Skip to content

Instantly share code, notes, and snippets.

@klaszlo8207

klaszlo8207/Engine.bas

Last active January 23, 2023 08:32
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save klaszlo8207/a5c3f15c43648346558737ce1064c67b to your computer and use it in GitHub Desktop.
Save klaszlo8207/a5c3f15c43648346558737ce1064c67b to your computer and use it in GitHub Desktop.
Download ZIP
Engine.bas 2003 körüli Visual Basic 6.0 szakdolgozat kódom egy része
Raw
Engine.bas
Attribute VB_Name = "mEngine"
'---------------------------------------------------_
' Billiard 3GL : the ENGINE, created it in Opengl 1.2
'---------------------------------- ----------- --_
' I / \/ \ I
'\____/--------------\______/--- I/\__/\_/\I
' created by: /(o)(o)\ -
'\____/--------------\______/---\___/--\__O_O_/ _/-
' KOZaRI / /LLI\ \_/_--
' LaSZLO(Laca) in 2003.02.-08 / / \--/ -
'------___________-------_______----_-\__--\__/______
'BBBBB II LL LL II AAA RRRRRR DDDDDD
'BB BB II LL LL II AAAA RR RR DD DD
'BBBBB II LL LL II AA AA RRRRRR DD DD
'BB BB II LL LL II AAAAAA RR RR DD DD
'BB BB II LL LL II AA AA RR RR DD DD
'BBBBB II LLLLLL LLLLLL II AA AA RR RR DDDDDD
'---------------------------------------------
'-KOMMENT-
'A "Motorba" raktam a lényegesebb dolgokat, a többi
'globális változót a VARIABLES Nameű Modulban helyeztem
'el, így egy kicsit (szerintem) áttekinthetőbb.
'Itt tulajdonképpen a játék fizikájával kapcsolatos
'konstansok, illetve típusok, változók vannak...
'A VARIABLES modulban az API hívások, valamint a
'képernyőkezelés, OPENGL-es változók, textúrakezelés
'változói vannak, és néhány egyéb cuccos is...
'---------------------------------------------
'---------------------------------------------
'Public Konstansok
'---------------------------------------------
Public Const N As Byte = 15 'labdák száma N+1
Public Const MU As Single = 0.002 '/mű/x
Public Const BALL_WEIGHT As Single = 0.0015 '1 golyo BALL_WEIGHTe sacc/kb
Public Const GRAVITATION As Single = 9.81 '9.81 helyett a gravitáció
'---------------------------------------------
'A golyó Típus
'---------------------------------------------
Type objectBall
x As Double 'X,Y
y As Double
z As Double 'Z alap érték...
VelX As Double 'SebességX,Y,mivel sik
VelY As Double
VelZ As Double
Velocity As Double
Rotation As Double
OldRot As Double
OldRotXYZ As Vect3
Rad As Double 'Radiusz
name As String 'pl.fekete8
Type As String 'pl.teli
OnTable As Boolean 'Legurult-e vagy se?
RolledDownInRound As Integer 'Melyik körben ment le, ha lement _
Ha 0 akkor még fenn van...
End Type
'---------------------------------------------
'Globális Változók
'---------------------------------------------
Public Balls(N) As objectBall 'N+1 db golyó 15+1
Public Round As Integer 'hányadik kör
Public NotOnTable As Byte 'legurultak...
Public Sub FirstRun()
'---------------------------------------------
'First Run modul
'---------------------------------------------
NotOnTable = 0
RunGame = True
CueAnim = True
'---------------------------------------------
'RADIUS adása, golyók értékeinek, Nameeinek adása stb..
'---------------------------------------------
For i = 0 To N
'---------------------------------------------
With Balls(i)
.OnTable = True 'nem ment le
.VelX = 0 'x,y kezdősebesség
.VelY = 0 ' -""-
.z = -2.2 'alap Z
.Rad = 0.036 'Balls nagysága
.RolledDownInRound = 0 'Mindegyik fenn van
End With
'---------------------------------------------
'Golyók felállítása...
'Kezdő X értékek
START_X0 = (i / 15.1) - 0.63 + CAMERA_X
START_X1 = (i / 15.1) + CAMERA_X + 0.1
START_X2 = ((i - 4) / 15.1) + CAMERA_X + 0.1
START_X3 = ((i - 7) / 15.1) + CAMERA_X + 0.1
START_X4 = ((i - 9) / 15.1) + CAMERA_X + 0.1
START_X5 = ((i - 10) / 15.1) + CAMERA_X + 0.1
'---------------------------------------------
'Kezdő Y értékek
vy = -0.07 '91
START_Y0 = (1 / 15.1) + vy + CAMERA_Y
START_Y1 = (i / 15.1) + vy + CAMERA_Y
START_Y2 = ((i - 4) / 15.1) - (2 / 15.1) + vy + CAMERA_Y
START_Y3 = ((i - 4) / 15.1) - (7 / 15.1) + vy + CAMERA_Y
START_Y4 = ((i - 4) / 15.1) - (11 / 15.1) + vy + CAMERA_Y
START_Y5 = ((i - 4) / 15.1) - (14 / 15.1) + vy + CAMERA_Y
Select Case i
'---------------------------------------------
'A fehér golyó...
Case 0:
Balls(i).x = START_X0
Balls(i).y = START_Y0
Balls(i).VelX = 0
Balls(i).VelY = 0
Balls(i).name = "feher0"
Balls(i).Type = "feher"
'A többi golyó...
'---------------------------------------------
'1.sor
Case 1:
Balls(i).x = START_X1
Balls(i).y = START_Y1
Balls(i).name = "sarga1"
Balls(i).Type = "teli"
Case 2:
Balls(i).x = START_X1
Balls(i).y = START_Y1 - 0.03
Balls(i).name = "lila4"
Balls(i).Type = "teli"
Case 3: '
Balls(i).x = START_X1
Balls(i).y = START_Y1 - (0.03 * 2)
Balls(i).name = "piros11"
Balls(i).Type = "csikos"
Case 4:
Balls(i).x = START_X1
Balls(i).y = START_Y1 - (0.03 * 3)
Balls(i).name = "barna15"
Balls(i).Type = "csikos"
Case 5:
Balls(i).x = START_X1
Balls(i).y = START_Y1 - (0.03 * 4)
Balls(i).name = "barna7"
Balls(i).Type = "teli"
'---------------------------------------------
'2.sor
Case 6:
Balls(i).x = START_X2
Balls(i).y = START_Y2 + 0.03
Balls(i).name = "kek10"
Balls(i).Type = "csikos"
Case 7:
Balls(i).x = START_X2
Balls(i).y = START_Y2
Balls(i).name = "fekete8"
Balls(i).Type = "fekete"
Case 8:
Balls(i).x = START_X2
Balls(i).y = START_Y2 - 0.03
Balls(i).name = "zold14"
Balls(i).Type = "csikos"
Case 9:
Balls(i).x = START_X2
Balls(i).y = START_Y2 - (0.03 * 2)
Balls(i).name = "narancs13"
Balls(i).Type = "csikos"
'---------------------------------------------
'3.sor
Case 10:
Balls(i).x = START_X3
Balls(i).y = START_Y3 + (0.03 * 2)
Balls(i).name = "kek2"
Balls(i).Type = "teli"
Case 11:
Balls(i).x = START_X3
Balls(i).y = START_Y3 + 0.03
Balls(i).name = "piros3"
Balls(i).Type = "teli"
Case 12:
Balls(i).x = START_X3
Balls(i).y = START_Y3
Balls(i).name = "zold6"
Balls(i).Type = "teli"
'---------------------------------------------
'4.sor
Case 13:
Balls(i).x = START_X4
Balls(i).y = START_Y4 + (0.03 * 3)
Balls(i).name = "sarga9"
Balls(i).Type = "csikos"
Case 14:
Balls(i).x = START_X4
Balls(i).y = START_Y4 + (0.03 * 2)
Balls(i).name = "lila12"
Balls(i).Type = "csikos"
'---------------------------------------------
'5.sor-utolso
Case 15:
Balls(i).x = START_X5
Balls(i).y = START_Y5 + (0.03 * 4)
Balls(i).name = "narancs5"
Balls(i).Type = "teli"
End Select
Next i
'---------------------------------------------
End Sub
Public Sub Modelling()
'---------------------------------------------
'A tényleges ModellingÉS itt kezdődik, _
ez az a Procedura/Sub, amelyben benne _
vannak a surlodások, visszapattanások, stb... _
VAGYIS A TÉNYLEGES biLLiaRd FIZIKAi MODELL
'---------------------------------------------
Dim i As Byte
Dim cfreq As Currency
Dim cuStart As Currency
Dim cuStop As Currency
Dim stop1 As Currency
Dim start1 As Currency
Dim sFPS As Single
'---------------------------------------------
deltaT = 1
QueryPerformanceFrequency cfreq
Do While RunGame
'FPS számolása
QueryPerformanceCounter cuStart
'Rezet Velocity változó
Velocity = 0
'Kurzorok-----------------
Call Main.ChangeCursor
Call drawOtherCue
'FPS kirakása x időközönként
If GetTickCount - Elapsed9 >= 400 Then
Fps_Now = sFPS
Elapsed9 = GetTickCount
End If
'Tick count
'Vagyis midnen gépen egy sebességgel fut már..
If GetTickCount - Elapsed8 >= deltaT Then
start1 = GetTickCount()
'==============
If mdown Then Call mGame.CueShot
Call AutomaticStrength
For i = 0 To N 'N+1 golyoval // fehér+15
If Balls(i).OnTable Then
Call SearchMaxVelocity
'X,Y súrlódás
Call Friction(i)
'Visszapattanások
Call CollisionWithTable(i)
'Ütközések figyelése...
Call CollisionWithBall(i)
If Not Balls(0).VelX = 0 And _
Not Balls(0).VelY = 0 Then Mistake = False
End If
Next i
'---------------------------------------------
If AllVelocity0 Then MouseDowned = False
stop1 = GetTickCount()
deltaT = stop1 - start1
'Kirajzolja a golyók fizikáját.Renderel.
Call RenderIt.RenderAll 'A golyók "szédelegnek" még
Elapsed8 = GetTickCount()
End If
'FPS számolása
QueryPerformanceCounter cuStop
sFPS = 1 / ((cuStop - cuStart) / cfreq)
DoEvents
'==========
Loop
'---------------------------------------------
End Sub
Public Sub Friction(i As Byte)
'---------------------------------------------
'Golyók súrlódásának a számítása az alapképlet _
alapján: _
sF=Fs súrlódási erő _
sF = MU * BALL_WEIGHT * GRAVITATION
'---------------------------------------------
Dim FrictionX As Double
Dim FrictionY As Double
Dim SPF As Double
sF = (MU * BALL_WEIGHT * GRAVITATION)
'---------------------------------------------
'Ha a sebesség 0-hoz közeli érték...
'---------------------------------------------
Velocity = Sqr(Balls(i).VelX ^ 2 + Balls(i).VelY ^ 2)
If Velocity <= 0.01 / 100 Then
Balls(i).VelX = 0
Balls(i).VelY = 0
Exit Sub
End If
'---------------------------------------------
'sF=Fs súrlódási erő
'---------------------------------------------
If Balls(i).VelX = 0 Then angle = 0 Else: angle = Atn(Balls(i).VelY / Balls(i).VelX)
FrictionX = Abs(sF * Cos(angle))
FrictionY = Abs(sF * Sin(angle))
If Balls(i).VelX > 0 Then FrictionX = -FrictionX
If Balls(i).VelY > 0 Then FrictionY = -FrictionY
Balls(i).VelX = Balls(i).VelX + FrictionX
Balls(i).VelY = Balls(i).VelY + FrictionY
Balls(i).Velocity = Sqr(Balls(i).VelX ^ 2 + Balls(i).VelY ^ 2)
'---------------------------------------------
End Sub
Public Function CollisionWithTable(i As Byte) As Boolean
'---------------------------------------------
'X-Y visszapatableTopanások a falakról...
'"Szédelgés"...
'---------------------------------------------
'OPENGL asztalméret 800*600-ban.
'---------------------------------------------
CollisionWithTable = False
tableLeft = TABLE_LEFT + CAMERA_X
tableRight = TABLE_RIGHT + CAMERA_X
tableTop = TABLE_TOP + CAMERA_Y
tableBottom = TABLE_BOTTOM + CAMERA_Y
backRollDistance = (Balls(i).Rad / 200)
'---------------------------------------------
If RolledDownBall(tableLeft, tableRight, tableTop, tableBottom, backRollDistance, i) = True Then
If SoundIn Then PlayTheSound 3
Exit Function
End If
'---------------------------------------------
'X visszapatableTopanások
If (Balls(i).x - backRollDistance <= tableLeft) Then
Balls(i).VelX = -Balls(i).VelX
Balls(i).x = tableLeft + backRollDistance
CollisionWithTable = True
End If
If (Balls(i).x + backRollDistance >= tableRight) Then
Balls(i).VelX = -Balls(i).VelX
Balls(i).x = tableRight - backRollDistance
CollisionWithTable = True
End If
Balls(i).x = Balls(i).x + Balls(i).VelX 'jo
'---------------------------------------------
'Y visszapatableTopanások
If (Balls(i).y - backRollDistance <= tableTop) Then
Balls(i).VelY = -Balls(i).VelY
Balls(i).y = tableTop + backRollDistance
CollisionWithTable = True
End If
If (Balls(i).y + backRollDistance >= tableBottom) Then
Balls(i).VelY = -Balls(i).VelY
Balls(i).y = tableBottom - backRollDistance
CollisionWithTable = True
End If
Balls(i).y = Balls(i).y + Balls(i).VelY
Velocity = Sqr(Balls(i).VelX ^ 2 + Balls(i).VelY ^ 2)
If CollisionWithTable And (Velocity > 0) Then
If SoundIn Then PlayTheSound 2
End If
'---------------------------------------------
End Function
Public Sub CollisionWithBall(i As Byte)
'---------------------------------------------
'Ütközések a golyók között
'---------------------------------------------
For j = 0 To N
If Balls(i).OnTable And Balls(j).OnTable Then
If i <> j Then ChangeVelocity Balls(j), Balls(i)
End If
Next j
'---------------------------------------------
End Sub
Public Sub ChangeVelocity(a As objectBall, b As objectBall)
'---------------------------------------------
'A TULAJDONKÉPPENI 'MOTOR'
'---------------------------------------------
Dim X1 As Single, Y1 As Single
Dim X2 As Single, Y2 As Single
Dim dxx As Single, dyy As Single
Dim lll As Single, ggg As Single
Dim deltaX As Single, deltaY As Single
X1 = a.x: X2 = b.x
Y1 = a.y: Y2 = b.y
'---------------------------------------------
'a távolság a 2 g. között.
Distance = Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)
'---------------------------------------------
'Hogyha kisebb a táv köztük, akRound koccannak..
'---------------------------------------------
If Distance >= (a.Rad + b.Rad) - 0.005 Then
If Round > 0 And FirstCollision = False Then FirstTouched = "nothing"
Exit Sub
ElseIf Distance < (a.Rad + b.Rad) - 0.005 Then 'Kisebb...
'---------------------------------------------
'Az első koccanás vizsgálata...
'A fehér és vmelyik golyo között.
'---------------------------------------------
If FirstCollision Then GoTo at:
FirstCollision = True
FirstTouched = a.Type
at:
'---------------------------------------------
'Max. X,Y seb. keresése
Call SearchMaxVelocity
'---------------------------------------------
'golyók szét...
dxx = (b.x - a.x) 'x y távolság
dyy = (b.y - a.y)
lll = Sqr(dxx ^ 2 + dyy ^ 2) 'tényleges táv
ggg = (a.Rad + b.Rad) - lll
deltaX = (ggg / lll) * dxx
deltaY = (ggg / lll) * dyy
b.x = b.x + deltaX
b.y = b.y + deltaY
'Elszakadás megtörtént...
'---------------------------------------------
'A szög kiszámítása
angle = Atn((Y2 - Y1) / (X2 - X1))
'Az ütközés melletti sebességek meghatározása
X1 = a.VelX * Cos(-angle) - a.VelY * Sin(-angle)
Y1 = a.VelX * Sin(-angle) + a.VelY * Cos(-angle)
X2 = b.VelX * Cos(-angle) - b.VelY * Sin(-angle)
Y2 = b.VelX * Sin(-angle) + b.VelY * Cos(-angle)
'X Sebesség komponens csere
'Y sebesség ugyanaz marad
'Majd visszaállítjuk a normál koordinátákat
newX1 = X2 * Cos(angle) - Y1 * Sin(angle)
newY1 = X2 * Sin(angle) + Y1 * Cos(angle)
newX2 = X1 * Cos(angle) - Y2 * Sin(angle)
newY2 = X1 * Sin(angle) + Y2 * Cos(angle)
'Sebességek vissza...
a.VelX = newX1
a.VelY = newY1
b.VelX = newX2
b.VelY = newY2
'---------------------------------------------
'kocc.wav
Velocity = Sqr(a.VelX ^ 2 + a.VelY ^ 2)
If (Velocity > 0) And (CueAnim = False) Then
If SoundIn Then PlayTheSound 1 'Sounds(3), 0, SND_ASYNC
End If
End If
'---------------------------------------------
End Sub
Public Function RolledDownBall(tableLeft, tableRight, tableTop, tableBottom, backRollDistance, i As Byte) As Boolean
'---------------------------------------------
'Lyukat ért-e a golyó?
'---------------------------------------------
RolledDownBall = False 'Alapból nem...
BackRollDist_01 = backRollDistance * 100
BackRollDist_02 = backRollDistance * 250
BackRollDist_03 = backRollDistance * 10
'---------------------------------------------
'Szélső 4 lyuk ellenőrzése
'---------------------------------------------
'Tökéletesítve..
'---------------------------------------------
If Balls(i).OnTable = True Then 'hogyha még fenn van...
'---------------------------------------------
'felsojobb
If (Balls(i).x + BackRollDist_01 > tableRight) And _
(Balls(i).y + BackRollDist_01 > tableBottom) Then
Hole = 3
GoTo le_gurult:
'---------------------------------------------
'alsobal
ElseIf (Balls(i).x - BackRollDist_01 <= tableLeft) And _
(Balls(i).y - BackRollDist_01 <= tableTop) Then
Hole = 4
GoTo le_gurult:
'---------------------------------------------
'alsojobb
ElseIf (Balls(i).x + BackRollDist_01 > tableRight) And _
(Balls(i).y - BackRollDist_01 <= tableTop) Then
Hole = 6
GoTo le_gurult:
'---------------------------------------------
'felsobal
ElseIf (Balls(i).x - BackRollDist_01 <= tableLeft) And _
(Balls(i).y + BackRollDist_01 > tableBottom) Then
Hole = 1
GoTo le_gurult:
'---------------------------------------------
'És a középső 2 ellenőrzése
ElseIf (Balls(i).x < -0.08 + BackRollDist_02) And _
(Balls(i).x > -0.12 - BackRollDist_02) And _
(Balls(i).y < tableTop + BackRollDist_03) Then
Hole = 4
GoTo le_gurult:
'---------------------------------------------
ElseIf (Balls(i).x <= -0.08 + BackRollDist_02) And _
(Balls(i).x >= -0.12 - BackRollDist_02) And _
(Balls(i).y > tableBottom - BackRollDist_03) Then
Hole = 2
GoTo le_gurult:
End If
End If
Exit Function
'---------------------------------------------
'---------------------------------------------
le_gurult: 'Gazdaságosabb megoldás _
Egy jó programozó nem fél a goto-ktol:)
'az adotableTop golyó melyik körben ment le az asztalról
Balls(i).RolledDownInRound = Round
RolledDown = RolledDown + 1
RolledDownNOW = RolledDownNOW + 1
ReDim RolledDownInThisRound(RolledDown)
RolledDownInThisRound(RolledDown) = i
Balls(i).OnTable = False
Balls(i).VelX = 0
Balls(i).VelY = 0
RolledDownBall = True
'---------------------------------------------
If Balls(i).name = "feher0" Then
'Ha a fehér lemegy
Balls(i).x = (tableRight + BackRollDist_01 + 0.3)
Balls(i).y = tableBottom + 0.1
Main.WhiteToTable.Visible = True
Exit Function
End If
NotOnTable = NotOnTable + 1
Balls(i).x = (tableRight + BackRollDist_01 + 0.1) - (NotOnTable * 0.075) + 0.32
Balls(i).y = (tableTop - BackRollDist_01 - 0.15) + 1.67
'---------------------------------------------
End Function
Public Sub SearchMaxVelocity()
'---------------------------------------------
'Maximális X,Y sebesség keresés a golyók
'között...
'---------------------------------------------
Dim k As Byte
Dim MaxX As Byte
Dim MaxY As Byte
Dim Str As String
MaxX = 0: MaxY = 0
'---------------------------------------------
'Hányas számu golyonak a legnagyobb SX,SY.-ja?
'---------------------------------------------
For k = 1 To N
If Balls(k).OnTable And (Abs(Balls(k).VelX) > Abs(Balls(MaxX).VelX)) Then MaxX = k
If Balls(k).OnTable And (Abs(Balls(k).VelY) > Abs(Balls(MaxY).VelY)) Then MaxY = k
Next k
If (Abs(Balls(MaxX).VelX) > Abs(Balls(MaxY).VelY)) Then: Velocity = Sqr(Balls(MaxX).VelX ^ 2 + Balls(MaxX).VelY ^ 2)
If (Abs(Balls(MaxX).VelX) < Abs(Balls(MaxY).VelY)) Then: Velocity = Sqr(Balls(MaxY).VelX ^ 2 + Balls(MaxY).VelY ^ 2)
'---------------------------------------------
'Hogyha a sebessége 0, akkor dákóanim...
'---------------------------------------------
If (Velocity = 0) And (Balls(MaxX).OnTable Or Balls(MaxY).OnTable) Then
If Balls(0).OnTable Then
CueAnim = True
'K ö v e t k e z ő j á t é k o s . . .
If Mistake = False Then Call NextPlayer1
' ShowCursor 1
End If
End If
Call AnalizeBall2
Call SelectType1(Seb)
'---------------------------------------------
End Sub
Public Function SelectType2(NextPlayR As Players, LastPlayR As Players) As Boolean
'---------------------------------------------
'Csak az első X körben, típusválasztás...
'Ameddig nincs eldöntve, hogy teli vagy csikos-e
'---------------------------------------------
SelectType2 = False
Dim TipusA As Byte, TipusB As Byte
For i = 0 To N
If (Not Balls(i).OnTable) And _
(Balls(i).Type = "csikos") Then
TipusA = TipusA + 1
ElseIf (Not Balls(i).OnTable) And _
(Balls(i).Type = "teli") Then
TipusB = TipusB + 1
End If
Next i
If TipusA > TipusB Then NextPlayR.Type = "csikos": LastPlayR.Type = "teli"
If TipusA < TipusB Then NextPlayR.Type = "teli": LastPlayR.Type = "csikos"
If TipusA = TipusB Then Exit Function
SelectType2 = True
'---------------------------------------------
End Function
Public Sub SelectType1(Seb)
'---------------------------------------------
'Tipusválasztás-teli vagy csikos...
'---------------------------------------------
If Screens = 2 Then
If ((Velocity = 0) And (Round = 1)) Or ((Velocity = 0)) Then
If SelectedType Then Exit Sub
If NextPlayer = 1 Then 'Player1
If SelectType2(Player1, Player2) = True Then
SelectedType = True
Else
SelectedType = False
End If
ElseIf NextPlayer = 2 Then 'Player2
If SelectType2(Player2, Player1) = True Then
SelectedType = True
Else
SelectedType = False
End If
End If
If SentType = True Then Exit Sub
If SelectedType Then Call SendNameTypePoints: SentType = True
End If
End If
'---------------------------------------------
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment