Page 1 of 1

Верёвочка

Posted: Sun Apr 21, 2013 7:14 am
by 0CodErr
Оригинал на VisualBasic: http://bit.pirit.info/forum/viewtopic.php?p=78682
Исходный код для FreeBasic:
Spoiler:

Code: Select all

  #Define TRUE  1
  
  '==============================================================================================
  'Количество точек
   Const NumP = 24
  'Начальная длина связей между точками
   Const RasstN = 2 * 20 / NumP
  'Коэффициент упругости связей
   Const lam = 50 / 20 * NumP
  'Масса каждой точки
   Const Mass = 8
  'Постоянная притяжения Земли
   Const g = 9.81
  'Количество циклов расчёта перед выводом информации
   Const propysk = 50 / 20 * NumP
  'Шаг расчётов по времени
   Const dt = 0.1 / propysk
  'Коэффициент сопротивления в воздухе
   Const sopr = 4
  'Отталкивание точек
  '0 - отталкивание разрешено
  '1 - точки не отталкиваются
   Const Ottalk = 0
  'Коэффициент трения о опору
   Const koefftr = 1
  'Отпустить второй конец
   Const bFree = True 
  '==============================================================================================

  Const PointWidth = 5	
	
  'Event Mask Constants  
  Const EM_REDRAW = &B1
  Const EM_KEY    = &B10
  Const EM_BUTTON = &B100
  Const EM_MOUSE  = &B100000

 ' Event Constants
  Const REDRAW_EVENT =  1
  Const KEY_EVENT    =  2
  Const BUTTON_EVENT =  3
  Const MOUSE_EVENT  =  6
  
 ' Color Constants
  Const COLOR_BLUE  =  &H000000FF
  Const COLOR_RED   =  &H00FF0000
  Const COLOR_GREEN =  &H0000FF00
  Const COLOR_WHITE =  &H00FFFFFF
  Const COLOR_BLACK =  &H00000000
  
  ' Window Style Constants
  Const WS_SKINNED_FIXED    = &H4000000
  Const WS_SKINNED_SIZABLE  = &H3000000
  Const WS_FIXED            = &H0000000
  Const WS_SIZABLE          = &H2000000
  Const WS_FILL_TRANSPARENT = &B1000000000000000000000000000000
  Const WS_FILL_GRADIENT    = &B10000000000000000000000000000000
  Const WS_COORD_CLIENT     = &B100000000000000000000000000000
  Const WS_CAPTION          = &B10000000000000000000000000000
  

  Type Size
    height As UShort
    width  As UShort
  End Type
  
  Type MousePos
    y As Short
    x As Short
  End Type
	
	
  '==============================================================================================
   Dim Shared pntsVX(0 To NumP + 1) As Single, pntsVY(0 To NumP + 1) As Single
   Dim Shared pntsXn(1 To NumP) As Single, pntsYn(1 To NumP) As Single
   Dim Shared dX As Single, dY As Single
   Dim Shared Rasst1 As Single, Rasst2 As Single
   Dim Shared F1 As Single, F2 As Single
   Dim Shared F1x As Single, F2x As Single
   Dim Shared F1y As Single, F2y As Single
   Dim Shared aX As Single, aY As Single
   Dim Shared pntsX(0 To NumP + 1) As Single
   Dim Shared pntsY(0 To NumP + 1) As Single   
   Dim Shared maxTop As Long = 525 
   Dim Shared i As Long, j As Long  
  '==============================================================================================	
	
  Dim Shared Window_width  As Long 
  Dim Shared Window_height As Long 
  Dim Shared Window_left   As Long
  Dim Shared Window_top    As Long	
  DIM Shared Caption       As ZString Ptr = @"Rope"
  Dim Shared MousePos      As MousePos
  Dim Shared Scr           As Size
  Dim Shared MX            As Long 
  Dim Shared MY            As Long 
	
	
	
	
	
  Declare Function CHECK_EVENT() As Long
  Declare Function GET_KEY_CODE() As Long
  Declare Function GET_BUTTON_NUMBER() As Long
  Declare Function GET_SCREEN_SIZE() As size 
  Declare Function GET_MOUSE_POS() As MousePos
  
  Declare Sub DRAW_WINDOW(Window_left As Long, Window_top As Long, Window_width As Long, Window_height As Long, Caption As ZString, BackColor As Long, Style As Long)
  Declare Sub DRAW_RECTANGLE(x As ULong, y As ULong, Rect_width As ULong, Rect_height As ULong, Rect_color  As ULong)
  Declare Sub DRAW_LINE(x1 As ULong, y1 As ULong, x2 As ULong, y2 As ULong, Line_color As ULong)
  #Undef SLEEP
  Declare Sub SLEEP(Sleep_time As ULong)
  
  Declare Sub On_Redraw()
  Declare Sub On_KeyPress() 
  Declare Sub On_ButtonPress() 
  Declare Sub On_MouseEvent()



