Исходный код для 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