12-24-2023, 06:19 AM
Quote:Hi all.
After a long time I finally finished the development of this game. It's a classic game you sometimes play on squared paper in two 10x10 squares. During the development of the network version of this game, I learned a lot. The game offers automatic player shipbuilding - or manual boarding by the player (then right mouse button rotate with boat), the game on one computer and the network game on the local network.
If you try localhost network game, please copy this program to two different directories and then start it. For localhost do not write IP, just press enter on client computer.
Battleship.7z (Size: 769.11 KB / Downloads: 37)
Code: (Select All)
'WARNING! For Lan game in LOCALHOST mode please use two different directories, copy game files in and start then both programs. Fullscreen is not locked, use Alt + ENTER for window switching.
'or use two computers :-D
'of course you can play in offline mode with computer :-D
Constructor "BattleShip.pmf"
StartLan = 1
Type setup
BSound As _Byte 'sound in background
Esound As _Byte 'sound effects
Edit As String * 4 'if you need your boats insert manually, goto menu / setup click to INSERT SHIPS MANUALLY, then goto menu / set game type, select game type and start it.
End Type
Dim Shared INI As setup
inistart:
If _FileExists("lode.ini") Then
iniF = FreeFile
Open "lode.ini" For Binary As #iniF
Get #iniF, , INI
Close #iniF
Else INICreate 1, 1, "AUTO"
GoTo inistart
End If
Type MIDI
Song As String * 5
Lenght As Single
End Type
Dim Shared MIDI(3) As MIDI, MIDposition
MIDI(1).Song = "y.mid": MIDI(1).Lenght = 126 ' real midi sound lenght
MIDI(2).Song = "g.mid": MIDI(2).Lenght = 181
MIDI(3).Song = "k.mid": MIDI(3).Lenght = 413
MIDposition = 1
Dim Shared Lan, Host As Long, Client As Long
Dim Shared poleA(1 To 10, 1 To 10) As _Byte ' players array
Dim Shared poleB(1 To 10, 1 To 10) As _Byte ' enemy array
Dim Shared exploze(7) As Long
Type Lod ' array LodA contains informations about number, type and positions your boats, LodB is the same for enemy. This is later used for calculating damaged boats.
pos As String * 1
typ As _Byte
x As _Byte
y As _Byte
End Type
ReDim Shared LodA(15) As Lod, Typ, GenX As _Byte, GenY As _Byte, PaletteSave(255) As Long
ReDim Shared LodB(15) As Lod, Pocty(10) As _Byte, Sn(1) As String, Frames, Big
Dim pX As Integer, pY As Integer
ReDim prijemX As _Byte, prijemY As _Byte
'arrays LodA and PoleA are for player, LodB and PoleB for enemy or computer
Declare Dynamic Library "playmidi32" ' see to wiki for more info
Function PlayMIDI& (filename As String)
End Declare
Vycisti_poleA
a = -1: B = -1: C = -1: d = -1: e = -1
Screen 13: _FullScreen ' comment fullscreen if you try localhost lan game
SavePalette
i32to256 "lod0.gif", 0, 30
Big = reader("LODE.PBF") '
Color 40: textar "BATTLE SHIP", 110, 60: Color 15
noplay:
menu
'settings restart --------------
xx = FreeFile
Open "lode.ini" For Binary As #xx
Get #xx, , INI
Close #xx
'-------------------------------
i32to256 "lod0.gif", 0, 30 ' this sub again transform 32 bit loaded image to 256 color screen
Color 40: textar "BATTLE SHIP", 110, 60: Color 15
Do Until Typ > 0 And Typ < 4
Randomize Timer
Typ = Int(Rnd * 4)
Loop
uvod = 1
GameRestart:
_KeyClear: _AutoDisplay
'initPlayer
Cls
ResetPalette ' set color palette to original values
If INI.Edit = "AUTO" Then ' set this values in menu / setup. AUTO is for autogenerating boats on the map, MANU if boats are inserted manually
initPlayer
Show_Area
Do While i$ <> Chr$(13)
i$ = InKey$
If i$ = Chr$(27) Then _KeyClear: GoTo noplay
Color 14
textar "Press enter for select map or", -6, 1
textar "SPACE key for generate map", -6, 12
Color 15
Do Until Typ > 0 And Typ < 4
Randomize Timer
Typ = Int(Rnd * 4)
Loop
Select Case i$
Case " "
Vycisti_poleA
Vycisti_LodeA
initPlayer
Show_Area
Typ = 0
End Select
Loop
End If
Cls
uvod = 0
i32to256 "lod0.gif", 0, 30
Color 40: textar "BATTLE SHIP", 110, 60: Color 15
' ---------------------- Generate Computers Ships --------------------------------------
If INI.Edit = "MANU" Then InsertShipsManually
initComputer
Show_Area
ReDim posX As _Byte, posY As _Byte
posX = 1: posY = 1: player = 1
Cls
ResetPalette
Zobraz_Stav 40, 135, 0
Zobraz_Stav 221, 135, 1
Color 15
For popisky = 1 To 10 'draw 1 to 10 and A - J to maps
znak = 64 + popisky
textar Chr$(znak), 3 + (10 * popisky), 22: textar Chr$(znak), 172 + (10 * popisky), 22 'HORNI!
If popisky < 10 Then textar (Str$(popisky)), -10, 22 + popisky * 10: textar (Str$(popisky)), 161, 22 + popisky * 10 Else textar (Str$(popisky)), -16, 22 + popisky * 10: textar (Str$(popisky)), 154, 22 + popisky * 10
Next popisky
PCopy _Display, 1
Dim Mx, My, Lb, vvv
Do
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
If komplet Then komplet = 0: GoTo GameRestart
invalid:
i& = _KeyHit
If i& = 27 Then menu
vvv = _MouseInput
Mx = _MouseX
My = _MouseY
Lb = _MouseButton(1)
' CLS
PCopy 1, _Display
Pocty_Lodi
textar Str$(Pocty(5)), 10, 136
textar Str$(Pocty(4)), 10, 150
textar Str$(Pocty(3)), 10, 163
textar Str$(Pocty(2)), 10, 176
textar Str$(Pocty(1)), 10, 189
textar Str$(Pocty(10)), 255, 136
textar Str$(Pocty(9)), 255, 150
textar Str$(Pocty(8)), 255, 163
textar Str$(Pocty(7)), 255, 176
textar Str$(Pocty(6)), 255, 189
If INI.BSound Then midas
Select Case Lan
Case 0 'NO LAN GAME
Select Case player
Case 1
_MouseShow
Color 14: textar " Human Play ", 100, 1: Color 15
If Mx >= 190 And Mx <= 290 And My >= 30 And My <= 130 Then
posX = .4 + Int(Mx - 190) / 10
posY = .4 + Int(My - 30) / 10
End If
If posX < 1 Then posX = 1
If posY < 1 Then posY = 1
info$ = "Fire to:" + LTrim$(Str$(posY) + LTrim$(Chr$(64 + posX)) + " ")
textar info$, 1, 1
If Lb = -1 Then _MouseHide
If Lb = -1 And poleB(posX, posY) = 2 Or Lb = -1 And poleB(posX, posY) = 3 Then GoTo invalid
If Lb = -1 And poleB(posX, posY) = 1 Then Do Until zvuk(1): Loop: poleB(posX, posY) = 2: player = 0
If Lb = -1 And poleB(posX, posY) = 0 Then Do Until zvuk(2): Loop: poleB(posX, posY) = 3: player = 0
Show_Area
Show_B_Area
Case 0
secondly:
generX = 0: generY = 0
_MouseHide
Color 14: textar "Computer Play", 100, 1: Color 15
Randomize Timer
Do Until generX > 0 And generX < 11
generX = CInt(Rnd * 10)
Loop
Randomize Timer
Do Until generY > 0 And generY < 11
generY = CInt(Rnd * 10)
Loop
If poleA(generX, generY) = 2 Or poleA(generX, generY) = 3 Then GoTo secondly
info$ = "Fire to:" + LTrim$(Str$(generY) + LTrim$(Chr$(64 + generX)) + " ")
textar info$, 1, 1
If poleA(generX, generY) = 1 Then Do Until zvuk(1): Loop: poleA(generX, generY) = 2: player = 1
If poleA(generX, generY) = 0 Then Do Until zvuk(2): Loop: poleA(generX, generY) = 3: player = 1
Show_Area
Show_B_Area
End Select ' for player select - human or computer
'=============================Down is========================= 1 = HOST, 2 = CLIENT, writed for ONE CLIENT ==============================
Case -1: Print "Connection error.": Beep: Beep: menu ' NENI OTESTOVANO JAK SE TO BUDE CHOVAT V MENU!
Case 1 'HOST (SERVER)
_Title "host"
Do
Lb = 0
_KeyClear
i& = _KeyHit
If i& = 27 Then menu
While _MouseInput
Mx = _MouseX
My = _MouseY
Lb = _MouseButton(1)
Wend
PCopy 1, _Display
Pocty_Lodi
textar Str$(Pocty(5)), 10, 136
textar Str$(Pocty(4)), 10, 150
textar Str$(Pocty(3)), 10, 163
textar Str$(Pocty(2)), 10, 176
textar Str$(Pocty(1)), 10, 189
textar Str$(Pocty(10)), 255, 136
textar Str$(Pocty(9)), 255, 150
textar Str$(Pocty(8)), 255, 163
textar Str$(Pocty(7)), 255, 176
textar Str$(Pocty(6)), 255, 189
If firstRun = 0 Then LanHost: firstRun = 1: HOSTPLAY = 1: Lb = 0
'HOST play first
If INI.BSound Then midas
If HOSTPLAY Then
_MouseShow
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Color 14: textar " Host Play ", 100, 1: Color 15
If Mx >= 190 And Mx <= 290 And My >= 30 And My <= 130 Then
posX = .4 + Int(Mx - 190) / 10
posY = .4 + Int(My - 30) / 10
If posX < 1 Then posX = 1
If posY < 1 Then posY = 1
If Lb = -1 Then
Lb = 0
_MouseHide
If poleB(posX, posY) = 2 Or Lb = -1 And poleB(posX, posY) = 3 Then GoTo invalid
If posX > 10 Or posX < 1 Or posY > 10 Or posY < 1 Then Stop 'test input value, so if program run, then value muss be correct.
Put #Host&, , posX
Put #Host&, , posY
If poleB(posX, posY) = 1 Then Do Until zvuk(1): Loop: poleB(posX, posY) = 2: HOSTPLAY = 0
If poleB(posX, posY) = 0 Then Do Until zvuk(2): Loop: poleB(posX, posY) = 3: HOSTPLAY = 0
HOSTPLAY = 0
prevzal = 0
End If
End If
info$ = "Fire to:" + LTrim$(Str$(posY) + LTrim$(Chr$(64 + posX)) + " ")
textar info$, 1, 1
Show_Area
Show_B_Area
If OverTest Then menu
Else
_MouseHide
prijemX = 0: prijemY = 0
Do
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
i$ = InKey$
If i$ = Chr$(32) Then Beep: Print prijemX, prijemY 'manual bug test, if program wait to values - its from developing times
If i$ = Chr$(27) Then menu
If prijemX = 0 Then Get #Host&, , prijemX 'missing IF conditions in this place caused me really BIG problems. One month for such this bug.
If prijemY = 0 Then Get #Host&, , prijemY
Color 14: textar " Host wait ", 100, 1: Color 15
Show_Area
Show_B_Area
_Display
If prijemX > 0 And prijemY > 0 Then Exit Do
Loop
If prijemX > 0 And prijemX < 11 And prijemY > 0 And prijemY < 11 Then
If poleA(prijemX, prijemY) = 1 Then Do Until zvuk(1): Loop: poleA(prijemX, prijemY) = 2: HOSTPLAY = 1
If poleA(prijemX, prijemY) = 0 Then Do Until zvuk(2): Loop: poleA(prijemX, prijemY) = 3: HOSTPLAY = 1
Else Sound 350, 1: Stop ' For unknown bug
End If
End If
_Display
If OverTest Then menu
Loop
Case 2 'CLIENT
_Title "client"
Do
i& = _KeyHit
If i& = 27 Then menu
While _MouseInput
Mx = _MouseX
My = _MouseY
Lb = _MouseButton(1)
Wend
PCopy 1, _Display
Pocty_Lodi
textar Str$(Pocty(5)), 10, 136
textar Str$(Pocty(4)), 10, 150
textar Str$(Pocty(3)), 10, 163
textar Str$(Pocty(2)), 10, 176
textar Str$(Pocty(1)), 10, 189
textar Str$(Pocty(10)), 255, 136
textar Str$(Pocty(9)), 255, 150
textar Str$(Pocty(8)), 255, 163
textar Str$(Pocty(7)), 255, 176
textar Str$(Pocty(6)), 255, 189
If firstRun = 0 Then LanClient: firstRun = 1: CLIENTPLAY = 0: Lb = 0
If INI.BSound Then midas
If CLIENTPLAY Then
_MouseShow
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Color 14: textar " Client Play ", 100, 1: Color 15
If Mx >= 190 And Mx <= 290 And My >= 30 And My <= 130 Then
posX = .4 + Int(Mx - 190) / 10
posY = .4 + Int(My - 30) / 10
If posX < 1 Then posX = 1
If posY < 1 Then posY = 1
If Lb = -1 Then
Lb = 0
_MouseHide
If poleB(posX, posY) = 2 Or Lb = -1 And poleB(posX, posY) = 3 Then GoTo invalid
'error detection
If posX > 10 Or posX < 1 Or posY > 10 Or posY < 1 Then Stop
Put #Client&, , posX
Put #Client&, , posY
If poleB(posX, posY) = 1 Then Do Until zvuk(1): Loop: poleB(posX, posY) = 2: CLIENTPLAY = 0
If poleB(posX, posY) = 0 Then Do Until zvuk(2): Loop: poleB(posX, posY) = 3: CLIENTPLAY = 0
CLIENTPLAY = 0
oka = 0
End If
End If
info$ = "Fire to:" + LTrim$(Str$(posY) + LTrim$(Chr$(64 + posX)) + " ")
textar info$, 1, 1
Show_Area
Show_B_Area
If OverTest Then menu
Else
_MouseHide
Color 14: textar " Client wait ", 100, 1: Color 15
ReDim p As _Byte
prijemX = 0: prijemY = 0: p = 1
'BEEP
Do
i$ = InKey$
If i$ = Chr$(32) Then Beep: Print prijemX, prijemY ' manual test - program wait to values!
If i$ = Chr$(27) Then menu
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Show_Area
Show_B_Area
_Display
If prijemX = 0 Then Get #Client&, , prijemX
If prijemY = 0 Then Get #Client&, , prijemY
If prijemX > 0 And prijemY > 0 Then Exit Do ' valid condition
Loop
If prijemX >= 1 And prijemX <= 10 And prijemY >= 1 And prijemY <= 10 Then
If poleA(prijemX, prijemY) = 1 Then Do Until zvuk(1): Loop: poleA(prijemX, prijemY) = 2: CLIENTPLAY = 1
If poleA(prijemX, prijemY) = 0 Then Do Until zvuk(2): Loop: poleA(prijemX, prijemY) = 3: CLIENTPLAY = 1
Else Sound 350, 1: Stop ' for unknown bug
End If
End If
_Display
If OverTest Then menu
Loop
'======================================================================================================================================================
End Select 'pro LAN typ hry
A_OK = 0: B_OK = 0
If OverTest Then menu
_Limit 180
_Display
Loop
Function OverTest
Shared Lan
OverTest = 0
For controlA = 1 To 10
For controlB = 1 To 10
If poleA(controlA, controlB) = 1 Then A_OK = 1
If poleB(controlA, controlB) = 1 Then B_OK = 1
Next
Next
If A_OK = 0 Then
ResetPalette
Cls
i32to256 "lod4.gif", 0, 20
If Lan = 0 Then
Color 40: textar "Computer WIN", 110, 90: _Display: Sleep: Vycisti_poleA: Vycisti_poleB: komplet = 1: OverTest = 1
Else
Select Case Lan
Case 1
Color 40: textar "CLIENT WIN", 110, 90: _Display: Sleep: Vycisti_poleA: Vycisti_poleB: komplet = 1: OverTest = 1: Close #Host&
Case 2
Color 40: textar "HOST WIN", 110, 90: _Display: Sleep: Vycisti_poleA: Vycisti_poleB: komplet = 1: OverTest = 1: Close #Client&
End Select
End If
End If
If B_OK = 0 Then
ResetPalette
Cls
i32to256 "lod3.gif", 35, 0
If Lan = 0 Then
Color 40: textar "Human WIN", 120, 10: _Display: Sleep: Vycisti_poleA: Vycisti_poleB: komplet = 1: OverTest = 1
Else
Select Case Lan
Case 1
Color 40: textar "HOST WIN", 110, 90: _Display: Sleep: Vycisti_poleA: Vycisti_poleB: komplet = 1: OverTest = 1: Close #Host&: Lan = 0
Case 2
Color 40: textar "CLIENT WIN", 110, 90: _Display: Sleep: Vycisti_poleA: Vycisti_poleB: komplet = 1: OverTest = 1: Close #Client&: Lan = 0
End Select
End If
End If
End Function
Sub cil (x As _Byte, y As _Byte)
Shared player
If player = 1 Then Exit Sub
Line (20 + (10 * (x - 1)) + 3, 30 + (10 * (y - 1)) + 3)-(30 + (10 * (x - 1) - 1), 40 + (10 * (y - 1) - 1)), 14, BF
End Sub
Sub midas
Shared midResult, midTimer, midName$, MIDposition 'this is not very good example for programming....
If midTimer > Timer Then
Exit Sub
Else
result = PlayMIDI("" + Chr$(0)) 'stop
MIDposition = MIDposition + 1
If MIDposition > UBound(MIDI) Then MIDposition = 1
midTimer = Timer + MIDI(MIDposition).Lenght: midName$ = MIDI(MIDposition).Song
result = PlayMIDI(midName$ + Chr$(0))
If result Then Print "Error. Playmidi32.dll not found, background music will not played."
End If
End Sub
Function zvuk (co As _Byte)
Shared generX, generY, Splash&, exploz
If exploze(0) = 0 Then
exploze(0) = _SndOpen("explode0.mp3")
exploze(1) = _SndOpen("explode1.mp3")
exploze(2) = _SndOpen("explode2.mp3")
exploze(3) = _SndOpen("explode3.mp3")
exploze(4) = _SndOpen("explode4.mp3")
exploze(5) = _SndOpen("explode5.mp3")
exploze(6) = _SndOpen("explode6.mp3")
exploze(7) = _SndOpen("explode7.mp3")
Splash& = _SndOpen("splash.mp3"): If INI.Esound = 0 Then _SndVol (Splash&), 0 Else _SndVol (Splash&), 1
End If
'1 lod, 2 voda 1 boat, 2 water
'for online
If Lan Then
exploz = exploz + 1: If exploz > 7 Then exploz = 0
GoTo NO_RANDOM
End If
' for offline
exploz = -1
Do Until exploz > -1 And exploz < 8
Randomize Timer
exploz = Int(Rnd + Rnd * 5)
Loop
NO_RANDOM:
If INI.Esound = 0 Then _SndVol exploze(exploz), 0 'this solution is best for tha same time duration after fire with and without sound
_SndPlay exploze(exploz)
Do While _SndPlaying(exploze(exploz)): Show_Area: Show_B_Area: cil generX, generY:: _Display: Loop
_SndStop exploze(exploz)
If co = 2 Then
_SndPlay Splash&
Do While _SndPlaying(Splash&): Show_Area: Show_B_Area: cil generX, generY:: _Display: Loop
_SndStop Splash&
End If
zvuk = 1
End Function
Sub Zobraz_Stav (x As Integer, y As Integer, typ) 'draw boats flags
oldY = y
Select Case typ
Case 0
For G = 1 To 5
For f = 1 To 50 - I Step 10
Line (x + f, y)-(x + f + 10, y + 10), 23, BF
Line (x + f, y)-(x + f + 10, y + 10), 15, B
Next f
I = I + 10
y = y + 13
Next G
Case 1
I = 0: y = oldY
For G = 1 To 5
For f = 40 To I Step -10
Line (x + f, y)-(x + f + 10, y + 10), 23, BF
Line (x + f, y)-(x + f + 10, y + 10), 15, B
Next f
I = I + 10
y = y + 13
Next G
End Select
End Sub
Sub Pocty_Lodi 'calculate number of boats
death1 = 0: death2 = 0: death3 = 0: death4 = 0: death5 = 0
For Lode = 1 To 10
For lodf = 1 To 10
For L = 1 To UBound(LodA)
If LodA(L).typ = 1 And LodA(L).x = Lode And LodA(L).y = lodf And poleA(Lode, lodf) > 1 Then death1 = death1 + 1
Select Case LodA(L).typ
Case 2
If LodA(L).x = Lode And LodA(L).y = lodf Then
Select Case LodA(L).pos
Case "X"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(1 + LodA(L).x, LodA(L).y) > 1 Then death2 = death2 + 1
Case "Y"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(LodA(L).x, 1 + LodA(L).y) > 1 Then death2 = death2 + 1
End Select
End If
Case 3
If LodA(L).x = Lode And LodA(L).y = lodf Then
Select Case LodA(L).pos
Case "X"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(1 + LodA(L).x, LodA(L).y) > 1 And poleA(2 + LodA(L).x, LodA(L).y) > 1 Then death3 = death3 + 1
Case "Y"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(LodA(L).x, 1 + LodA(L).y) > 1 And poleA(LodA(L).x, 2 + LodA(L).y) > 1 Then death3 = death3 + 1
End Select
End If
Case 4
If LodA(L).x = Lode And LodA(L).y = lodf Then
Select Case LodA(L).pos
Case "X"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(1 + LodA(L).x, LodA(L).y) > 1 And poleA(2 + LodA(L).x, LodA(L).y) > 1 And poleA(3 + LodA(L).x, LodA(L).y) > 1 Then death4 = death4 + 1
Case "Y"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(LodA(L).x, 1 + LodA(L).y) > 1 And poleA(LodA(L).x, 2 + LodA(L).y) > 1 And poleA(LodA(L).x, 3 + LodA(L).y) > 1 Then death4 = death4 + 1
End Select
End If
Case 5
If LodA(L).x = Lode And LodA(L).y = lodf Then
Select Case LodA(L).pos
Case "X"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(1 + LodA(L).x, LodA(L).y) > 1 And poleA(2 + LodA(L).x, LodA(L).y) > 1 And poleA(3 + LodA(L).x, LodA(L).y) > 1 And poleA(4 + LodA(L).x, LodA(L).y) > 1 Then death5 = death5 + 1
Case "Y"
If poleA(LodA(L).x, LodA(L).y) > 1 And poleA(LodA(L).x, 1 + LodA(L).y) > 1 And poleA(LodA(L).x, 2 + LodA(L).y) > 1 And poleA(LodA(L).x, 3 + LodA(L).y) > 1 And poleA(LodA(L).x, 4 + LodA(L).y) > 1 Then death5 = death5 + 1
End Select
End If
End Select
Next L, lodf, Lode
Pocty(1) = 5 - death1
Pocty(2) = 4 - death2
Pocty(3) = 3 - death3
Pocty(4) = 2 - death4
Pocty(5) = 1 - death5
death1 = 0: death2 = 0: death3 = 0: death4 = 0: death5 = 0
For Lode = 1 To 10
For lodf = 1 To 10
For L = 1 To UBound(LodB)
If LodB(L).typ = 1 And LodB(L).x = Lode And LodB(L).y = lodf And poleB(Lode, lodf) > 1 Then death1 = death1 + 1
Select Case LodB(L).typ
Case 2
If LodB(L).x = Lode And LodB(L).y = lodf Then
Select Case LodB(L).pos
Case "X"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(1 + LodB(L).x, LodB(L).y) > 1 Then death2 = death2 + 1
Case "Y"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(LodB(L).x, 1 + LodB(L).y) > 1 Then death2 = death2 + 1
End Select
End If
Case 3
If LodB(L).x = Lode And LodB(L).y = lodf Then
Select Case LodB(L).pos
Case "X"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(1 + LodB(L).x, LodB(L).y) > 1 And poleB(2 + LodB(L).x, LodB(L).y) > 1 Then death3 = death3 + 1
Case "Y"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(LodB(L).x, 1 + LodB(L).y) > 1 And poleB(LodB(L).x, 2 + LodB(L).y) > 1 Then death3 = death3 + 1
End Select
End If
Case 4
If LodB(L).x = Lode And LodB(L).y = lodf Then
Select Case LodB(L).pos
Case "X"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(1 + LodB(L).x, LodB(L).y) > 1 And poleB(2 + LodB(L).x, LodB(L).y) > 1 And poleB(3 + LodB(L).x, LodB(L).y) > 1 Then death4 = death4 + 1
Case "Y"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(LodB(L).x, 1 + LodB(L).y) > 1 And poleB(LodB(L).x, 2 + LodB(L).y) > 1 And poleB(LodB(L).x, 3 + LodB(L).y) > 1 Then death4 = death4 + 1
End Select
End If
Case 5
If LodB(L).x = Lode And LodB(L).y = lodf Then
Select Case LodB(L).pos
Case "X"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(1 + LodB(L).x, LodB(L).y) > 1 And poleB(2 + LodB(L).x, LodB(L).y) > 1 And poleB(3 + LodB(L).x, LodB(L).y) > 1 And poleB(4 + LodB(L).x, LodB(L).y) > 1 Then death5 = death5 + 1
Case "Y"
If poleB(LodB(L).x, LodB(L).y) > 1 And poleB(LodB(L).x, 1 + LodB(L).y) > 1 And poleB(LodB(L).x, 2 + LodB(L).y) > 1 And poleB(LodB(L).x, 3 + LodB(L).y) > 1 And poleB(LodB(L).x, 4 + LodB(L).y) > 1 Then death5 = death5 + 1
End Select
End If
End Select
Next L, lodf, Lode
Pocty(6) = 5 - death1
Pocty(7) = 4 - death2
Pocty(8) = 3 - death3
Pocty(9) = 2 - death4
Pocty(10) = 1 - death5
End Sub
Sub Vycisti_poleA
For x = 1 To 10
For y = 1 To 10
poleA(x, y) = 0
Next y, x
End Sub
Sub Vycisti_LodeA 'uvolni lodni pole
ReDim LodA(0) As Lod
End Sub
Sub Vycisti_poleB
For x = 1 To 10
For y = 1 To 10
poleB(x, y) = 0
Next y, x
End Sub
Sub Vycisti_LodeB 'uvolni lodni pole
ReDim LodB(0) As Lod
End Sub
Sub Show_Area
Shared anima, uvod
y2 = 0
For y = 1 To 100 Step 10
y2 = y2 + 1
For x = 1 To 100 Step 10
x2 = x2 + 1
TypLodi = 0
barva = 0
For B = 0 To 15
If LodA(B).x = x2 And LodA(B).y = y2 Then TypLodi = LodA(B).typ: Exit For
If x2 >= LodA(B).x And LodA(B).pos = "X" And x2 <= LodA(B).typ + LodA(B).x And y2 = LodA(B).y Then TypLodi = LodA(B).typ: Exit For
If y2 >= LodA(B).y And LodA(B).pos = "Y" And y2 <= LodA(B).typ + LodA(B).y And x2 = LodA(B).x Then TypLodi = LodA(B).typ: Exit For
Next B
Select Case TypLodi
Case 0: barva = 60
Case 1: barva = 22
Case 2: barva = 23
Case 3: barva = 24
Case 4: barva = 25
Case 5: barva = 26
End Select
Select Case poleA(x2, y2)
Case 0 ' VODA
Line (x + 20 + m, y + 30 + m)-(x + 30 + m, y + 40 + m), 1, BF
Line (x + 20 + m, y + 30 + m)-(x + 30 + m, y + 40 + m), 15, B
anima = anima + .0001: If anima > 3 Then anima = 1
Color 53 + anima: rozpis 37 + Int(anima), 1 + x + 20, 1 + y + 30: Color 15
Case 1 ' LOD
Line (x + 20 + 1, y + 30 + 1)-(x + 30 - 1, y + 40 - 1), barva, BF
Line (x + 20 + m, y + 30 + m)-(x + 30 + m, y + 40 + m), 15, B
Case 2 ' Zasah lod
Line (x + 20 + 1, y + 30 + 1)-(x + 30 - 1, y + 40 - 1), 5, BF
Line (x + 20 + m, y + 30 + m)-(x + 30 + m, y + 40 + m), 15, B
Color 38 + anima: rozpis 40 + Int(anima), 1 + x + 20, 1 + y + 30: Color 15
Case 3 ' Zasah voda
Line (x + 20 + 1, y + 40 - 1)-(x + 30 - 1, y + 30 + 1), 1, BF
Color 53 + anima: rozpis 37 + Int(anima), 1 + x + 20, 1 + y + 30: Color 15
Line (x + 20 + 1, y + 30 + 1)-(x + 30 - 1, y + 40 - 1), 15
Line (x + 20 + 1, y + 40 - 1)-(x + 30 - 1, y + 30 + 1), 15
Line (x + 20, y + 30)-(x + 30, y + 40), 15, B
End Select
Next x
x2 = 0
If uvod = 0 Then
End If
Next y
End Sub
Sub Show_B_Area
Shared anima
x2 = 0: y2 = 0
For y = 1 To 100 Step 10
y2 = y2 + 1
For x = 1 To 100 Step 10
x2 = x2 + 1
TypLodi = 0
barva = 0
For B = 1 To 15
If x2 >= LodB(B).x And LodB(B).pos = "X" And x2 <= LodB(B).typ + LodB(B).x And y2 = LodB(B).y Then TypLodi = LodB(B).typ: Exit For
If y2 >= LodB(B).y And LodB(B).pos = "Y" And y2 <= LodB(B).typ + LodB(B).y And x2 = LodB(B).x Then TypLodi = LodB(B).typ: Exit For
Next B
Select Case TypLodi
Case 1: barva = 22
Case 2: barva = 23
Case 3: barva = 24
Case 4: barva = 25
Case 5: barva = 26
End Select
m = 0
Select Case poleB(x2, y2)
Case 0 ' voda na pozici Water on position
Line (x + 190 + m, y + 30 + m)-(x + 200 + m, y + 40 + m), 1, BF
Color 53 + anima: rozpis 37 + Int(anima), 1 + x + 190, 1 + y + 30: Color 15
Line (x + 190 + m, y + 30 + m)-(x + 200 + m, y + 40 + m), 15, B
Case 1 ' lod na pozici
Line (x + 190 + 1, y + 30 + 1)-(x + 200 - 1, y + 40 - 1), 1, BF ' Rewrite 1 before ,BF to show enemy boats.
Color 53 + anima: rozpis 37 + Int(anima), 1 + x + 190, 1 + y + 30: Color 15
Line (x + 190 + m, y + 30 + m)-(x + 200 + m, y + 40 + m), 15, B
Case 2 ' zasah lode Boat damage
Line (x + 190 + 1, y + 30 + 1)-(x + 200 - 1, y + 40 - 1), 5, BF
Color 38 + anima: rozpis 40 + Int(anima), 1 + x + 190, 1 + y + 30: Color 15
Line (x + 190 + m, y + 30 + m)-(x + 200 + m, y + 40 + m), 15, B
Case 3
Line (x + 190 + 1, y + 40 - 1)-(x + 200 - 1, y + 30 + 1), 1, BF
Color 53 + anima: rozpis 37 + Int(anima), 1 + x + 190, 1 + y + 30: Color 15
Line (x + 190 + 1, y + 30 + 1)-(x + 200 - 1, y + 40 - 1), 15
Line (x + 190 + 1, y + 40 - 1)-(x + 200 - 1, y + 30 + 1), 15
Line (x + 190 + m, y + 30 + m)-(x + 200 + m, y + 40 + m), 15, B
End Select
Next x
x2 = 0
Next y
End Sub
Function Rozmisti_lodeX (rozmisti As _Byte)
T = Timer + .2
index = UBound(LodA)
Select Case rozmisti
Case 1
Do While lod < 5
gen:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 10 Or GenX < 1 Or GenY > 10 Or GenY < 1 Then GoTo gen
If VolnoA(GenX, GenY) Then
ReDim _Preserve LodA(index + 1 + lod) As Lod
LodA(index + 1 + lod).pos = "X": LodA(index + 1 + lod).typ = 1: LodA(index + 1 + lod).x = GenX: LodA(index + 1 + lod).y = GenY
poleA(GenX, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeX = 1: Exit Function
Loop
Case 2
lod = 0
Do While lod < 1
gen2:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 9 Or GenX < 1 Or GenY > 9 Or GenY < 1 Then GoTo gen2
If VolnoA(GenX, GenY) And VolnoA(GenX + 1, GenY) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "X": LodA(index + 1).typ = 2: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX + 1, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeX = 1: Exit Function
Loop
Case 3
lod = 0
Do While lod < 1
gen3:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 8 Or GenX < 1 Or GenY > 8 Or GenY < 1 Then GoTo gen3
If VolnoA(GenX, GenY) And VolnoA(GenX + 1, GenY) And VolnoA(GenX + 2, GenY) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "X": LodA(index + 1).typ = 3: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX + 1, GenY) = 1: poleA(GenX + 2, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeX = 1: Exit Function
Loop
Case 4
'CTYRKA LOD
lod = 0
Do While lod < 1
gen4:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 7 Or GenX < 1 Or GenY > 7 Or GenY < 1 Then GoTo gen4
If VolnoA(GenX, GenY) And VolnoA(GenX + 1, GenY) And VolnoA(GenX + 2, GenY) And VolnoA(GenX + 3, GenY) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "X": LodA(index + 1).typ = 4: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX + 1, GenY) = 1: poleA(GenX + 2, GenY) = 1: poleA(GenX + 3, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeX = 1: Exit Function
Loop
Case 5
'PETKA LOD
lod = 0
Do While lod < 1
gen5:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 6 Or GenX < 1 Or GenY > 6 Or GenY < 1 Then GoTo gen5
ReDim _Preserve A5(lod, GenX To GenX + 5, GenY) As _Byte
If VolnoA(GenX, GenY) And VolnoA(GenX + 1, GenY) And VolnoA(GenX + 2, GenY) And VolnoA(GenX + 3, GenY) And VolnoA(GenX + 4, GenY) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "X": LodA(index + 1).typ = 5: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX + 1, GenY) = 1: poleA(GenX + 2, GenY) = 1: poleA(GenX + 3, GenY) = 1: poleA(GenX + 4, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeX = 1: Exit Function
Loop
End Select
End Function
Function Rozmisti_B_lodeX (rozmisti As _Byte)
GenX = 0: GenY = 0
T = Timer + .2 'time limit for genarating
index = UBound(LodB)
lod = 0
Select Case rozmisti
Case 1
Do While lod < 5
gen:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 10 Or GenX < 1 Or GenY > 10 Or GenY < 1 Then GoTo gen
If VolnoB(GenX, GenY) Then
ReDim _Preserve LodB(index + 1 + lod) As Lod
LodB(index + 1 + lod).pos = "X": LodB(index + 1 + lod).typ = 1: LodB(index + 1 + lod).x = GenX: LodB(index + 1 + lod).y = GenY
poleB(GenX, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_B_lodeX = 1: Exit Function
Loop
Case 2
'DVOJKA LOD
lod = 0
Do While lod < 1
gen2:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 9 Or GenX < 1 Or GenY > 9 Or GenY < 1 Then GoTo gen2
If VolnoB(GenX, GenY) And VolnoB(GenX + 1, GenY) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "X": LodB(index + 1).typ = 2: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX + 1, GenY) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeX = 1: Exit Function
Loop
Case 3
'TROJKA LOD
lod = 0
Do While lod < 1
gen3:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 8 Or GenX < 1 Or GenY > 8 Or GenY < 1 Then GoTo gen3
If VolnoB(GenX, GenY) And VolnoB(GenX + 1, GenY) And VolnoB(GenX + 2, GenY) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "X": LodB(index + 1).typ = 3: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX + 1, GenY) = 1: poleB(GenX + 2, GenY) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeX = 1: Exit Function
Loop
Case 4
'CTYRKA LOD
lod = 0
Do While lod < 1
gen4:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 7 Or GenX < 1 Or GenY > 7 Or GenY < 1 Then GoTo gen4
If VolnoB(GenX, GenY) And VolnoB(GenX + 1, GenY) And VolnoB(GenX + 2, GenY) And VolnoB(GenX + 3, GenY) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "X": LodB(index + 1).typ = 4: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX + 1, GenY) = 1: poleB(GenX + 2, GenY) = 1: poleB(GenX + 3, GenY) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeX = 1: Exit Function
Loop
Case 5
'PETKA LOD
lod = 0
Do While lod < 1
gen5:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 6 Or GenX < 1 Or GenY > 6 Or GenY < 1 Then GoTo gen5
If VolnoB(GenX, GenY) And VolnoB(GenX + 1, GenY) And VolnoB(GenX + 2, GenY) And VolnoB(GenX + 3, GenY) And VolnoB(GenX + 4, GenY) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "X": LodB(index + 1).typ = 5: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX + 1, GenY) = 1: poleB(GenX + 2, GenY) = 1: poleB(GenX + 3, GenY) = 1: poleB(GenX + 4, GenY) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeX = 1: Exit Function
Loop
End Select
End Function
Function Rozmisti_lodeY (rozmisti As _Byte)
T = Timer + .2
index = UBound(LodA)
Select Case rozmisti
Case 1
'JEDNICKA lod
Do While lod < 5
gen:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 10 Or GenX < 1 Or GenY > 10 Or GenY < 1 Then GoTo gen
If VolnoA(GenX, GenY) Then
ReDim _Preserve LodA(index + 1 + lod) As Lod
LodA(index + 1 + lod).pos = "Y": LodA(index + 1 + lod).typ = 1: LodA(index + 1 + lod).x = GenX: LodA(index + 1 + lod).y = GenY
poleA(GenX, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeY = 1: Exit Function
Loop
Case 2
'DVOJKA LOD
lod = 0
Do While lod < 1
gen2:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 9 Or GenX < 1 Or GenY > 9 Or GenY < 1 Then GoTo gen2
If VolnoA(GenX, GenY) And VolnoA(GenX, GenY + 1) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "Y": LodA(index + 1).typ = 2: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX, GenY + 1) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeY = 1: Exit Function
Loop
Case 3
'TROJKA LOD
lod = 0
Do While lod < 1
gen3:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 8 Or GenX < 1 Or GenY > 8 Or GenY < 1 Then GoTo gen3
If VolnoA(GenX, GenY) And VolnoA(GenX, GenY + 1) And VolnoA(GenX, GenY + 2) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "Y": LodA(index + 1).typ = 3: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX, GenY + 1) = 1: poleA(GenX, GenY + 2) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeY = 1: Exit Function
Loop
Case 4
'CTYRKA LOD
lod = 0
Do While lod < 1
gen4:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 7 Or GenX < 1 Or GenY > 7 Or GenY < 1 Then GoTo gen4
If VolnoA(GenX, GenY) And VolnoA(GenX, GenY + 1) And VolnoA(GenX, GenY + 2) And VolnoA(GenX, GenY + 3) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "Y": LodA(index + 1).typ = 4: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX, GenY + 1) = 1: poleA(GenX, GenY + 2) = 1: poleA(GenX, GenY + 3) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_lodeY = 1: Exit Function
Loop
Case 5
'PETKA LOD
lod = 0
Do While lod < 1
gen5:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 6 Or GenX < 1 Or GenY > 6 Or GenY < 1 Then GoTo gen5
If VolnoA(GenX, GenY) And VolnoA(GenX, GenY + 1) And VolnoA(GenX, GenY + 2) And VolnoA(GenX, GenY + 3) And VolnoA(GenX, GenY + 4) Then
ReDim _Preserve LodA(index + 1) As Lod
LodA(index + 1).pos = "Y": LodA(index + 1).typ = 5: LodA(index + 1).x = GenX: LodA(index + 1).y = GenY
poleA(GenX, GenY) = 1: poleA(GenX, GenY + 1) = 1: poleA(GenX, GenY + 2) = 1: poleA(GenX, GenY + 3) = 1: poleA(GenX, GenY + 4) = 1: lod = lod + 1
End If
Loop
If Timer > T Then Rozmisti_lodeY = 1: Exit Function
End Select
End Function
Function Rozmisti_B_lodeY (rozmisti As _Byte)
GenX = 0: GenY = 0
T = Timer + .2
index = UBound(LodB)
Select Case rozmisti
Case 1
'JEDNICKA lod
Do While lod < 5
gen:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 10 Or GenX < 1 Or GenY > 10 Or GenY < 1 Then GoTo gen
If VolnoB(GenX, GenY) Then
ReDim _Preserve LodB(index + 1 + lod) As Lod
LodB(index + 1 + lod).pos = "Y": LodB(index + 1 + lod).typ = 1: LodB(index + 1 + lod).x = GenX: LodB(index + 1 + lod).y = GenY
poleB(GenX, GenY) = 1: lod = lod + 1
End If
If Timer > T Then Rozmisti_B_lodeY = 1: Exit Function
Loop
Case 2
'DVOJKA LOD
lod = 0
Do While lod < 1
gen2:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 9 Or GenX < 1 Or GenY > 9 Or GenY < 1 Then GoTo gen2
If VolnoB(GenX, GenY) And VolnoB(GenX, GenY + 1) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "Y": LodB(index + 1).typ = 2: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX, GenY + 1) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeY = 1: Exit Function
Loop
Case 3
'TROJKA LOD
lod = 0
Do While lod < 1
gen3:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 8 Or GenX < 1 Or GenY > 8 Or GenY < 1 Then GoTo gen3
If VolnoB(GenX, GenY) And VolnoB(GenX, GenY + 1) And VolnoB(GenX, GenY + 2) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "Y": LodB(index + 1).typ = 3: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX, GenY + 1) = 1: poleB(GenX, GenY + 2) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeY = 1: Exit Function
Loop
Case 4
'CTYRKA LOD
lod = 0
Do While lod < 1
gen4:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 7 Or GenX < 1 Or GenY > 7 Or GenY < 1 Then GoTo gen4
If VolnoB(GenX, GenY) And VolnoB(GenX, GenY + 1) And VolnoB(GenX, GenY + 2) And VolnoB(GenX, GenY + 3) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "Y": LodB(index + 1).typ = 4: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX, GenY + 1) = 1: poleB(GenX, GenY + 2) = 1: poleB(GenX, GenY + 3) = 1: lod = lod + 1
Exit Function
End If
If Timer > T Then Rozmisti_B_lodeY = 1: Exit Function
Loop
Case 5
'PETKA LOD
lod = 0
Do While lod < 1
gen5:
Randomize Timer
GenX = CInt(Rnd * 10)
GenY = CInt(Rnd * 10)
If GenX > 6 Or GenX < 1 Or GenY > 6 Or GenY < 1 Then GoTo gen5
If VolnoB(GenX, GenY) And VolnoB(GenX, GenY + 1) And VolnoB(GenX, GenY + 2) And VolnoB(GenX, GenY + 3) And VolnoB(GenX, GenY + 4) Then
ReDim _Preserve LodB(index + 1) As Lod
LodB(index + 1).pos = "Y": LodB(index + 1).typ = 5: LodB(index + 1).x = GenX: LodB(index + 1).y = GenY
poleB(GenX, GenY) = 1: poleB(GenX, GenY + 1) = 1: poleB(GenX, GenY + 2) = 1: poleB(GenX, GenY + 3) = 1: poleB(GenX, GenY + 4) = 1: lod = lod + 1
End If
Loop
If Timer > T Then Rozmisti_B_lodeY = 1: Exit Function
End Select
End Function
Function VolnoA (x As _Byte, y As _Byte)
If x = 1 Then startX = 1 Else startX = x - 1
If y = 1 Then startY = 1 Else startY = y - 1
If x >= 10 Then CilX = 10 Else CilX = x + 1
If y >= 10 Then CilY = 10 Else CilY = y + 1
For scnX = startX To CilX
For scnY = startY To CilY
If poleA(scnX, scnY) <> 0 Then Volno = 1: GoTo vystup
Next scnY, scnX
vystup:
If Volno Then VolnoA = 0 Else VolnoA = 1
End Function
Function VolnoB (x As _Byte, y As _Byte)
If x = 1 Then startX = 1 Else startX = x - 1
If y = 1 Then startY = 1 Else startY = y - 1
If x >= 10 Then CilX = 10 Else CilX = x + 1
If y >= 10 Then CilY = 10 Else CilY = y + 1
For scnX = startX To CilX
For scnY = startY To CilY
If poleB(scnX, scnY) <> 0 Then Volno = 1: GoTo vystup
Next scnY, scnX
vystup:
If Volno Then VolnoB = 0 Else VolnoB = 1
End Function
Sub initPlayer
Do
Select Case Typ
Case 1
'dve ctyrky
a = Rozmisti_lodeY(4)
a = Rozmisti_lodeX(4)
' tri trojky
b = Rozmisti_lodeX(3)
b = Rozmisti_lodeY(3)
b = Rozmisti_lodeX(3)
'jedna petka
e = Rozmisti_lodeX(5)
'ctyry dvojky
c = Rozmisti_lodeY(2)
c = Rozmisti_lodeY(2)
c = Rozmisti_lodeX(2)
c = Rozmisti_lodeY(2)
'pet jednicek (generuje 5 rovnou)
d = Rozmisti_lodeY(1)
Case 2
a = Rozmisti_lodeX(4)
a = Rozmisti_lodeX(4)
' tri trojky
b = Rozmisti_lodeY(3)
b = Rozmisti_lodeY(3)
b = Rozmisti_lodeY(3)
'jedna petka
e = Rozmisti_lodeX(5)
'ctyry dvojky
c = Rozmisti_lodeY(2)
c = Rozmisti_lodeX(2)
c = Rozmisti_lodeX(2)
c = Rozmisti_lodeY(2)
'pet jednicek (generuje 5 rovnou)
d = Rozmisti_lodeY(1)
Case 3
'jedna petka
e = Rozmisti_lodeY(5)
a = Rozmisti_lodeY(4)
a = Rozmisti_lodeY(4)
' tri trojky
b = Rozmisti_lodeX(3)
b = Rozmisti_lodeX(3)
b = Rozmisti_lodeX(3)
'ctyry dvojky
c = Rozmisti_lodeY(2)
c = Rozmisti_lodeX(2)
c = Rozmisti_lodeX(2)
c = Rozmisti_lodeY(2)
'pet jednicek (generuje 5 rovnou)
d = Rozmisti_lodeY(1)
End Select
If a = 0 And b = 0 And c = 0 And d = 0 And e = 0 And UBound(LodA) = 15 Then
Exit Do
Else
Randomize Timer
Vycisti_poleA
Vycisti_LodeA
End If
Loop
End Sub
Sub initComputer
a = -1: b = -1: c = -1: d = -1: e = -1
Do
Select Case Typ
Case 1
'dve ctyrky
a = Rozmisti_B_lodeY(4)
a = Rozmisti_B_lodeX(4)
' tri trojky
b = Rozmisti_B_lodeX(3)
b = Rozmisti_B_lodeY(3)
b = Rozmisti_B_lodeX(3)
'jedna petka
e = Rozmisti_B_lodeX(5)
'ctyry dvojky
c = Rozmisti_B_lodeY(2)
c = Rozmisti_B_lodeY(2)
c = Rozmisti_B_lodeX(2)
c = Rozmisti_B_lodeY(2)
'pet jednicek (generuje 5 rovnou)
d = Rozmisti_B_lodeY(1)
Case 2
a = Rozmisti_B_lodeX(4)
a = Rozmisti_B_lodeX(4)
' tri trojky
b = Rozmisti_B_lodeY(3)
b = Rozmisti_B_lodeY(3)
b = Rozmisti_B_lodeY(3)
'jedna petka
e = Rozmisti_B_lodeX(5)
'ctyry dvojky
c = Rozmisti_B_lodeY(2)
c = Rozmisti_B_lodeX(2)
c = Rozmisti_B_lodeX(2)
c = Rozmisti_B_lodeY(2)
'pet jednicek (generuje 5 rovnou)
d = Rozmisti_B_lodeY(1)
Case 3
'jedna petka
e = Rozmisti_B_lodeY(5)
a = Rozmisti_B_lodeY(4)
a = Rozmisti_B_lodeY(4)
' tri trojky
b = Rozmisti_B_lodeX(3)
b = Rozmisti_B_lodeX(3)
b = Rozmisti_B_lodeX(3)
'ctyry dvojky
c = Rozmisti_B_lodeY(2)
c = Rozmisti_B_lodeX(2)
c = Rozmisti_B_lodeX(2)
c = Rozmisti_B_lodeY(2)
'pet jednicek (generuje 5 rovnou)
d = Rozmisti_B_lodeY(1)
End Select
If a = 0 And b = 0 And c = 0 And d = 0 And e = 0 And UBound(LodB) = 15 Then
' PRINT UBOUND(lodB)
Exit Do
Else
Randomize Timer
Vycisti_poleB
Vycisti_LodeB
End If
Loop
End Sub
Sub textar (veta As String, x As Integer, y As Integer)
c = 25
For r = 1 To Len(veta$)
ch$ = UCase$(Mid$(veta$, r, 1))
Select Case ch$
Case ":": in = 36
Case "A": in = 0
Case "B": in = 1
Case "C": in = 2
Case "D": in = 3
Case "E": in = 4
Case "F": in = 5
Case "G": in = 6
Case "H": in = 7
Case "I": in = 8
Case "J": in = 9
Case "K": in = 10
Case "L": in = 11
Case "M": in = 12
Case "N": in = 13
Case "O": in = 14
Case "P": in = 15
Case "Q": in = 16
Case "R": in = 17
Case "S": in = 18
Case "T": in = 19
Case "U": in = 20
Case "V": in = 21
Case "W": in = 22
Case "X": in = 23
Case "Y": in = 24
Case "Z": in = 25
Case "0": in = 26
Case "1": in = 27
Case "2": in = 28
Case "3": in = 29
Case "4": in = 30
Case "5": in = 31
Case "6": in = 32
Case "7": in = 33
Case "8": in = 34
Case "9": in = 35
Case " ": in = -1
End Select
krokX = krokX + 9: If krokX > _Width - 13 - x Then krokX = 0: krokY = krokY + 12
If in = -1 Then _Continue
rozpis in, x + krokX, y + krokY
in = 0
Next
End Sub
Function reader (file As String)
Shared Frames
kx = 0: ky = 1
oo = FreeFile
If _FileExists(file$) Then Open file$ For Binary As #oo Else Beep: Print "Error opening file "; file$: Exit Function
ident$ = Space$(4)
ReDim big As Integer
Get #oo, , ident$
If ident$ <> "Petr" Then Print "This is not my file format": Sleep 2: Exit Function
Get #oo, , big
Frames = (LOF(oo) - 6) / (big ^ 2 / 8)
ReDim udaj As _Unsigned _Byte
ReDim Sn(Frames) As String
While Not EOF(oo)
Get #oo, , udaj
binar$ = DECtoBIN$(udaj)
Sn(snindex) = Sn(snindex) + binar$
For rozklad = 1 To Len(binar$)
inSeek = inSeek + 1
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
reader = big
Close #oo
End Function
Sub rozpis (snimek As Integer, posX As Integer, posY As Integer)
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
Function DECtoBIN$ (vstup)
Shared BINARY$
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 i32to256 (image As String, x As Integer, y As Integer) ' this is already on the .NET forum writed by me. As example how show pictures in 256 colors.
If _FileExists(image$) Then
image& = _LoadImage(image$, 32)
Type colors
ClrVal As Long ' this contais color number in long format (_RGB32)
ClrNmbr As Long ' this contais number for color. How much is this one color used in picture. Is for future use, if 32bit image contais more than 256 colors, then
End Type ' i will use the most used only.
ReDim colors(256) As colors
ReDim scn As Long, col As Long, scan As Long, control As Long, TotalColors As Long
ReDim m As _MEM
m = _MemImage(image&)
For scan = 0 To (_Width(image&) * _Height(image&) * 4) - 4 Step 4 ' use 32 bit, step is 4 byt * 8 bit = 32 bit, i read 4 bytes (LONG) in one loop, so STEP 4
_MemGet m, m.OFFSET + scan, col&
For control = 0 To TotalColors&
If col& = colors(control).ClrVal Then colors(control).ClrNmbr = colors(control).ClrNmbr + 1: col& = 0: Exit For
Next
If col& <> 0 Then colors(control + 1).ClrVal = col&: colors(control + 1).ClrNmbr = 1: TotalColors& = TotalColors& + 1: col& = 0
If TotalColors& > 255 Then Exit For
Next scan
If TotalColors& <= 256 Then
image256& = _NewImage(_Width(image&), _Height(image&), 256)
_Dest image256&
Dim m2 As _MEM
m2 = _MemImage(image256&)
For MESecam = 255 - TotalColors& To 255
_Dest 0
_PaletteColor MESecam, colors(255 - MESecam).ClrVal
Next
ReDim SelectColor As _Unsigned _Byte
For scan = 0 To (_Width(image&) * _Height(image&) * 4) - 4 Step 4
_MemGet m, m.OFFSET + scan, Value&
For SelectColor = 255 - TotalColors& To 255
If colors(255 - SelectColor).ClrVal& = Value& Then _MemPut m2, m2.OFFSET + position256, SelectColor
Next SelectColor
position256 = position256 + 1
Next scan
_PutImage (x, y), image256&, 0
_MemFree m: _MemFree m2: _FreeImage image&: _FreeImage image256&
Else Print "Image contains more than 256 colors."
End If
Else Print "File "; image$; " not exists.": Sleep 5
End If
End Sub
Sub SavePalette
For S = 0 To 255
Color _RGB(_Red(S), _Green(S), _Blue(S))
PaletteSave(S) = _RGB(_Red(S), _Green(S), _Blue(S))
Next S
End Sub
Sub ResetPalette
For S = 0 To 255
_PaletteColor S, _RGB32(_Red(PaletteSave(S)), _Green(PaletteSave(S)), _Blue(PaletteSave(S)))
Next S
End Sub
Sub menu
menuBegin:
_KeyClear
k& = 0
Cls
n = 1: gametype = 1
Do
i& = _KeyHit
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Select Case i&
Case 13: GoSub selected
Case 27: eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Case 18432: n = n - 1: If n < 1 Then n = 1
Case 20480: n = n + 1: If n > 4 Then n = 4
End Select
If INI.BSound Then midas
i32to256 "lod0.gif", 0, 30
Color 40
textar "Battle Ship 01 BETA", 10, 0
Select Case n
Case 1
Color 20
textar "Set game type", 150, 50
Color 40
textar "Setup", 150, 70
textar "About", 150, 90
textar "Quit game", 150, 110
Case 2
Color 40
textar "Set game type", 150, 50
Color 20
textar "Setup", 150, 70
Color 40
textar "About", 150, 90
textar "Quit game", 150, 110
Case 3
Color 40
textar "Set game type", 150, 50
textar "Setup", 150, 70
Color 20
textar "About", 150, 90
Color 40
textar "Quit game", 150, 110
Case 4
Color 40
textar "Set game type", 150, 50
textar "Setup", 150, 70
textar "About", 150, 90
Color 20
textar "Quit game", 150, 110
End Select
Color 15
_Display
Loop
selected:
Select Case n
Case 1 'select game type
Do While k& <> 13
k& = _KeyHit
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Select Case k&
Case 27: GoTo menuBegin 'destructor a k tomu uvolnit vse za hlavni smyckou
Case 18432: gametype = gametype - 1: If gametype < 1 Then gametype = 1
Case 20480: gametype = gametype + 1: If gametype > 2 Then gametype = 2
End Select
Select Case gametype
Case 1
If INI.BSound Then midas
i32to256 "lod0.gif", 0, 30
Color 20
textar "Game VS computer", 150, 50
Color 40
textar "LAN Game", 150, 70
Case 2
If INI.BSound Then midas
i32to256 "lod0.gif", 0, 30
Color 40
textar "Game VS computer", 150, 50
Color 20
textar "LAN Game", 150, 70
End Select
_Display
Loop
Select Case gametype
Case 1: Cls: i32to256 "lod0.gif", 0, 30: _Display: Lan = 0: Exit Sub
Case 2
If INI.BSound Then midas
Cls
i32to256 "lod0.gif", 0, 30
Color 40
textar "LAN GAME", 10, 0
textar "Press C for Client or H for Host", 10, 100
_Display
Do
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
i$ = InKey$
Select Case LCase$(i$)
Case "c": computer$ = "C": Exit Do
Case "h": computer$ = "H": Exit Do
End Select
Loop
If INI.BSound Then midas
Cls
i32to256 "lod0.gif", 0, 30
Color 40
textar "LAN GAME", 10, 0
If Len(computer$) Then Line (0, 0)-(150, 25), 0, BF
If computer$ = "C" Then
textar "Input IP adress or press ESC", 10, 1
IP$ = IPinput$(85, 82)
Line (0, 0)-(320, 25), 0, BF
Lan = Network(IP$)
Else
textar "Waiting for client", 10, 100:
Do Until Lan
Lan = Network(IP$)
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Loop
End If
If Lan = 0 Then GoTo menuBegin 'pressed ESC when HOST wait for CLIENT
_Display
End Select
Case 2 'sound setup
_MouseShow
If INI.BSound Then midas
Cls
While i& <> 27
_Limit 30
Color 40
textar "Setup", 100, 15
Color 15
textar "Use background music", 20, 50
textar "Use sound effects", 20, 80
textar "Use AUTO generator for ships", 20, 110
textar "Insert ships manually", 20, 140
If INI.BSound = 0 Then Line (10, 50)-(15, 55), 15, B Else Line (10, 50)-(15, 55), 14, BF
If INI.Esound = 0 Then Line (10, 80)-(15, 85), 15, B Else Line (10, 80)-(15, 85), 14, BF
If INI.Edit = "AUTO" Then Line (10, 110)-(15, 115), 14, BF Else Line (10, 110)-(15, 115), 15, B
If INI.Edit = "MANU" Then Line (10, 140)-(15, 145), 14, BF Else Line (10, 140)-(15, 145), 15, B
i& = _KeyHit
Do While _MouseInput
Select Case _MouseX
Case 10 To 15
Select Case _MouseY
Case 50 To 55: If _MouseButton(1) Then
Shared midTimer
If INI.BSound = 1 Then INI.BSound = 0: r = PlayMIDI("" + Chr$(0)) Else INI.BSound = 1: midTimer = 0: midas
End If
Case 80 To 85: If _MouseButton(1) Then
If INI.Esound = 1 Then INI.Esound = 0 Else INI.Esound = 1
End If
Case 110 To 115: If _MouseButton(1) Then
INI.Edit = "AUTO"
End If
Case 140 To 145
If _MouseButton(1) Then
INI.Edit = "MANU"
End If
End Select
End Select
Loop
_Display
Cls
Wend
INICreate INI.BSound, INI.Esound, INI.Edit
GoTo menuBegin
Case 3 'about
Cls
For F = 0 To 200
i32to256 "battleship.gif", 60, F
_Display
_Limit 25
Cls
Next F
Cls
Color 40
textar "About BattleShip game", 10, 10
textar "This game is based on desktop game", 1, 30
textar "as in previous picture", 1, 45
textar "Quads represents ships and player", 1, 60
textar "try destroy it all as first", 1, 75
textar "Both players have the same number", 1, 90
textar "of Ships", 1, 105
textar "Left map is for player and right", 1, 120
textar "map is for enemy", 1, 135
textar "Use mouse on the right map to ", 1, 150
textar "determine target and shoot", 1, 165
textar "Press any key ", 1, 190
_Display
i$ = ""
_KeyClear
Do Until i$ <> "": i$ = InKey$: If INI.BSound Then midas
Loop
ResetPalette
_AutoDisplay
GoTo menuBegin
Case 4 ' end
For CLOSURE = 0 To 7
_SndClose exploze(CLOSURE)
Next CLOSURE
_SndClose Splash&
eee = PlayMIDI&("")
Destructor "BattleShip.pmf"
System
End Select
End Sub
Function Network (IP As String)
_AutoDisplay
Client& = _OpenClient("TCP/IP:3455:" + LTrim$(IP$))
If Client& Then
Network = 2 'client
Else
Print "No host found"
_Delay 1
_Delay 1
Client& = _OpenHost("TCP/IP:3455")
If Client& Then
Print "Host created!"
Do
i& = _KeyHit
If i& = 27 Then Exit Function
Host& = _OpenConnection(Client&)
Locate 1, 1: Print "Waiting for CLIENT at "; _ConnectionAddress$(Client&)
_Display
Loop Until Host&
Cls
Network = 1
Else
eee = PlayMIDI&("")
Destructor "BattleShip.pmf"
System
End If
End If
End Function
Sub INICreate (BSound As _Byte, ESound As _Byte, Edit As String * 4)
lode = FreeFile
Open "lode.ini" For Output As #lode: Close #lode
Open "lode.ini" For Binary As #lode
INI.BSound = BSound
INI.Esound = ESound
INI.Edit = Edit
Put #lode, , INI
Close #lode
End Sub
Sub InsertShipsManually
ReDim LodA(15) As Lod
Dim shL(1) As Lod
Shared anima
index = 0
_AutoDisplay
If INI.BSound Then midas
poloha = 1
Vycisti_poleA
Cls
ResetPalette
Color 14
textar "Insert ALL ships to water then click to done or press Esc for quit Right click for ship rotate R for reset", -10, 1
Color 15
L1 = 5: L2 = 4: L3 = 3: L4 = 2: L5 = 1: x = 110: y = 60
oL1 = 5: oL2 = 4: oL3 = 3: oL4 = 2: oL5 = 1
PCopy _Display, 3
Do Until i& = 27
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
Dim pX As _Byte, pY As _Byte
For navrhy = 1 To 100 Step 10
For navrhx = 1 To 100 Step 10
Line (x + navrhx - 5, y + navrhy - 5)-(5 + x + navrhx, 5 + y + navrhy), 1, BF
Line (x + navrhx - 5, y + navrhy - 5)-(5 + x + navrhx, 5 + y + navrhy), 15, B
Line (275, 170)-(311, 190), 15, B
If complete Then Color 15 Else Color 19
_PrintString (278, 176), "Done"
Color 15
i& = _KeyHit
i$ = InKey$
If i& = 27 Then menu
If LCase$(i$) = "r" Then Vycisti_poleA: Vycisti_LodeA: index = 0: ReDim LodA(15) As Lod: L5 = 1: L4 = 2: L3 = 3: L2 = 4: L1 = 5
anima = anima + .0005: If anima > 3 Then anima = 1
pX = _Ceil(navrhx / 10): pY = _Ceil(navrhy / 10)
If poleA(pX, pY) = 0 Then
Color 53 + anima: rozpis 37 + Int(anima), 1 + x + navrhx - 5, 1 + y + navrhy - 5: Color 15
Else
Line (x + navrhx - 5, y + navrhy - 5)-(5 + x + navrhx, 5 + y + navrhy), 49, BF
End If
If poleA(pX, pY) = 1 Then
Line (x + navrhx - 5, y + navrhy - 5)-(5 + x + navrhx, 5 + y + navrhy), 29, BF
Line (x + navrhx - 5, y + navrhy - 5)-(5 + x + navrhx, 5 + y + navrhy), 15, B
End If
Next navrhx
If navrhy <= 90 Then textar Chr$(49 + navrhy / 10), 197, 55 + navrhy + 2
textar Chr$(65 + navrhy / 10), 94 + navrhy + 2, 160
textar "10", 197, 148
Next navrhy
Zobraz_Stav 5, 75, 1
textar Str$(L1) + "x", 40, 129
textar Str$(L2) + "x", 40, 116
textar Str$(L3) + "x", 40, 102
textar Str$(L4) + "x", 40, 89
textar Str$(L5) + "x", 40, 76
Do While _MouseInput
mx = _MouseX: my = _MouseY: Lb = _MouseButton(1): Rb = _MouseButton(2)
If mx > 5 And mx < 55 And my > 75 And my < 85 And Lb = -1 And L5 > 0 Then vybrano = 5
If mx > 15 And mx < 55 And my > 88 And my < 98 And Lb = -1 And L4 > 0 Then vybrano = 4
If mx > 25 And mx < 55 And my > 101 And my < 111 And Lb = -1 And L3 > 0 Then vybrano = 3
If mx > 35 And mx < 55 And my > 114 And my < 124 And Lb = -1 And L2 > 0 Then vybrano = 2
If mx > 45 And mx < 55 And my > 127 And my < 137 And Lb = -1 And L1 > 0 Then vybrano = 1
If vybrano > 1 And Rb = -1 Then poloha = poloha * -1: Rb = 0
If complete And Lb = -1 And mx > 275 And mx < 311 And my > 170 And my < 190 Then Exit Sub
Loop
Select Case vybrano ' BLOK JEN PRO GRAFICKE ZOBRAZENI! block for graphic view only ---------------------------------
Case 1
Line (mx - 5, my - 5)-(mx + 5, my + 5), 23, BF: Line (mx - 5, my - 5)-(mx + 5, my + 5), 15, B
Case 2
If poloha = 1 Then
For delka = mx - 5 To mx + 5 Step 10
Line (delka - 5, my - 5)-(delka + 5, my + 5), 23, BF: Line (delka - 5, my - 5)-(delka + 5, my + 5), 15, B
Next delka
Else
For delka = my - 5 To my + 5 Step 10
Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 23, BF: Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 15, B
Next delka
End If
Case 3
If poloha = 1 Then
For delka = mx - 10 To mx + 10 Step 10
Line (delka - 5, my - 5)-(delka + 5, my + 5), 23, BF: Line (delka - 5, my - 5)-(delka + 5, my + 5), 15, B
Next delka
Else
For delka = my - 10 To my + 10 Step 10
Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 23, BF: Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 15, B
Next delka
End If
Case 4
If poloha = 1 Then
For delka = mx - 15 To mx + 15 Step 10
Line (delka - 5, my - 5)-(delka + 5, my + 5), 23, BF: Line (delka - 5, my - 5)-(delka + 5, my + 5), 15, B
Next delka
Else
For delka = my - 15 To my + 15 Step 10
Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 23, BF: Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 15, B
Next delka
End If
Case 5
If poloha = 1 Then
For delka = mx - 20 To mx + 20 Step 10
Line (delka - 5, my - 5)-(delka + 5, my + 5), 23, BF: Line (delka - 5, my - 5)-(delka + 5, my + 5), 15, B
Next delka
Else
For delka = my - 20 To my + 20 Step 10
Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 23, BF: Line (mx - 5, delka - 5)-(mx + 5, delka + 5), 15, B
Next delka
End If
End Select
'------------------------------------------------------------------------------------------------------------------------------------------
'blok ktery prepocita kam chces lod umistit this block calculate, if your selected area in manual inserting is valid for ship
ReDim PnX As _Unsigned _Byte, PnY As _Unsigned _Byte
If mx > 106 And mx < 206 And my > 56 And my < 156 Then
PnX = _Ceil(mx - 101) / 10 'pnx i pny ok
PnY = _Ceil(my - 51) / 10
If vybrano = 1 And L1 > 0 Then
cilX = PnX: cilY = PnY
If Lb = -1 And VolnoA(PnX, PnY) Then poleA(PnX, PnY) = 1: L1 = L1 - 1
End If
If vybrano = 2 And poloha = 1 And L2 > 0 Then
If Lb = -1 And PnX - 1 > 0 Then
If VolnoA(PnX - 1, PnY) And VolnoA(PnX, PnY) Then poleA(PnX - 1, PnY) = 1: poleA(PnX, PnY) = 1: L2 = L2 - 1
End If
End If
If vybrano = 2 And poloha = -1 And L2 > 0 Then
If Lb = -1 And PnY - 1 > 0 Then
If VolnoA(PnX, PnY) And VolnoA(PnX, PnY - 1) Then poleA(PnX, PnY - 1) = 1: poleA(PnX, PnY) = 1: L2 = L2 - 1
End If
End If
If vybrano = 3 And poloha = 1 And L3 > 0 Then
If Lb = -1 And PnX - 1 > 0 And PnX + 1 < 11 Then
If VolnoA(PnX - 1, PnY) And VolnoA(PnX, PnY) And VolnoA(PnX + 1, PnY) Then poleA(PnX - 1, PnY) = 1: poleA(PnX, PnY) = 1: poleA(PnX + 1, PnY) = 1: L3 = L3 - 1
End If
End If
If vybrano = 3 And poloha = -1 And L3 > 0 Then
If Lb = -1 And PnY - 1 > 0 And PnY + 1 < 11 Then
If VolnoA(PnX, PnY + 1) And VolnoA(PnX, PnY) And VolnoA(PnX, PnY - 1) Then poleA(PnX, PnY - 1) = 1: poleA(PnX, PnY) = 1: poleA(PnX, PnY + 1) = 1: L3 = L3 - 1
End If
End If
If vybrano = 4 And poloha = 1 And L4 > 0 Then
If Lb = -1 And PnX - 1 > 0 And PnX + 2 < 11 Then
If VolnoA(PnX - 1, PnY) And VolnoA(PnX, PnY) And VolnoA(PnX + 1, PnY) And VolnoA(PnX + 2, PnY) Then poleA(PnX - 1, PnY) = 1: poleA(PnX, PnY) = 1: poleA(PnX + 1, PnY) = 1: poleA(PnX + 2, PnY) = 1: L4 = L4 - 1
End If
End If
If vybrano = 4 And poloha = -1 And L4 > 0 Then
If Lb = -1 And PnY - 1 > 0 And PnY + 2 < 11 Then
If VolnoA(PnX, PnY - 1) And VolnoA(PnX, PnY) And VolnoA(PnX, PnY + 1) And VolnoA(PnX, PnY + 2) Then poleA(PnX, PnY - 1) = 1: poleA(PnX, PnY) = 1: poleA(PnX, PnY + 1) = 1: poleA(PnX, PnY + 2) = 1: L4 = L4 - 1
End If
End If
If vybrano = 5 And poloha = 1 And L5 > 0 Then
If Lb = -1 And PnX - 2 > 0 And PnX + 2 < 11 Then
If VolnoA(PnX - 2, PnY) And VolnoA(PnX - 1, PnY) And VolnoA(PnX, PnY) And VolnoA(PnX + 1, PnY) And VolnoA(PnX + 2, PnY) Then poleA(PnX - 2, PnY) = 1: poleA(PnX - 1, PnY) = 1: poleA(PnX, PnY) = 1: poleA(PnX + 1, PnY) = 1: poleA(PnX + 2, PnY) = 1: L5 = L5 - 1
End If
End If
If vybrano = 5 And poloha = -1 And L5 > 0 Then
If Lb = -1 And PnY - 2 > 0 And PnY + 2 < 11 Then
If VolnoA(PnX, PnY - 2) And VolnoA(PnX, PnY - 1) And VolnoA(PnX, PnY) And VolnoA(PnX, PnY + 1) And VolnoA(PnX, PnY + 2) Then poleA(PnX, PnY - 2) = 1: poleA(PnX, PnY - 1) = 1: poleA(PnX, PnY) = 1: poleA(PnX, PnY + 1) = 1: poleA(PnX, PnY + 2) = 1: L5 = L5 - 1
End If
End If
If L1 = 0 And L2 = 0 And L3 = 0 And L4 = 0 And L5 = 0 Then complete = 1 Else complete = 0
textar "Position:" + Str$(PnX) + Str$(PnY), 250, 140
' IF opacnychod THEN index = index - 1: opacnychod = 0: GOTO nepricitat
If oL1 <> L1 Then index = index + 1: oL1 = L1: zmena = 1
If oL2 <> L2 Then index = index + 1: oL2 = L2: zmena = 1
If oL3 <> L3 Then index = index + 1: oL3 = L3: zmena = 1
If oL4 <> L4 Then index = index + 1: oL4 = L4: zmena = 1
If oL5 <> L5 Then index = index + 1: oL5 = L5: zmena = 1
nepricitat:
If index < 0 Then index = 0
If index > 15 Then
index = 0
Do Until LodA(index).x = 0 And LodA(index).y = 0
index = index + 1
Loop
zmena = 1
End If
If zmena Then
If poloha = 1 Then LodA(index).pos = "X"
If poloha = -1 Then LodA(index).pos = "Y"
LodA(index).typ = vybrano
If vybrano = 1 Then
LodA(index).x = PnX
LodA(index).y = PnY
End If
If vybrano = 2 And poloha = 1 Then
LodA(index).x = PnX - 1
LodA(index).y = PnY
End If
If vybrano = 2 And poloha = -1 Then
LodA(index).x = PnX
LodA(index).y = PnY - 1
End If
If vybrano = 3 And poloha = 1 Then
LodA(index).x = PnX - 1
LodA(index).y = PnY
End If
If vybrano = 3 And poloha = -1 Then
LodA(index).x = PnX
LodA(index).y = PnY - 1
End If
If vybrano = 4 And poloha = 1 Then
LodA(index).x = PnX - 1
LodA(index).y = PnY
End If
If vybrano = 4 And poloha = -1 Then
LodA(index).x = PnX
LodA(index).y = PnY - 1
End If
If vybrano = 5 And poloha = 1 Then
LodA(index).x = PnX - 2
LodA(index).y = PnY
End If
If vybrano = 5 And poloha = -1 Then
LodA(index).x = PnX
LodA(index).y = PnY - 2
End If
vybrano = 0
zmena = 0
End If
End If
_Display
_Limit 75
PCopy 3, _Display
Loop
End Sub
Function IPinput$ (x As Integer, y As Integer) ' PRESS ENTER FOR LOCALHOST MODE
_AutoDisplay
_PrintString (30, 180), "PRESS ENTER FOR LOCALHOST MODE!"
Line (x, y)-(x + 150, y + 35), 18, BF
Line (x, y)-(x + 150, y + 35), 15, B
Color , 18
_PrintString (x + 35, y + 5), "Insert IP:"
Line (x, y)-(x + 150, y + 18), 15, B
Line (x + 13, y + 19)-(x + 40, y + 34), 19, BF
Line (x + 45, y + 19)-(x + 72, y + 34), 19, BF
Line (x + 77, y + 19)-(x + 104, y + 34), 19, BF
Line (x + 109, y + 19)-(x + 135, y + 34), 19, BF
For dot = 42 To 132 Step 32
PSet (x + dot, y + 32), 15
Next dot
Do
i& = _KeyHit
If _Exit Then eee = PlayMIDI&(""): Destructor ("battleship.pmf"): System
If i& = 27 Then _KeyClear: Exit Function
If i& = 13 Then IPinput$ = "localhost": Exit Function
f = _MouseInput
If _MouseButton(1) Then
Select Case _MouseY
Case y + 19 To y + 34
Select Case _MouseX
Case x + 13 To x + 40
o = 0: v$ = ""
Do While o < 3
midas
v$ = InKey$
p1:
If Len(v$) Then
If Asc(v$) >= 48 And Asc(v$) <= 57 And Len(p$) < 3 Then p$ = p$ + v$: o = o + 1
If Asc(v$) = 8 Then p$ = Left$(p$, Len(p$) - 1): o = o - 1
If o < 0 Then o = 0
If Val(p$) < 256 Then c = 15 Else c = 40
Color c, 19
_PrintString (x + 15, y + 24), " "
_PrintString (x + 15, y + 24), p$
If o = 3 Then GoTo p2 'druhe okenko
End If
Loop
Case x + 45 To x + 72
p2:
o = 0: v$ = ""
Do While o < 3
midas
v$ = InKey$
p2a:
If Len(v$) Then
If Asc(v$) >= 48 And Asc(v$) <= 57 And Len(p2$) < 3 Then p2$ = p2$ + v$: o = o + 1
If Asc(v$) = 8 Then p2$ = Left$(p2$, Len(p2$) - 1): o = o - 1
If Val(p2$) < 256 Then c = 15 Else c = 40
Color c, 19
_PrintString (x + 47, y + 24), " "
_PrintString (x + 47, y + 24), p2$
If o < 0 Then o = 3: GoTo p1
If o = 3 Then GoTo p3 'treti okenko
End If
Loop
Case x + 77 To x + 104
p3:
o = 0: v$ = ""
Do While o < 3
midas
v$ = InKey$
p3a:
If Len(v$) Then
If Asc(v$) >= 48 And Asc(v$) <= 57 And Len(p3$) < 3 Then p3$ = p3$ + v$: o = o + 1
If Asc(v$) = 8 Then p3$ = Left$(p3$, Len(p3$) - 1): o = o - 1
If Val(p3$) < 256 Then c = 15 Else c = 40
Color c, 19
_PrintString (x + 77, y + 24), " "
_PrintString (x + 77, y + 24), p3$
If o < 0 Then o = 3: GoTo p2a
If o = 3 Then GoTo p4 'ctvrte okenko
End If
Loop
Case x + 109 To x + 135
p4:
o = 0: v$ = ""
Do
midas
v$ = InKey$
If Len(v$) Then
If Asc(v$) >= 48 And Asc(v$) <= 57 And Len(p4$) < 3 Then p4$ = p4$ + v$: o = o + 1
If o > 3 Then o = 3
If Asc(v$) = 8 Then p4$ = Left$(p4$, Len(p4$) - 1): o = o - 1
If Val(p4$) < 256 Then c = 15 Else c = 40
Color c, 19
_PrintString (x + 109, y + 24), " "
_PrintString (x + 109, y + 24), p4$
If o < 0 Then o = 3: GoTo p3a
'IF o = 3 THEN GOTO p4 'ctvrte okenko
If v$ = Chr$(13) Then
If Val(p$) < 256 And Val(p2$) < 256 And Val(p3$) < 256 And Val(p4$) < 256 Then
IPinput$ = p$ + LTrim$(".") + LTrim$(p2$) + LTrim$(".") + LTrim$(p3$) + LTrim$(".") + LTrim$(p4$): Exit Function
Else
Beep 'invalid ip range
End If
End If
End If
Loop
End Select
End Select
End If
Loop
End Function
Sub LanHost
pass = 0
For aLan = 1 To 10
For bLan = 1 To 10
value = poleA(aLan, bLan) + 1
Put #Host, , value
pass = 0
Next bLan, aLan
Do Until pass
Get #Host, , pass
Loop
pass = 1
For PrijemC = 1 To 10
For prijemCl = 1 To 10
Do Until valu
Get #Host, , valu
poleB(PrijemC, prijemCl) = valu - 1
Loop
valu = 0
Next prijemCl
Next PrijemC
Put #Host, , pass
pass = 0 'od 5
prenes_LodA_Host
End Sub
Sub prenes_LodA_Host
valu = 0: pass = 0
For posli = LBound(LodA) To UBound(LodA)
LX = LodA(posli).x + 1
LY = LodA(posli).y + 1
LS = Asc(LodA(posli).pos)
LT = LodA(posli).typ + 1
Put #Host, , LX
Put #Host, , LY
Put #Host, , LS
Put #Host, , LT
Next posli
pass = 1
value = 0
For posli = LBound(LodA) To UBound(LodA)
Get #Host, , value: LodB(posli).x = value - 1: value = 0
Get #Host, , value: LodB(posli).y = value - 1: value = 0
Get #Host, , value: LodB(posli).pos = Chr$(value): value = 0
Get #Host, , value: LodB(posli).typ = value - 1: value = 0
Next posli
End Sub
Sub LanClient
value = 0
pass = 1
For aLan = 1 To 10
For bLan = 1 To 10
Do Until value
Get #Client, , value
poleB(aLan, bLan) = value - 1
Loop
value = 0
Next bLan
Next aLan
Put #Client, , pass
For poA = 1 To 10
For poAA = 1 To 10
value = poleA(poA, poAA) + 1
Put #Client, , value
value = 0
Next poAA, poA
Do Until ok
Get #Client, , ok
Loop
ok = 0
pass = 0 'od 5
prenes_LodA_Client
End Sub
Sub prenes_LodA_Client
valu = 0: pass = 0
For posli = LBound(LodA) To UBound(LodA)
LX = LodA(posli).x + 1
LY = LodA(posli).y + 1
LS = Asc(LodA(posli).pos)
LT = LodA(posli).typ + 1
Put #Client, , LX
Put #Client, , LY
Put #Client, , LS
Put #Client, , LT
Next posli
pass = 1
value = 0
For posli = LBound(LodA) To UBound(LodA)
Get #Client, , value: LodB(posli).x = value - 1: value = 0
Get #Client, , value: LodB(posli).y = value - 1: value = 0
Get #Client, , value: LodB(posli).pos = Chr$(value): value = 0
Get #Client, , value: LodB(posli).typ = value - 1: value = 0
Next posli
End Sub
Sub Constructor (vystup As String) 'extract files from .PMF
Type head2
identity As String * 16
much As Long
End Type
If InStr(1, LCase$(vystup$), ".pmf") Then Else vystup$ = vystup$ + ".PMF"
If _FileExists(vystup$) Then
Dim head As head2
e = FreeFile
Open vystup$ For Binary As #e
Get #e, , head
If head.identity = "Petr's MultiFile" Then Else Print "Head Failure": Sleep 3: End
Dim starts(head.much) As Long
For celek = 1 To head.much
Get #e, , starts(celek)
Next
Seek #e, 21 + head.much * 4 ' start DATA area
For total = 1 To head.much
If total = 1 Then velikost& = starts(1) - (21 + head.much * 4) Else velikost& = starts(total) - starts(total - 1) 'velikost is SIZE english -
record$ = Space$(velikost&)
Get #e, , record$
i = FreeFile
jmeno$ = "$Ext" + LTrim$(Str$(total))
Open jmeno$ For Output As #i: Close #i: Open jmeno$ For Binary As #i
Put #i, , record$
Close #i
Next total
Dim NamesLenght(head.much) As Integer
For NameIt = 1 To head.much
Get #e, , NamesLenght(NameIt)
' PRINT "File name: "; NameIt; "lenght in bytes is "; NamesLenght(NameIt)
Next NameIt
Close #i
For Name2 = 1 To head.much
s$ = Space$(NamesLenght(Name2))
Get #e, , s$
jm$ = "$Ext" + LTrim$(Str$(Name2))
erh:
If _FileExists(s$) Then
Beep: Input "Warnig! Extracted file the same name already exists!!!! (O)verwrite, (R)ename or (E)xit? "; er$
Select Case LCase$(er$)
Case "o": Kill s$: Name jm$ As s$
Case "r": Input "Input new name"; s$: GoTo erh
Case "e": Destructor "tetris.pmf": System
End Select
Else
Name jm$ As s$
End If
Next Name2
Close #e
For ctrl = 1 To head.much
nam$ = "$ext" + LTrim$(Str$(ctrl))
If _FileExists(nam$) Then Kill nam$
Next ctrl
Else
Print "Specified file not found": Sleep 3
End If
End Sub
Sub Destructor (vystup As String) 'delete files created by Constructor
Type head
identity As String * 16
much As Long
End Type
If InStr(1, LCase$(vystup$), ".pmf") Then Else vystup$ = vystup$ + ".PMF"
If _FileExists(vystup$) Then
Close
Dim head As head
e = FreeFile
Open vystup$ For Binary As #e
Get #e, , head
Dim starts(head.much) As Long
For celek = 1 To head.much
Get #e, , starts(celek)
Next
Seek #e, starts(head.much) ' start DATA area
Dim NamesLenght(head.much) As Integer
For NameIt = 1 To head.much
Get #e, , NamesLenght(NameIt)
Next NameIt
For Name2 = 1 To head.much
s$ = Space$(NamesLenght(Name2))
Get #e, , s$
If _FileExists(s$) Then Kill s$
Next Name2
Close #e
Else
Print "Specified file not found": Sleep 3
End If
End Sub