#Undef RGB
#Define RGB(r,g,b) ((cuint(r) shl 16) or (cuint(g) shl 8) or cuint(b))

#Macro PROGRAM_TERMINATE()
  Asm
      or eax, -1
      int 64
  End Asm
#EndMacro

#Macro REDRAW_START()
  Asm
      mov eax, 12
      mov ebx, 1
      int 64    
  End Asm
#EndMacro

#Macro REDRAW_FINISH()
  Asm
      mov eax, 12
      mov ebx, 2
      int 64    
  End Asm
#EndMacro

#Macro SET_EVENT(mask)
  Asm
    mov eax, 40
    mov ebx, mask
    int 64
  End Asm
#EndMacro


                  Sub Main()
                    SET_EVENT(EM_REDRAW + EM_KEY + EM_BUTTON + EM_MOUSE)
                    Scr = GET_SCREEN_SIZE()
                    Window_width  = Scr.width \ 5 Shl 2 
                    Window_height = Scr.height \ 5 Shl 2 
                    Window_left   = (Scr.width  - Window_width) Shr 1
                    Window_top    = (Scr.height - Window_height) Shr 1
                    
                                        
                    On_Redraw

                    Do 
                    
                      For i = 0 To NumP
                        DRAW_LINE pntsX(i), pntsY(i), pntsX(i + 1), pntsY(i + 1), COLOR_WHITE
                        DRAW_RECTANGLE pntsX(i) - PointWidth/2, pntsY(i) - PointWidth/2, PointWidth, PointWidth, COLOR_WHITE
                      Next
                      
                      For j = 1 To propysk
                        For i = 1 To NumP 
                          dX = (pntsX(i - 1) + pntsVX(i - 1) * dt - pntsX(i))
                          dY = (pntsY(i - 1) + pntsVY(i - 1) * dt - pntsY(i))
                          Rasst1 = Sqr(dX * dX + dY * dY)
                          
                          dX = (pntsX(i + 1) + pntsVX(i - 1) * dt - pntsX(i))
                          dY = (pntsY(i + 1) + pntsVY(i - 1) * dt - pntsY(i))
                          Rasst2 = Sqr(dX * dX + dY * dY)
                          
                          If Rasst1 > RasstN * Ottalk Then
                            F1 = lam * (Rasst1 - RasstN)
                            F1x = F1 * (pntsX(i - 1) - pntsX(i)) / Rasst1
                            F1y = F1 * (pntsY(i - 1) - pntsY(i)) / Rasst1
                          Else
                            F1x = 0
                            F1y = 0
                          End If
                          
                          If Rasst2 > RasstN * Ottalk Then
                            F2 = lam * (Rasst2 - RasstN)
                            F2x = F2 * (pntsX(i + 1) - pntsX(i)) / Rasst2
                            F2y = F2 * (pntsY(i + 1) - pntsY(i)) / Rasst2
                          Else
                            F2x = 0
                            F2y = 0
                          End If
                          
                          aX = (F1x + F2x - pntsVX(i) * sopr) / Mass
                          aY = (F1y + F2y + Mass * g - pntsVY(i) * sopr) / Mass
                          
                          pntsXn(i) = pntsX(i) + pntsVX(i) * dt + aX * dt * dt / 2
                          pntsYn(i) = pntsY(i) + pntsVY(i) * dt + aY * dt * dt / 2
                          
                          pntsVX(i) = pntsVX(i) + aX * dt
                          pntsVY(i) = pntsVY(i) + aY * dt
                        Next i

                        For i = 1 To NumP
                          pntsX(i) = pntsXn(i)
                          If pntsYn(i) > maxTop Then
                            pntsYn(i) = maxTop
                            pntsVY(i) = 0
                            pntsVX(i) = pntsVX(i) * (1 - koefftr)
                          End If
                          pntsY(i) = pntsYn(i)
                        Next i
                        
                        If bFree Then
                          pntsX(NumP + 1) = pntsXn(NumP)
                          pntsY(NumP + 1) = pntsYn(NumP)
                        End If
                        
                      Next j

                      For i = 0 To NumP
                        DRAW_LINE pntsX(i), pntsY(i), pntsX(i + 1), pntsY(i + 1), RGB(0, 128, 128) \ (i + 1) 
                        DRAW_RECTANGLE pntsX(i) - PointWidth/2, pntsY(i) - PointWidth/2, PointWidth, PointWidth, RGB(64, 64, 128) \ (2 * i + 1) 
                      Next
                      
                      SLEEP 1
                      
                      Select Case CHECK_EVENT()
                        Case REDRAW_EVENT : On_Redraw
                        Case KEY_EVENT    : On_KeyPress
                        Case BUTTON_EVENT : On_ButtonPress
                        Case MOUSE_EVENT  : On_MouseEvent
                      End Select
                       
                    Loop 

                  End Sub

