03-04-2023, 08:28 PM
On purpose. Who remembers my first program, back on the old
![[Image: voll.png]](https://i.ibb.co/yskGcvM/voll.png)
Galleon forum?
Hey guys, don't expect any physics! This was written purely for the show, for the joy of writing! Forget about any calculations! This is just total crap I love! PBF file is need!
After downloading file voll.zip do not try extract it, just rename it as voll.pbf, forum allow not add this file directly, then copy it to the same folder with source code.
Galleon forum?
Hey guys, don't expect any physics! This was written purely for the show, for the joy of writing! Forget about any calculations! This is just total crap I love! PBF file is need!
Code: (Select All)
'programmed Petr Preclik. Contains none graphics orgy.
'DATE: 04/2018
Screen 13
_FullScreen
_MouseHide
ReDim Shared sn(0) As String
Dim Shared bigs As Integer, VidL, VidP, LevyX, LevyY, levysmer, PravyX, PravyY, pravysmer, start, BalonX, BalonY, left, right, SmerX, SmerY, rest, Balon, BalonTime, Vyskok, LeftPlayer, RightPlayer, I$, autostarted, ODPOCET, oldleft, oldright, vs, snd
bigs = reader("voll.pbf")
Balon = 5
PravyX = 150: PravyY = 101: VidP = 10
LevyX = 40: LevyY = 102: VidL = 1
pravysmer = 0
snd = 1
start:
SmerY = 1
start = 0
BalonX = 125: BalonY = 10
If left = 0 And right = 0 And autostarted = 0 Then menu
Cls: _AutoDisplay
If _FileExists("voll.pbf") Then
Do While I$ <> Chr$(27)
_PrintMode _KeepBackground
' COLOR 0, 2
If oldleft <> left Then oldleft = left: score$ = Str$(left) + "-" + Str$(right): Locate 23, (80 - Len(score$)) / 2: Print score$
If oldright <> right Then oldright = right: Locate 23, 17: Print left; " - "; right
If autostarted = 0 Then I$ = InKey$
Color 15, 0
'============================================
If vs And autostarted Then
l = l + 1
Select Case l
Case 1
j$ = InKey$
If j$ = Chr$(27) Then
autostarted = 0: vs = 0: ODPOCET = Timer: j$ = "": GoTo start
Else I$ = j$
End If
Case 2
AUTOSTART 1: l = 0
End Select
End If
'=============================================
If Timer > ODPOCET And vs = 0 Then AUTOSTART 0
TestSmeru
If rest Then rest = 0: GoTo start
Select Case I$
Case "S", "s": start = 1: ODPOCET = 99999: pisk
Case Chr$(0) + Chr$(77)
pravysmer = 1
VidP = VidP + 1: If VidP > 13 Then VidP = 10
PravyX = PravyX + 1
If PravyX > 270 Then
PravyX = 270
doraz
End If
Case "D", "d"
levysmer = 1
VidL = VidL + 1: If VidL > 4 Then VidL = 1
LevyX = LevyX + 1
If LevyX > 100 Then
LevyX = 100
doraz
End If
Case Chr$(0) + Chr$(75)
pravysmer = 2
VidP = VidP - 1: If VidP < 10 Then VidP = 13
PravyX = PravyX - 1
If PravyX < 150 Then
PravyX = 150
doraz
End If
Case "A", "a"
levysmer = 2
VidL = VidL - 1: If VidL < 1 Then VidL = 4
LevyX = LevyX - 1
If LevyX < 10 Then
LevyX = 10
doraz
End If
Case Chr$(13)
If delkaskoku = 0 Then delkaskoku = Timer + .50
While delkaskoku > 0
Vyskok = 1
TestBalonu
TestSmeru
Select Case delkaskoku - Timer
Case Is > .25: PravyY = PravyY - 2
' TestBalonu
If PravyY < 20 Then PravyY = 20
If pravysmer = 1 Then
VidP = VidP + 1: If VidP > 13 Then VidP = 10
PravyX = PravyX + 1
If PravyX > 270 Then
PravyX = 270
doraz
End If
End If
If pravysmer = 2 Then
VidP = VidP - 1: If VidP < 10 Then VidP = 13
PravyX = PravyX - 1
If PravyX < 150 Then
PravyX = 150
doraz
End If
End If
Case Is < .25
' TestBalonu
PravyY = PravyY + 2
If PravyY >= 101 Then
PravyY = 101
delkaskoku = 0
I$ = ""
End If
End Select
okoli
rozpis VidP, PravyX, PravyY
rozpis Balon, BalonX, BalonY
rozpis VidL, LevyX, LevyY
rozpis 9, 130, 100
Line (0, 163)-(320, 163)
_Display
_Limit 30
Cls
Wend
Case Chr$(32)
If delkaskokuL = 0 Then delkaskokuL = Timer + .50
While delkaskokuL > 0
Vyskok = 1
TestBalonu
TestSmeru
Select Case delkaskokuL - Timer
Case Is > .25
' TestBalonu
LevyY = LevyY - 2
If LevyY < 20 Then levy = 20
If levysmer = 1 Then
VidL = VidL + 1: If VidL > 4 Then VidL = 1
LevyX = LevyX + 1
If LevyX > 100 Then
LevyX = 100
doraz
End If
End If
If levysmer = 2 Then
VidL = VidL - 1: If VidL < 1 Then VidL = 4
LevyX = LevyX - 1
If LevyX < 10 Then
LevyX = 10
doraz
End If
End If
Case Is < .25
'TestBalonu
LevyY = LevyY + 2
If LevyY >= 102 Then
LevyY = 102
delkaskokuL = 0
I$ = ""
End If
End Select
okoli
rozpis VidP, PravyX, PravyY
rozpis Balon, BalonX, BalonY
rozpis VidL, LevyX, LevyY
rozpis 9, 130, 100
Line (0, 163)-(320, 163)
_Display
_Limit 30
Cls
Wend
End Select
TestBalonu
If Timer > BalonTime Then BalonTime = Timer + .5: Balon = Balon + 1: If Balon > 8 Then Balon = 5
okoli
rozpis VidP, PravyX, PravyY ' right player frame, coordinate X, coordinate Y
rozpis Balon, BalonX, BalonY ' ball frame, coordinate X, coordinate Y
rozpis VidL, LevyX, LevyY ' left player frame, coordinate X, coordinate Y
rozpis 9, 130, 100
Line (0, 163)-(320, 163)
_Display
_Limit 30
Cls
Loop
left = 0: right = 0: autostarted = 0: vs = 0
GoTo start
Else
Print "voll.pbf not found!": Sleep 2: System
End If
Sub menu
Shared netiskni
netiskni = 0
_AutoDisplay: _KeyClear
I$ = ""
If Not vs Then ODPOCET = Timer + 30
SmerY = 1
start = 0
BalonX = 125: BalonY = 10
fto& = _NewImage(60, 60, 256)
_Dest fto&
rozpis 7, 0, 0
_Dest 0
netiskni = 1
po = 50
Do While I$ <> Chr$(27)
Cls
uhel = uhel + 3: If uhel > 360 Then uhel = 1
rotation fto&, 80, po, uhel, 1.5
I$ = InKey$
If Timer > ODPOCET And vs = 0 Then I$ = "3"
center 10, "Volleyball - B/W"
center 25, "Press keys 1 - 6 or arrows and enter"
_PrintString (100, 50), "1: 1 player and computer"
_PrintString (100, 70), "2: 2 players"
_PrintString (100, 90), "3: demo"
_PrintString (100, 110), "4: About"
_PrintString (100, 130), "5: Sound setup"
_PrintString (100, 150), "6: End"
Select Case I$
Case Chr$(0) + Chr$(80): po = po + 20
Case Chr$(0) + Chr$(72): po = po - 20
Case Chr$(13): I$ = Str$(((po + 10) / 20) - 2)
End Select
Select Case Val(I$)
Case 3: ODPOCET = Timer: Exit Sub ' AUTOSTART 2 PLRS
Case 2: autostarted = 0: Exit Sub ' PLAY GAME 2 PLRS
Case 4: about: menu ' ABOUT
Case 5: If snd = 0 Then snd = 1: _PrintString (100, 180), "Sound ON": _Display: Sleep 2 Else snd = 0: _PrintString (100, 180), "Sound OFF": _Display: Sleep 2 ' SOUND
Case 6: _FreeImage fto&: _MouseShow: System ' QUIT
Case 1: AUTOSTART 1: ODPOCET = Timer: Exit Sub ' CLS: menu ' PLAY GAME 1 PLR VS PC
End Select
If po > 150 Then po = 150
If po < 50 Then po = 50
If Len(I$) And I$ <> "3" Then ODPOCET = Timer + 30 'NYNI
_Display
_Limit 20
I$ = ""
Loop
End Sub
Sub about
Cls
Locate 2
Print "About:"
Locate 5
Print "This is game for 0 or 1 or 2 players. "
Print "Its shared so as it is, without hiscore."
Print "Contains automatic demo start after 30 sec."
Print
Locate 12
Print "Use A, D for move left player, S for "
Print "Ball, space for jump left."
Print "Use arrows left and right for move right"
Print "player, enter for jump right."
Print
Locate 20
Print "Writed Petr P."
Print
Print "Press key...."
_Display
Sleep
End Sub
Sub center (lin As Integer, text As String)
centr = (_Width / 2 - _PrintWidth(text) / 2)
_PrintString (centr, lin), text$
End Sub
Sub AUTOSTART (mode)
Shared tah
Select Case mode
Case 0 ' this is call if plays PC vs PC
autostarted = 1
If start = 0 Then start = 1
tah = tah + 1
Select Case tah
Case 1: If BalonX - 30 > LevyX Then I$ = "d" ' on coordinates based computer "intelligence"
Case 2: If BalonX - 30 < LevyX Then I$ = "a"
Case 3: If BalonX + 60 > PravyX Then I$ = Chr$(0) + LTrim$(Chr$(77))
Case 4: If BalonX + 30 < PravyX Then I$ = Chr$(0) + LTrim$(Chr$(75))
Case 5: If BalonX + 60 > 220 Then I$ = Chr$(13)
Case 6: If BalonX - 30 < 40 Then I$ = " "
tah = 0
End Select
If InKey$ <> "" Then autostarted = 0: ODPOCET = Timer + 20: left = 0: right = 0: restart 3
Case 1 ' this run, if plays human vs computer.
vs = 1
autostarted = 1
If start = 0 Then start = 1
tah = tah + 1
ODPOCET = Timer
' SHARED j$
Select Case tah
Case 5: If BalonX - 30 > LevyX Then I$ = "d" ' computer drive one player.
Case 6: If BalonX - 30 < LevyX Then I$ = "a"
Case 7: If BalonX - 30 < 90 Then I$ = Chr$(32)
End Select
If tah > 9 Then tah = 0
End Select
End Sub
Sub TestSmeru ' sub for testing how player go. If to right or to left.
Select Case pravysmer
Case 1
VidP = VidP + 1: If VidP > 13 Then VidP = 10
PravyX = PravyX + 1
If PravyX > 270 Then
PravyX = 270: pravysmer = 0
doraz
End If
Case 2
VidP = VidP - 1: If VidP < 10 Then VidP = 13
PravyX = PravyX - 1
If PravyX < 150 Then
doraz
PravyX = 150: pravysmer = 0
End If
End Select
Select Case levysmer
Case 1
VidL = VidL + 1: If VidL > 4 Then VidL = 1
LevyX = LevyX + 1
If LevyX > 100 Then
LevyX = 100: levysmer = 0
doraz
End If
Case 2
VidL = VidL - 1: If VidL < 1 Then VidL = 4
LevyX = LevyX - 1
If LevyX < 10 Then
LevyX = 10: levysmer = 0
doraz
End If
End Select
End Sub
Sub TestBalonu ' sub for testing ball fly
If start = 1 Then
If Timer Mod 5 = 0 And Sgn(SmerY) = 1 Then SmerY = SmerY + .0981
If Timer Mod 5 = 0 And Sgn(SmerY) = -1 Then SmerY = SmerY + -0.0981
If Abs(SmerY) > 3 Then SmerY = 3 * Sgn(SmerY)
If Abs(SmerX) > 3 Then SmerX = 3 * Sgn(SmerX)
If Vyskok And inCircle(BalonX + 33, BalonY + 37, 20, LevyX + 20, LevyY + 20, 23) Or skok And inCircle(BalonX + 33, BalonY + 37, 20, PravyX + 35, PravyY + 22, 20) Then
klep
Vyskok = 0 'resi kolizi ve vyskoku ball collision on the fly if player skip
SmerX = Rnd + SmerX * -1: SmerY = Rnd + SmerY * -1
While inCircle(BalonX + 33, BalonY + 37, 20, LevyX + 20, LevyY + 20, 23) Or inCircle(BalonX + 33, BalonY + 37, 20, PravyX + 35, PravyY + 22, 20)
BalonX = BalonX + SmerX
BalonY = BalonY - (1 + Rnd * 10)
SmerY = SmerY - .0990
BalonX = BalonX + SmerX
If BalonY < 10 Then SmerY = SmerY * -1: Do While BalonY < 30: BalonY = BalonY + SmerY: Loop
Wend
'EXIT SUB
GoTo sut
End If
' ball collision if player go
If inCircle(BalonX + 33, BalonY + 37, 20, LevyX + 20, LevyY + 20, 23) Then SmerX = Rnd / 2 + SmerX * -1: SmerY = SmerY * -1: BalonX = BalonX + 10 * SmerX: BalonY = BalonY + 10 * SmerY: klep
If inCircle(BalonX + 33, BalonY + 37, 20, PravyX + 35, PravyY + 22, 20) Then SmerX = Rnd / 2 + SmerX * -1: SmerY = SmerY * -1: BalonX = BalonX + 10 * SmerX: BalonY = BalonY + 10 * SmerY: klep
sut:
If SmerX = 0 Then sm = Rnd * 10: If sm <= 5 Then SmerX = 1 Else SmerX = -1
If SmerY = 0 Then sm = Rnd * 10: If sm <= 5 Then SmerY = 1 Else SmerY = -1
If BalonY < 10 Then SmerY = SmerY * -1: BalonY = 10
If BalonY > 80 And BalonX < 160 Then right = right + 1: start = 0: pad: restart 1 ' left player fail
If BalonY > 80 And BalonX > 160 Then left = left + 1: start = 0: pad: restart 2 ' right player fail
BalonX = BalonX + SmerX: BalonY = BalonY + SmerY
End If
End Sub
Sub klep
If snd Then Sound 550, .2
End Sub
Sub restart (who As _Unsigned _Byte)
Select Case who
Case 1: LeftPlayer = LeftPlayer - 1
Case 2: RightPlayer = RightPlayer - 1
End Select
BalonX = 125: BalonY = 10
rest = 1
End Sub
Function reader (file As String) ' Read PBF file. This is my own new format contains graphics or characters. Its based on the BIT image representing.
Shared frames
kx = 0: ky = 1
If _FileExists(file$) Then Open file$ For Binary As #1 Else Beep: Print "Error opening file "; file$: _Display: Sleep 3: System
ident$ = Space$(4)
ReDim big As Integer
Get #1, , ident$
If ident$ <> "Petr" Then Print "This is not my file format": Sleep 2: Exit Function
Get #1, , big
frames = (LOF(1) - 6) / (big ^ 2 / 8)
ReDim udaj As _Unsigned _Byte
ReDim sn(frames) As String
While Not EOF(1)
Get #1, , udaj
binar$ = DECtoBIN$(udaj)
sn(snindex) = sn(snindex) + binar$
For rozklad = 1 To Len(binar$)
inSeek = inSeek + 1 'vnitrni pocitadlo pozice
povel = Val(Mid$(binar$, rozklad, 1))
kx = kx + 1: If kx > big Then kx = 1: ky = ky + 1
Next rozklad
If inSeek Mod (big ^ 2) = 0 Then ky = ky + 10: snindex = snindex + 1
If _Height - ky < big Then ky = 1: posun = posun + 60
Wend
Cls
reader = big
End Function
Sub rozpis (snimek As Integer, posX As Integer, posY As Integer) ' Draw frames from PBF read by function READER
Shared netiskni
If autostarted And Not vs Then Color 2: Locate 23, 1: Print "Demo": Color 15
If autostarted And vs Then Color 2: Locate 23, 1: Print "PC vs Human": Color 15
If netiskni Then Locate 23, 17: Print left; " - "; right
big = bigs ' je typu shared, udava delku strany
binar$ = sn(snimek)
For rozklad = 1 To Len(binar$)
povel = Val(Mid$(binar$, rozklad, 1))
kx = kx + 1: If kx > big Then kx = 1: ky = ky + 1
If povel = 1 Then PSet (posX + kx, posY + ky) 'ELSE PRESET (posX + kx, posY + ky)
Next rozklad
End Sub
' modifiation original code from CIRCLE help.
Function inCircle (cx As Integer, cy As Integer, cr As Integer, x As Integer, y As Integer, r As Integer) 'detect circle to circle contact. Return 1 if is contact, else return 0
r = r + 1
For Crc = 0 To 1.6 * _Pi Step .1
pseudocircleX = (Sin(Crc) * r) + x
pseudocircleY = (Cos(Crc) * r) + y
xy& = ((pseudocircleX - cx) ^ 2) + ((pseudocircleY - cy) ^ 2) ' Pythagorean theorem
If cr ^ 2 >= xy& Then inCircle = 1: Ic = 1 Else inCircle = 0
If Ic = 1 Then Exit For
Next
End Function
Function DECtoBIN$ (vstup) ' decimal to binary number convertor
For rj = 7 To 0 Step -1
If vstup And 2 ^ rj Then BINtoDE$ = BINtoDE$ + "1" Else BINtoDE$ = BINtoDE$ + "0"
Next rj
DECtoBIN$ = BINtoDE$
End Function
Sub doraz
If snd And Not autostarted Then
For e = .1 To .15 Step .01
Sound e * 500, e
Sound (500 * .6) - e, e
Sound e * 10000, e / 2
Next
For e = .15 To .1 Step -.01
Sound e * 500, e
Sound (500 * .6) - e, e
Sound e * 10000, e / 2
Next
End If
End Sub
Sub pisk
If snd Then
For e = .1 To .5 Step .1
Sound Sqr(e * 100 ^ 2 * 5000), e * 3
Next
End If
End Sub
Sub pad
If snd Then
For e = 2 To .1 Step -.1
Sound e * 200, .5
Next
End If
End Sub
Sub rotation (image As Long, x As Integer, y As Integer, angle As Integer, zoom As Integer) ' inspired by demo from somewhere in the forum, rotate image in menu.
_Source image&
_Dest 0
wide% = _Width(image&): deep% = _Height(image&)
TLC$ = "BL" + Str$(wide% / 2) + "BU" + Str$(deep% / 2)
RET$ = "BD BL" + Str$(wide%)
Draw "BM" + Str$(x) + ", " + Str$(y) + "TA=" + VarPtr$(angle%) + "S" + Str$(zoom) + TLC$
For y = 0 To deep% - 1
For x = 0 To wide% - 1
Draw "C" + Str$(Point(x, y)) + "R1"
Next x
Draw RET$
Next y
End Sub
Sub okoli
Line (0, 164)-(319, 200), 2, BF 'travnik pozadi
End SubAfter downloading file voll.zip do not try extract it, just rename it as voll.pbf, forum allow not add this file directly, then copy it to the same folder with source code.