'========================================================='  
'                  Нажатие Клавиатуры
'========================================================='  
                  Sub On_KeyPress()
                    GET_KEY_CODE
                  End Sub

'========================================================='  
'                    Нажатие Кнопки
'========================================================='  
                  Sub On_ButtonPress()
                    Select Case GET_BUTTON_NUMBER()
                    Case 1
                      PROGRAM_TERMINATE()
                    End Select
                  End Sub
  
'========================================================='  
'                  Событие Мыши
'========================================================='  
                  Sub On_MouseEvent()
                    MousePos = GET_MOUSE_POS
                    If (MX <> MousePos.x) Or (MY <> MousePos.y) Then
                      DRAW_LINE pntsX(0), pntsY(0), pntsX(0 + 1), pntsY(0 + 1), RGB(255, 255, 255)
                      DRAW_RECTANGLE pntsX(0) - PointWidth/2, pntsY(0) - PointWidth/2, PointWidth, PointWidth, RGB(255, 255, 255)
                      pntsX(0) = MX
                      pntsY(0) = MY
                      DRAW_LINE pntsX(0), pntsY(0), pntsX(0 + 1), pntsY(0 + 1), RGB(0, 128, 128)
                      DRAW_RECTANGLE pntsX(0) - PointWidth/2, pntsY(0) - PointWidth/2, PointWidth, PointWidth, RGB(64, 64, 128)
                    End If
                    MX = MousePos.x
                    MY = MousePos.y    
                  End Sub  

'========================================================='  
'                   Перерисовка
'========================================================='  
                  Sub On_Redraw()
                    REDRAW_START()
                    DRAW_WINDOW   Window_left, Window_top, Window_width, Window_height, *Caption, COLOR_WHITE,  WS_SKINNED_SIZABLE + WS_COORD_CLIENT + WS_CAPTION
                    REDRAW_FINISH()
                  End Sub




Sub DRAW_WINDOW(Window_left As Long, Window_top As Long, Window_width As Long, Window_height As Long, Caption As ZString, BackColor As Long, Style As Long)
  Asm
      xor eax, eax
      mov ebx, [Window_left]
      shl ebx, 16
      add ebx, [Window_width]
      mov ecx, [Window_top]
      shl ecx, 16
      add ecx, [Window_height]
      mov edx, [Style]
      or  edx, [BackColor]
      mov edi, [Caption]
      int 64
  End Asm
End Sub

Function CHECK_EVENT() As Long
  Asm
    mov eax, 11
    Int 64
    mov [Function], eax
  End Asm
End Function

Function GET_KEY_CODE() As Long
  Asm
    mov eax, 2
    int 64
    movzx eax, ah  
    mov [Function], eax
  End Asm
End Function

Function GET_BUTTON_NUMBER() As Long
  Asm
    mov eax, 17
    int 64
    shr eax, 8
    mov [Function], eax
  End Asm
End Function

Function GET_SCREEN_SIZE() As size
  Asm
    mov eax, 61
    mov ebx, 1
    int 64
    mov [Function], eax
  End Asm
End Function

Sub DRAW_RECTANGLE(x As ULong, y As ULong, Rect_width As ULong, Rect_height As ULong, Rect_color  As ULong)
  Asm 
    mov eax, 13
    mov ebx, [x]
    shl ebx, 16
    add ebx, [Rect_width]
    mov ecx, [y]
    shl ecx, 16
    add ecx, [Rect_height]
    mov edx, [Rect_color]
    int 64
  End Asm
End  Sub 

Sub DRAW_LINE(x1 As ULong, y1 As ULong, x2 As ULong, y2 As ULong, Line_color As ULong)
  Asm 
    mov eax, 38
    mov ebx, [x1]
    shl ebx, 16
    add ebx, [x2]
    mov ecx, [y1]
    shl ecx, 16
    add ecx, [y2]
    mov edx, [Line_color]
    int 64
  End Asm 
End  Sub

Sub SLEEP(Sleep_time As ULong)
  Asm
    mov eax, 5
    mov ebx, [Sleep_time]
    int 64  
  End Asm
End Sub

Function GET_MOUSE_POS() As MousePos
  Asm 
    mov eax, 37
    mov ebx, 1
    int 64
    mov [Function], eax
  End Asm
END Function
Скриншот:
Spoiler:Image
Rope.kex (1.13 KiB)
Downloaded 362 times

Re: Верёвочка

Posted: Sun May 26, 2013 8:19 am
by SoUrcerer
Ох, а я писал подобный код. Есть мнение, что если добавить еще толщину, и если она сможет быть переменной, и если можно будет произвольные стыки делать - то у такой проги будет спрос

Re: Верёвочка

Posted: Tue May 28, 2013 1:16 am
by Leency
Забавно) но артефакты немного портят впечатление
Spoiler:
1.png
1.png (42.98 KiB)
Viewed 6204 times