| Welcome, Guest |
You have to register before you can post on our site.
|
| Forum Statistics |
» Members: 485
» Latest member: zenevan
» Forum threads: 2,804
» Forum posts: 26,470
Full Statistics
|
|
|
| Othello 1977 (ported by justsomeguy) |
|
Posted by: SMcNeill - 12-24-2023, 06:26 AM - Forum: Games
- No Replies
|
 |
Quote:While reading old computer magazines, I came across this Othello game published in 1977, and I was curious how backward compatible QB64 was. Apparently very!
This is a very old school game so no mouse clicky. It has instructions built-in, so It shouldn't be too hard to figure it out. I'm ashamed to say I have yet to be able to beat it, but I suck at these kind of games.
I used OCR to port this program in, so there a few misspellings and oddities.
The original article can be found here. -> https://archive.org/details/byte-magazin...1/mode/2up
Code: (Select All)
10 ' https://archive.org/details/byte-magazin...1/mode/2up
20 '
30 '
40 '
50 '
60 '
70 '
80 ' OTHELLO AUTHOR: RICHARD O. DUDA PLAYS THE GAME "OTHELLO" WITH TWO STRATEGIES:
' 1. TAKE THE MAXIMUM NUMBER OF PIECES
' 2. ADD A BONUS FOR OUTSIDE POSITION BOARD IS THE ARRAY A, BOUNDED BY 0'S (BLANKS) A = 0 FOR EMPTY SQUARE A = B FOR BLACK SQUARE -- X (INTERNALLY -1) A = W FOR WHITE SQUARE -- 0 (INTERNALLY +1)
90 ' I AND J ALWAYS USED FOR ROW/COLUMN INDICES
100 ' I4 AND J4 STORE INC'ENTS TO THE 8 NEIGHBORS
110 ' C$ AND D$ STORE CHARACTERS A-H,X,.,O FOR OUTPUT
120 Dim A(9, 9), I4(8), J4(8), C$(8), D$(2)
130 ' INITIAL GREETING
140 Print "GREETINGS FROM OTHELLO"
150 Print "DO YOU WANT INSTRUCTIONS (Y OR N) ";
160 Input X$
170 If X$ = "N" Then 390
180 If X$ <> "Y" Then 160
190 Print
200 Print "OTHELLO IS PLAYED ON AN 8 X 8 CHECKER BOARD,"
210 Print "ROWS NUMBERED 1 TO 8 AND COLUMNS A TO H."
220 Print "THE INITIAL CONFIGURATION IS ALL BLANK, EXCEPT"
230 Print "FOR THE CENTER FOUR SQUARES, WHICH FORM THE"
240 Print "PATTERN"
250 Print " 0 X"
260 Print " X 0"
270 Print
280 Print "TRY TO PLACE YOUR PIECE SO THAT IT 'OUTFLANKS'"
290 Print "MINE, CREATING A HORIZONTAL, VERTICAL, OR"
300 Print "DIAGONAL RUN OF MY PIECES BOUNDED AT EACH END"
310 Print "BY AT LEAST ONE OF YOURS. THIS WILL 'FLIP' MY"
320 Print "PIECES, TURNING THEM INTO YOURS."
330 Print "NOTE: YOU MUST CAPTURE AT LEAST ONE OF MY"
340 Print "PIECES IN THIS WAY IF IT IS AT ALL POSSIBLE."
350 Print "IF IT IS NOT POSSIBLE, YOU FORFEIT YOUR TURN BY"
360 Print "ENTERING 0,0 FOR YOUR (ROW,COL) MOVE."
370 Print
380 ' INITIALIZE
390 Print "SHOULD I WAIT BEFORE MAKING MY MOVES (Y OR N) ";
400 F2 = 0
410 Input X$
420 If X$ = "N" Then 460
430 If X$ <> "Y" Then 410
440 F2 = 1
450 Print "OK. TYPING ANY CHARACTER WILL LET ME GO."
460 Print "SHOULD I PLAY MY BEST STRATEGY (Y OR N)"
470 S2 = 0
480 Input X$
490 If X$ = "N" Then 520
500 If X$ <> "Y" Then 480
510 S2 = 2
520 B = -1
530 W = 1
540 D$(B + 1) = "X"
550 D$(0 + 1) = "."
560 D$(W + 1) = "0"
570 For K = 1 To 8
580 Read I4(K)
590 Next K
600 Data 0,-1,-1,-1,0,1,1,1
610 For K = 1 To 8
620 Read J4(K)
630 Next K
640 Data 1,1,0,-1,-1,-1,0,1
650 For K = 1 To 8
660 Read C$(K)
670 Next K
680 Data "A","B","C","D","E","F","G","H"
690 ' SET UP A NEW GAME
700 For I = 0 To 9
710 For J = 0 To 9
720 A(I, J) = 0
730 Next J
740 Next I
750 A(4, 4) = W
760 A(5, 5) = W
770 A(4, 5) = B
780 A(5, 4) = B
790 C1 = 2
800 H1 = 2
810 N1 = 4
820 Z = 0
830 ' HUMAN'S CHOICES
840 Print "DO YOU WANT TO HAVE X OR 0 ";
850 C = W
860 H = B
870 Input X$
880 If X$ = "X" Then 920
890 If X$ <> "0" Then 870
900 C = B
910 H = W
920 Print "DO YOU WANT TO GO FIRST (Y OR N) ";
930 Input X$
940 If X$ = "N" Then 1020
950 If X$ <> "Y" Then 930
960 ' PRINT INITIAL BOARD
970 GoSub 3100
980 GoTo 1690
990 ' COMPUTER'S MOVE
1000 If F2 = 0 Then 1020
1010 Input X$
1020 B1 = -1
1030 I3 = J3 = 0
1040 T1 = C
1050 T2 = H
1060 ' SCAN FOR BLANK SQUARE
1070 For I = 1 To 8
1080 For J = 1 To 8
1090 If A(I, J) <> 0 Then 1380
1100 ' FOUND A BLANK SQUARE
1110 ' DOES IT HAVE AN OPPONENT AS A NEIGHBOR?
1120 GoSub 2620
1130 If F1 = 0 Then 1380
1140 ' FOUND AN OPPONENT AS A NEIGHBOR
1150 ' HOW MANY OF HIS PIECES CAN WE FLIP?
1160 ' (DON'T DO IT NOW)
1170 U = -1
1180 GoSub 2820
1190 ' EXTRA POINTS FOR BOUNDARY POSITION
1200 If S1 = 0 Then 1380
1210 If (I - 1) * (I - 8) <> 0 Then 1230
1220 S1 = S1 + S2
1230 If (J - 1) * (J - 8) <> 0 Then 1260
1240 S1 = S1 + S2
1250 ' IS THIS BETTER THAN THE BEST FOUND SO FAR?
1260 If S1 < B1 Then 1380
1270 If S1 > B1 Then 1340
1280 ' A TIE; RANDOM DECISION
1290 ' THE NEXT TWO EXECUTABLE STATEMENTS CAN BE DELETED
1300 ' FOR A VERSION OF BASIO WITHOUT RANDOM NUMBERS
1310 R = Rnd
1320 If R > 0.5 Then 1380
1330 ' YES
1340 B1 = S1
1350 I3 = I
1360 J3 = J
1370 ' END OF SCAN LOOP
1380 Next J
1390 Next I
1400 ' COULD WE DO ANYTHING?
1410 If B1 > 0 Then 1480
1420 ' NO
1430 Print "I HAVE TO FORFEIT MY MOVE"
1440 If Z = 1 Then 2190
1450 Z = 1
1460 GoTo 1690
1470 ' MAKE THE MOVE
1480 Z = 0
1490 Print "I WILL MOVE TO ";
1500 Print I3;
1510 Print ", ";
1520 Print C$(J3)
1530 I = I3
1540 J = J3
1550 U = 1
1560 GoSub 2820
1570 C1 = C1 + S1 + 1
1580 H1 = H1 - S1
1590 N1 = N1 + 1
1600 Print "THAT GIVES ME ";
1610 Print S1;
1620 Print " OF YOUR PIECES"
1630 ' PRINT OUT BOARD
1640 GoSub 3100
1650 ' TEST FOR END OF GAME
1660 If H1 = 0 Then 2190
1670 If N1 = 64 Then 2190
1680 ' HUMAN'S MOVE
1690 T1 = H
1700 T2 = C
1710 Print "YOUR MOVE -- (ROW, COL) ";
1720 Input I, X$
1730 If I < 0 Then 1720
1740 If I > 8 Then 1720
1750 If I <> 0 Then 1820
1760 Print "ARE YOU FORFEITING YOUR TURN (Y OR N)"
1770 Input X$
1780 If X$ <> "Y" Then 1710
1790 If Z = 1 Then 2190
1800 Z = 1
1810 GoTo 1000
1820 For J = 1 To 8
1830 If C$(J) = X$ Then 1870
1840 Next J
1850 GoTo 1720
1860 ' CHECK IF BLANK
1870 If A(I, J) = 0 Then 1910
1880 Print "SORRY, THAT SQUARE IS OCCUPIED; TRY AGAIN."
1890 GoTo 1720
1900 ' CHECK FOR LEGAL NEIGHBOR
1910 GoSub 2620
1920 If F1 = 1 Then 1970
1930 Print "SORRY, YOU ARE NOT NEXT TO ONE OF MY PIECES;"
1940 Print "TRY AGAIN"
1950 GoTo 1720
1960 ' CHECK IF LEGAL RUN
1970 U = -1
1980 GoSub 2820
1990 If S1 > 0 Then 2030
2000 Print "SORRY, THAT DOESN'T FLANK A ROW; TRY AGAIN"
2010 GoTo 1720
2020 ' EVERYTHING LEGAL; MAKE HUMAN'S MOVE
2030 Z = 0
2040 Print "THAT GIVES YOU ";
2050 Print S1;
2060 Print " OF MY PIECES"
2070 U = 1
2080 GoSub 2820
2090 H1 = H1 + S1 + 1
2100 C1 = C1 - S1
2110 N1 = N1 + 1
2120 '. PRINT OUT BOARD
2130 GoSub 3100
2140 ' TEST FOR END OF GAME
2150 If C1 = 0 Then 2190
2160 If N1 = 64 Then 2190
2170 GoTo 1000
2180 ' END OF GAME WRAPUP
2190 Print
2200 Print "YOU HAVE ";
2210 Print H1;
2220 Print " PIECES AND I HAVE ";
2230 Print C1;
2240 Print " PIECES -- ";
2250 If H1 = C1 Then 2290
2260 If H1 > C1 Then 2310
2270 Print "SORRY, I WON THAT ONE."
2280 GoTo 2320
2290 Print "A TIE !I"
2300 GoTo 2500
2310 Print "YOU WON 1"
2320 C1 = C1 - H1
2330 If C1 > 0 Then 2350
2340 C1 = -C1
2350 C1 = (64 * C1) / N1
2360 Print "THAT WAS A ";
2370 If C1 < 11 Then 2490
2380 If C1 < 25 Then 2470
2390 If C1 < 39 Then 2450
2400 If C1 < 53 Then 2430
2410 Print "PERFECT GAME."
2420 GoTo 2500
2430 Print "WALKAWAY."
2440 GoTo 2500
2450 Print "FIGHT."
2460 GoTo 2500
2470 Print "HOT GAME !"
2480 GoTo 2500
2490 Print "SQUEAKER !!"
2500 Print
2510 Print "DO YOU WANT TO PLAY ANOTHER GAME (Y OR N) ";
2520 Input X$
2530 If X$ = "Y" Then 700
2540 If X$ <> "N" Then 2520
2550 Print "THANKS FOR PLAYING."
2560 Stop
2570 '
2580 ' SUBROUTINE TEST-FOR-PROPER-NEIGHBOR
2590 ' ASSUMES:
2600 ' I,J LOCATES A BLANK SQUARE
2610 ' YOU HOPE TO SEE AN ADJACENT T2 (. -T1)
2620 For I1 = -1 To 1
2630 For J1 = -1 To 1
2640 If A(I + I1, J + J1) = T2 Then 2710
2650 Next J1
2660 Next I1
2670 ' NO T2 FOUND; FAILURE
2680 F1 = 0
2690 Return
2700 ' SUCCESS
2710 F1 = 1
2720 Return
2730 ' SUBROUTINE SCORE-AND-UPDATE
2740 ' ASSUMES:
2750 ' (I,J) IS A TENTATIVE PLACE FOR A PIECE T1.
2760 ' WANT RUNS OF T2 . -T1, TERMINATED BY A T1.
2770 ' IF U IS TRUE (1), MARK THOSE RUNS AS T1'S.
2780 ' RETURN SUM OF ALL RUNS (T2'S ONLY) IN S1.
2790 ' MAIN PROGRAM CONTAINS THE FOLLOWING ARRAYS:
2800 ' i4: 0 -1 -1 -1 0 1 1 1
2810 ' J4: 1 1 0 -1 -1 -1 0 1
2820 S1 = 0
2830 For K = 1 To 8
2840 I5 = I4(K)
2850 J5 = J4(K)
2860 I6 = I + I5
2870 J6 = J + J5
2880 S3 = 0
2890 If A(I6, J6) <> T2 Then 3070
2900 ' LOOP THROUGH THE RUN
2910 S3 = S3 + 1
2920 I6 = I6 + I5
2930 J6 = J6 + J5
2940 If A(I6, J6) = T1 Then 2970
2950 If A(I6, J6) = 0 Then 3070
2960 GoTo 2910
2970 S1 = S1 + S3
2980 If U <> 1 Then 3070
2990 ' UPDATE BOARD
3000 I6 = I
3010 J6 = J
3020 For K1 = 0 To S3
3030 A(I6, J6) = T1
3040 I6 = I6 + I5
3050 J6 = J6 + J5
3060 Next K1
3070 Next K
3080 Return
3090 ' SUBROUTINE PRINT-BOARD
3100 Print
3110 Print " A B C D E F G H"
3120 For I = 1 To 8
3130 Print I;
3140 For J = 1 To 8
3150 Print " ";
3160 Print D$(A(I, J) + 1);
3170 Next J
3180 Print
3190 Next I
3200 Print
3210 Return
3220 End
|
|
|
| Battleship (LAN or Local Game) by Petr |
|
Posted by: SMcNeill - 12-24-2023, 06:19 AM - Forum: Games
- No Replies
|
|
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: 67)
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
|
|
|
|
| Tetris by vince |
|
Posted by: SMcNeill - 12-24-2023, 06:02 AM - Forum: Games
- Replies (1)
|
|
Quote:Description:
clean and simple tetris implementation. you can change variables size, sw, and sh for custom board sizes.
20:55 < _vince> ive said it before but i think tetris is the ultimate test of a
programmer
20:55 < _vince> as it combines all programming concepts but doesnt demand any
specialized knowledge
controls:
* arrow keys: movement, up: rotate
* shift + left/right/down: hard left/right/drop
* spacebar: hard drop
* +/-: change speed
* p: pause
* Enter: restart
* Esc: quit
Code: (Select All)
Randomize Timer
DefLng A-Z
Dim Shared piece(6, 3, 1)
Dim Shared piece_color(6)
Dim Shared size, sw, sh
size = 35
sw = 10
sh = 20
ReDim Shared board(sw - 1, sh - 1)
piece(0, 0, 0) = 0: piece(0, 1, 0) = 1: piece(0, 2, 0) = 1: piece(0, 3, 0) = 0
piece(0, 0, 1) = 0: piece(0, 1, 1) = 1: piece(0, 2, 1) = 1: piece(0, 3, 1) = 0
piece(1, 0, 0) = 1: piece(1, 1, 0) = 1: piece(1, 2, 0) = 1: piece(1, 3, 0) = 1
piece(1, 0, 1) = 0: piece(1, 1, 1) = 0: piece(1, 2, 1) = 0: piece(1, 3, 1) = 0
piece(2, 0, 0) = 0: piece(2, 1, 0) = 0: piece(2, 2, 0) = 1: piece(2, 3, 0) = 1
piece(2, 0, 1) = 0: piece(2, 1, 1) = 1: piece(2, 2, 1) = 1: piece(2, 3, 1) = 0
piece(3, 0, 0) = 0: piece(3, 1, 0) = 1: piece(3, 2, 0) = 1: piece(3, 3, 0) = 0
piece(3, 0, 1) = 0: piece(3, 1, 1) = 0: piece(3, 2, 1) = 1: piece(3, 3, 1) = 1
piece(4, 0, 0) = 0: piece(4, 1, 0) = 1: piece(4, 2, 0) = 1: piece(4, 3, 0) = 1
piece(4, 0, 1) = 0: piece(4, 1, 1) = 0: piece(4, 2, 1) = 1: piece(4, 3, 1) = 0
piece(5, 0, 0) = 0: piece(5, 1, 0) = 1: piece(5, 2, 0) = 1: piece(5, 3, 0) = 1
piece(5, 0, 1) = 0: piece(5, 1, 1) = 1: piece(5, 2, 1) = 0: piece(5, 3, 1) = 0
piece(6, 0, 0) = 0: piece(6, 1, 0) = 1: piece(6, 2, 0) = 1: piece(6, 3, 0) = 1
piece(6, 0, 1) = 0: piece(6, 1, 1) = 0: piece(6, 2, 1) = 0: piece(6, 3, 1) = 1
Screen _NewImage(sw * size, sh * size, 32)
piece_color(0) = _RGB(0, 200, 0)
piece_color(1) = _RGB(200, 0, 0)
piece_color(2) = _RGB(156, 85, 211)
piece_color(3) = _RGB(219, 112, 147)
piece_color(4) = _RGB(0, 100, 250)
piece_color(5) = _RGB(230, 197, 92)
piece_color(6) = _RGB(0, 128, 128)
Dim t As Double
redraw = -1
speed = 10
lines = 0
pause = 0
putpiece = 0
startx = (sw - 4) / 2
pn = Int(Rnd * 7)
px = startx
py = 1
rot = 0
title$ = "lines=" + LTrim$(Str$(lines)) + ",speed=" + LTrim$(Str$(speed))
_Title title$
t = Timer
Do
If (Timer - t) > (1 / speed) And Not pause Then
If valid(pn, px, py + 1, rot) Then py = py + 1 Else putpiece = -1
t = Timer
redraw = -1
End If
If putpiece Then
If valid(pn, px, py, rot) Then
n = place(pn, px, py, rot)
If n Then
lines = lines + n
title$ = "lines=" + LTrim$(Str$(lines)) + ",speed=" + LTrim$(Str$(speed))
_Title title$
End If
End If
pn = Int(Rnd * 7)
px = startx
py = 0
rot = 0
putpiece = 0
redraw = -1
If Not valid(pn, px, py, rot) Then
For y = 0 To sh - 1
For x = 0 To sw - 1
board(x, y) = 0
Next
Next
lines = 0
title$ = "lines=" + LTrim$(Str$(lines)) + ",speed=" + LTrim$(Str$(speed))
_Title title$
End If
End If
If redraw Then
Line (0, 0)-(sw * size, sh * size), _RGB(0, 0, 0), BF
For y = 0 To sh - 1
For x = 0 To sw - 1
If board(x, y) <> 0 Then
Line (x * size, y * size)-Step(size - 2, size - 2), piece_color(board(x, y) - 1), BF
Else
Line (x * size, y * size)-Step(size - 2, size - 2), _RGB(50, 50, 50), B
End If
Next
Next
For y = 0 To 1
For x = 0 To 3
rotate xx, yy, x, y, pn, rot
If piece(pn, x, y) Then Line ((px + xx) * size, (py + yy) * size)-Step(size - 2, size - 2), piece_color(pn), BF
Next
Next
_Display
redraw = 0
End If
k = _KeyHit
If k Then
shift = _KeyDown(100304) Or _KeyDown(100303)
Select Case k
Case 18432 'up
If valid(pn, px, py, (rot + 1) Mod 4) Then rot = (rot + 1) Mod 4
pause = 0
Case 19200 'left
If shift Then
For xx = 0 To sw - 1
If Not valid(pn, px - xx, py, rot) Then Exit For
Next
px = px - xx + 1
Else
If valid(pn, px - 1, py, rot) Then px = px - 1
End If
pause = 0
Case 19712 'right
If shift Then
For xx = px To sw - 1
If Not valid(pn, xx, py, rot) Then Exit For
Next
px = xx - 1
Else
If valid(pn, px + 1, py, rot) Then px = px + 1
End If
pause = 0
Case 20480, 32 'down
If shift Or k = 32 Then
For yy = py To sh - 1
If Not valid(pn, px, yy, rot) Then Exit For
Next
py = yy - 1
putpiece = -1
Else
If valid(pn, px, py + 1, rot) Then py = py + 1
End If
pause = 0
Case 112 'p
pause = Not pause
Case 13 'enter
For y = 0 To sh - 1
For x = 0 To sw - 1
board(x, y) = 0
Next
Next
pn = Int(Rnd * 7)
px = startx
py = 0
rot = 0
putpiece = 0
lines = 0
title$ = "lines=" + LTrim$(Str$(lines)) + ",speed=" + LTrim$(Str$(speed))
_Title title$
Case 43, 61 'plus
If speed < 100 Then
speed = speed + 1
title$ = "lines=" + LTrim$(Str$(lines)) + ",speed=" + LTrim$(Str$(speed))
_Title title$
End If
Case 95, 45
If speed > 1 Then
speed = speed - 1
title$ = "lines=" + LTrim$(Str$(lines)) + ",speed=" + LTrim$(Str$(speed))
_Title title$
End If
Case 27
Exit Do
End Select
redraw = -1
End If
Loop
System
Sub rotate (xx, yy, x, y, pn, rot)
Select Case pn
Case 0
rot_new = 0
Case 1 To 3
rot_new = rot Mod 2
Case 4 To 6
rot_new = rot
End Select
Select Case rot_new
Case 0
xx = x
yy = y
Case 1
xx = y + 2
yy = 2 - x
Case 2
xx = 4 - x
yy = 1 - y
Case 3
xx = 2 - y
yy = x - 1
End Select
End Sub
Function valid (pn, px, py, rot)
For y = 0 To 1
For x = 0 To 3
rotate xx, yy, x, y, pn, rot
If py + yy >= 0 Then
If piece(pn, x, y) Then
If (px + xx >= sw) Or (px + xx < 0) Then
valid = 0
Exit Function
End If
If (py + yy >= sh) Then
valid = 0
Exit Function
End If
If (py >= 0) Then
If board(px + xx, py + yy) Then
valid = 0
Exit Function
End If
End If
End If
End If
Next
Next
valid = -1
End Function
Function place (pn, px, py, rot)
lines = 0
For y = 0 To 1
For x = 0 To 3
rotate xx, yy, x, y, pn, rot
If py + yy >= 0 Then If piece(pn, x, y) Then board(px + xx, py + yy) = pn + 1
Next
Next
'clear lines
For y = py - 1 To py + 2
If y >= 0 And y < sh Then
clr = -1
For x = 0 To sw - 1
If board(x, y) = 0 Then
clr = 0
Exit For
End If
Next
If clr Then
lines = lines + 1
For yy = y To 1 Step -1
For x = 0 To sw - 1
board(x, yy) = board(x, yy - 1)
Next
Next
End If
End If
Next
place = lines
End Function
![[Image: index.php?action=dlattach;topic=637.0;attach=1520]](https://qb64forum.alephc.xyz/index.php?action=dlattach;topic=637.0;attach=1520)
|
|
|
|
| A Game for those with children (or who are children themselves!) by Cobalt |
|
Posted by: SMcNeill - 12-24-2023, 05:25 AM - Forum: Games
- No Replies
|
|
Quote:when in doubt hit ESC.
Otherwise enjoy.
Required Resource files:
Paw's Patrol.7z (Size: 8.52 MB / Downloads: 52)
Code: (Select All)
'Paw Patrol matching\memory game
'8/27/2021
'UniKorn ProDucKions
'inital test release V1b(eta)
'9/2/2021:Release-002
'To Be Finished;
'Game Mode 2-Pup to Badge matching
'High Score addition;
'À-Name Entry and Hi-lite
'Add and exit button to Options Screen and High Scores(just hit ESC for now)
TYPE Card_Data
Id AS _BYTE
X1 AS INTEGER
Y1 AS INTEGER
X2 AS INTEGER
Y2 AS INTEGER
END TYPE
TYPE Game_Data
GameType AS _BYTE 'Mode 1(P+P,B+B) or Mode 2(P+B)
BGMVol AS _BYTE 'Music volume
SFXVol AS _BYTE 'Sound volume
Status AS _BYTE 'MainMenu or GameMode
time AS INTEGER 'number of seconds in game
Match AS INTEGER 'number of matches made in game
Level AS SINGLE '"difficulty" of game 1-12cards, 2-24cards,3-48cards,4-70cards
Quit AS SINGLE 'player quits current game 
END TYPE
TYPE Game_Board
Id AS _BYTE 'what card is here
Flipped AS _BYTE 'is card flipped?(displayed)
Matched AS _BYTE 'is the card still here?
X AS _BYTE
Y AS _BYTE
END TYPE
'------------------------Constants-------------------------
CONST TRUE = -1, FALSE = NOT TRUE
CONST MainMenu = 1, Options = 2, Help = 3, GameMode = 4, HighScores = 5
CONST Mode_1 = 1, Mode_2 = 2
CONST Level_1 = 1, Level_2 = 1.5, Level_3 = 2, Level_4 = 2.5
CONST LoadedMusic = 3
CONST LoadedSounds = 1
'----------------------------------------------------------
'----------------------Tile Data---------------------------
Card_data: '10 tiles
DATA 32,165,190,323: 'sky
DATA 207,341,365,499: 'chase
DATA 31,517,189,675: 'everest
DATA 383,343,541,501: 'marshal
DATA 30,868,188,1026: 'rubble
DATA 32,340,190,498: 'marshal badge
DATA 30,692,188,850: 'chase badge
DATA 206,693,364,851: 'rubble badge
DATA 206,869,364,1027: 'sky badge
DATA 208,166,366,324: 'everest badge
'perhaps more tiles would be nice?
Board_Size:
DATA 2,3,5,6
DATA 3,5,7,9
'----------------------------------------------------------
'---------------------Array and Globals--------------------
DIM SHARED Layer(16) AS LONG, BGM(5) AS LONG, G AS Game_Data, T&, M&
DIM SHARED FFX(6) AS LONG, Cards(16) AS Card_Data, SFX(5) AS LONG
DIM SHARED Board(96) AS Game_Board, BoardX(4) AS _BYTE, BoardY(4) AS _BYTE
'----------------------------------------------------------
'------------------------Timers----------------------------
T& = _FREETIMER
ON TIMER(T&, .5) BackGroundMusic 'control the background music
M& = _FREETIMER
ON TIMER(M&, 1) CountTime 'keeps track of time during gameplay
'----------------------------------------------------------
SCREEN _NEWIMAGE(800, 600, 32): RANDOMIZE TIMER
_SCREENMOVE 10, 10
G.Status = MainMenu
G.BGMVol = 45
G.SFXVol = 45
MFI_Loader "PawsV1b.mfi"
_PUTIMAGE , Splash&, _DISPLAY 'erase `Loading...` as that is done
SetVolumes 'adjust volume levels
_DELAY 5 'leave the pups up for a few seconds.
Fade_Out _DISPLAY
CLS
'--------------------------GFX setup stuff------------------------
_SETALPHA 48, , Layer(4)
_CLEARCOLOR _RGB32(0), Layer(3)
_CLEARCOLOR _RGB32(0), Layer(4)
_CLEARCOLOR _RGB32(0), Layer(11)
_CLEARCOLOR _RGB32(0), Layer(12)
_CLEARCOLOR _RGB32(0), Layer(14)
_PRINTMODE _KEEPBACKGROUND , Layer(1)
_PRINTMODE _KEEPBACKGROUND , Layer(8)
_PRINTMODE _KEEPBACKGROUND , Layer(9)
_DEST Layer(8)
COLOR _RGB32(100, 235, 250) 'menu options color
_DEST Layer(9)
COLOR _RGB32(100, 235, 250) 'High Score color
_DEST Layer(0)
_FONT FFX(0), Layer(8)
_FONT FFX(0), Layer(1)
_FONT FFX(2), Layer(9)
'-----------------------------------------------------------------
'-----------------------------Load Data---------------------------
FOR i%% = 1 TO 10
READ Cards(i%%).X1, Cards(i%%).Y1, Cards(i%%).X2, Cards(i%%).Y2
NEXT i%%
FOR i%% = 1 TO 4
READ BoardY(i%%)
NEXT i%%
FOR i%% = 1 TO 4
READ BoardX(i%%)
NEXT i%%
'-----------------------------------------------------------------
Build_Screens MainMenu
_SOURCE Layer(7) 'click check layer
_DEST Layer(1)
COLOR _RGB32(255, 255, 0) 'mouse over menu options highlight color
_DEST Layer(0)
Create_ClickMap MainMenu
_DEST Layer(1)
Fade_In Layer(8)
G.Level = Level_1
TIMER(M&) ON
DO
Nul = _MOUSEINPUT
_PUTIMAGE , Layer(8), Layer(1) 'prep the menu layer to screen(erases old screen cycle)
IF _MOUSEBUTTON(1) THEN 'lets see where the user clicked
Opt%% = Mouse_Over
ButtonDown%% = TRUE
Clicked%% = TRUE
ELSE
ButtonDown%% = FALSE
END IF
'check over game options with click layer
SELECT CASE Mouse_Over
CASE 1 ' Game mode 1, Portrat+Portrat
_PRINTSTRING (400 - 64, 200), "Game 1", Layer(1)
CASE 2 ' Game Mode 2, Portrat+Badge
_PRINTSTRING (400 - 64, 250), "Game 2", Layer(1)
CASE 3 ' Help
_PRINTSTRING (400 - 56, 300), " Help", Layer(1)
CASE 4 ' High Scores(most matches in a row? Board completion time?)
_PRINTSTRING (400 - 100, 350), "High Scores", Layer(1)
CASE 5 ' Options (Sound levels, High Score Reset)
_PRINTSTRING (400 - 64, 400), "Options", Layer(1)
CASE 6 ' Quit the game(Tis a sad day indeed!)
_PRINTSTRING (400 - 48, 450), " Quit", Layer(1)
END SELECT
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 60
IF Clicked%% AND ButtonDown%% = FALSE THEN 'user clicked something lets see what.
SELECT CASE Opt%%
CASE 1
G.Level = Level_1
G.Status = GameMode
DO
Game_Mode1
LOOP UNTIL G.Level = 3 OR G.Quit
IF G.Level = 3 THEN 'victory screen
Run_Victory
END IF
Create_ClickMap MainMenu
G.Status = MainMenu
CASE 2
CASE 3 'Help screen
Fade_Out Layer(0)
Build_Screens Help
Build_Screens MainMenu
Fade_In Layer(8)
CASE 4 'High Scores list
Fade_Out Layer(0)
Build_Screens HighScores
Build_Screens MainMenu
Fade_In Layer(8)
CASE 5 'Options Menu
Fade_Out Layer(0)
Build_Screens Options 'Build Options
Create_ClickMap Options
Fade_In Layer(8)
Options_Menu
Fade_Out Layer(0)
Build_Screens MainMenu 'rebuild MainMenu
Create_ClickMap MainMenu
Fade_In Layer(8)
CASE 6 'ok, lets quit
QuitFlag%% = TRUE
CASE ELSE 'null click, invalid option
Opt%% = 0
END SELECT
Clicked%% = FALSE
END IF
DO: Nul = _MOUSEINPUT: LOOP WHILE _MOUSEINPUT 'clear the mouse buffer
IF INKEY$ = CHR$(27) THEN QuitFlag%% = TRUE
' BackGroundMusic 'deal with the menus background music || Handled with Timer for now
'debugging information area
' LINE (600, 500)-STEP(160, 99), _RGB32(0), BF
' _PRINTSTRING (600, 500), STR$(LastPlay!), Layer(1)
' _PRINTSTRING (600, 524), STR$(Clicked%%), Layer(1)
' _PRINTSTRING (600, 548), STR$(ButtonDown%%), Layer(1)
' _PRINTSTRING (600, 572), STR$(Opt%%), Layer(1)
LOOP UNTIL QuitFlag%%
'Fade_Out _DISPLAY
'SND_FadeOut
'shut down audio
IF _SNDPLAYING(SFX(1)) THEN _SNDSTOP (SFX(1))
IF _SNDPLAYING(SFX(2)) THEN _SNDSTOP (SFX(2))
IF _SNDPLAYING(SFX(3)) THEN _SNDSTOP (SFX(3))
TIMER(M&) OFF
_FONT 16
COLOR _RGB32(255)
'C%% = (800 - (740 - 14)) \ 2
'_PUTIMAGE (C%%, 0), Layer(2), _DISPLAY, (14, 11)-(740, 149) 'Game Menu Title
SUB Create_ClickMap (Opt%%)
_DEST Layer(7)
CLS
SELECT CASE Opt%%
CASE MainMenu
LINE (328, 196)-STEP(127, 31), _RGB32(255, 255, 1), BF
LINE (328, 246)-STEP(127, 31), _RGB32(255, 255, 2), BF
LINE (336, 300)-STEP(111, 31), _RGB32(255, 255, 3), BF
LINE (292, 350)-STEP(199, 31), _RGB32(255, 255, 4), BF
LINE (328, 400)-STEP(127, 31), _RGB32(255, 255, 5), BF
LINE (350, 446)-STEP(95, 31), _RGB32(255, 255, 6), BF
CASE Options
LINE (255, 240)-STEP(16 * 16, 32), _RGB32(255, 255, 1), BF
LINE (255, 290)-STEP(16 * 16, 32), _RGB32(255, 255, 2), BF
LINE (252, 350)-STEP(287, 31), _RGB32(255, 255, 3), BF
LINE (348, 446)-STEP(87, 31), _RGB32(255, 255, 4), BF
CASE Help
CASE GameMode
'the actual game mode is unimportant, just the number of cards to layout.
Offset% = 175 / G.Level
Scaled% = 157 / G.Level
FOR y%% = 0 TO BoardY(G.Level * 2 - 1)
FOR x%% = 0 TO BoardX(G.Level * 2 - 1)
C%% = C%% + 1
LINE (50 + x%% * Offset%, 75 + y%% * Offset%)-STEP(Scaled%, Scaled%), _RGB32(64, 64, C%%), BF
NEXT x%%, y%%
END SELECT
_DEST Layer(7)
END SUB
FUNCTION Mouse_Over~%% ()
Result~%% = 0 'just in case?
Result~%% = _BLUE32(POINT(_MOUSEX, _MOUSEY)) 'get our blue value for option under mouse
Mouse_Over = Result~%%
END FUNCTION
SUB Build_Screens (Opt%%)
ClearLayer Layer(8)
SELECT CASE Opt%%
CASE MainMenu
Cx% = (800 - 464) \ 2 'Center the image on screen
Cy% = (600 - 396) \ 2
_PUTIMAGE (Cx%, Cy%), Layer(4), Layer(8) 'Title Screen Logo background
_PUTIMAGE (0, 64), Layer(3), Layer(8)
_PRINTSTRING (400 - 64, 200), "Game 1", Layer(8)
_PRINTSTRING (400 - 64, 250), "Game 2", Layer(8)
_PRINTSTRING (400 - 56, 300), " Help", Layer(8)
_PRINTSTRING (400 - 100, 350), "High Scores", Layer(8)
_PRINTSTRING (400 - 64, 400), "Options", Layer(8)
_PRINTSTRING (400 - 48, 450), " Quit", Layer(8)
CASE Options
_SETALPHA 96, , Layer(3) 'fade the image
_CLEARCOLOR _RGB32(0), Layer(3) 'restore clear color
Cx% = (800 - 464) \ 2 'Center the image on screen
Cy% = (600 - 396) \ 2
_PUTIMAGE (Cx%, Cy%), Layer(4), Layer(8) 'Title Screen Logo background
_PUTIMAGE (0, 64), Layer(3), Layer(8)
_SETALPHA 255, , Layer(3) 'restore opacity
_CLEARCOLOR _RGB32(0), Layer(3) 'restore clear color
_PRINTSTRING (400 - 120, 200), "Volume Level", Layer(8)
_PRINTSTRING (100, 250), "Music ", Layer(8)
_PRINTSTRING (100, 300), "Sounds", Layer(8)
_PRINTSTRING (400 - 144, 350), "Reset High Scores", Layer(8)
_PRINTSTRING (400 - 40, 450), "Exit", Layer(8)
CASE Help
ClearLayer Layer(9)
_PUTIMAGE , Layer(4), Layer(9)
_PRINTSTRING (16, 32), "In game mode one(1) the goal is to match", Layer(9)
_PRINTSTRING (16, 64), "Pup to Pup and Badge to Badge. Beat all 4", Layer(9)
_PRINTSTRING (16, 96), "levels quickly for high scores!", Layer(9)
_PRINTSTRING (16, 144), "In game mode two(2) the goal is to match", Layer(9)
_PRINTSTRING (16, 176), "Pup to badge. Make as many matches as", Layer(9)
_PRINTSTRING (16, 208), "possible in 120 seconds for high scores!", Layer(9)
_PRINTSTRING (16, 256), "Make matches by clicking on the back of", Layer(9)
_PRINTSTRING (16, 288), "the cards to reveal a pup or badge image.", Layer(9)
_PRINTSTRING (16, 320), "Depending on game mode they matched by", Layer(9)
_PRINTSTRING (16, 352), "Pup to Pup\Badge to Badge, or", Layer(9)
_PRINTSTRING (16, 384), "in game mode 2 Pup to Badge.", Layer(9)
_KEYCLEAR
Fade_In Layer(9)
DO
_PUTIMAGE , Layer(9), Layer(0)
_LIMIT 30
LOOP UNTIL INKEY$ <> ""
Fade_Out Layer(0)
_KEYCLEAR
CASE HighScores
ClearLayer Layer(9)
_PUTIMAGE , Layer(4), Layer(9)
_PUTIMAGE (100, 0), Layer(11), Layer(9)
_PRINTSTRING (168, 160), "Names", Layer(9)
_PRINTSTRING (520, 160), "Times", Layer(9)
_PRINTSTRING (168, 365), "Names", Layer(9)
_PRINTSTRING (520, 365), "Matches", Layer(9)
IF _FILEEXISTS("Paws.HSL") THEN
N$ = SPACE$(26)
T$ = SPACE$(5)
OPEN "Paws.HSL" FOR BINARY AS #1
'Game time high scores (time to finish matches)
GET #1, , Count%%
FOR i%% = 1 TO Count%%
GET #1, , N$
GET #1, , T$
_PRINTSTRING (168, 192 + 24 * i%%), N$, Layer(9)
_PRINTSTRING (520, 192 + 24 * i%%), T$, Layer(9)
NEXT i%%
'Matches under timer (matches made in 120 sec
GET #1, , Count%%
FOR i%% = 1 TO Count%%
GET #1, , N$
GET #1, , T$
_PRINTSTRING (168, 397 + 24 * i%%), N$, Layer(9)
_PRINTSTRING (520, 397 + 24 * i%%), T$, Layer(9)
NEXT i%%
ELSE
_PRINTSTRING (168, 192 + 24 * i%%), "No game yet", Layer(9)
_PRINTSTRING (168, 397 + 24 * i%%), "No game yet", Layer(9)
END IF
CLOSE #1
_KEYCLEAR
Fade_In Layer(9)
DO
_PUTIMAGE , Layer(9), Layer(0)
_LIMIT 30
LOOP UNTIL INKEY$ <> ""
Fade_Out Layer(0)
_KEYCLEAR
CASE GameMode
END SELECT
END SUB
SUB Options_Menu
DO
Nul = _MOUSEINPUT
_PUTIMAGE , Layer(8), Layer(1) 'prep the menu layer to screen(erases old screen cycle)
_DEST Layer(1)
BGMV = G.BGMVol / 100: SFXV = G.SFXVol / 100
LINE (255, 240)-STEP(16 * 16, 32), _RGB32(0 + INT(255 * BGMV), 255 - INT(255 * BGMV), 0), BF
LINE (255, 290)-STEP(16 * 16, 32), _RGB32(0 + INT(255 * SFXV), 255 - INT(255 * SFXV), 0), BF
LINE (255 + (256 * BGMV), 236)-STEP(1, 40), _RGB32(224, 224, 224), B
LINE (255 + (256 * SFXV), 286)-STEP(1, 40), _RGB32(224, 224, 224), B
_DEST Layer(0)
IF _MOUSEBUTTON(1) THEN 'lets see where the user clicked
Opt%% = Mouse_Over
ButtonDown%% = TRUE
Clicked%% = TRUE
ELSE
ButtonDown%% = FALSE
END IF
'check over game options with click layer
SELECT CASE Mouse_Over
CASE 1 'Music Vol controller
_PRINTSTRING (100, 250), "Music ", Layer(1)
CASE 2 ' Sounds Vol Controller
_PRINTSTRING (100, 300), "Sounds", Layer(1)
CASE 3 ' Reset High Scores List
_PRINTSTRING (400 - 144, 350), "Reset High Scores", Layer(1)
CASE 4 ' Exit Options
_PRINTSTRING (400 - 40, 450), "Exit", Layer(1)
END SELECT
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 60
IF (Clicked%% AND ButtonDown%% = FALSE) AND Opt%% > 2 THEN 'user clicked something lets see what.
SELECT CASE Opt%%
CASE 3 'Reset High Scores
IF _FILEEXISTS("Paws.HSL") THEN KILL "Paws.HSL" 'erase the highscore file
CASE 4 'Exit
ExitFlag%% = TRUE
CASE ELSE 'null click, invalid option
Opt%% = 0
END SELECT
Clicked%% = FALSE
ELSEIF ButtonDown%% THEN 'the volume controls are button down and slide
SELECT CASE Opt%%
CASE 1 'music
G.BGMVol = INT((_MOUSEX - 255) / 256 * 100)
CASE 2 'sounds
G.SFXVol = INT((_MOUSEX - 255) / 256 * 100)
END SELECT
ELSEIF Clicked%% THEN 'once released change volume levels
Clicked%% = FALSE
SetVolumes
END IF
DO: Nul = _MOUSEINPUT: LOOP WHILE _MOUSEINPUT 'clear the mouse buffer
IF INKEY$ = CHR$(27) THEN ExitFlag%% = TRUE
' BackGroundMusic 'deal with the menus background music || Handled with Timer for now
LOOP UNTIL ExitFlag%%
END SUB
SUB BackGroundMusic
STATIC LastPlay&
IF LastPlay& = 0 THEN _SNDPLAY BGM(1) 'game just started
IF _SNDPLAYING(BGM(1)) THEN
'main theme is still playing so nothing to do!
LastPlay& = TIMER '86399
IF LastPlay& > 86350 THEN LastPlay& = 0 'make the midnight jump (what are little kids doing up?)
'-----------------------------Looping Music Section----------------------------------------
ELSEIF G.Status = MainMenu THEN 'user is in the menus
'================================Menu Music Area===========================================
IF _SNDPLAYING(BGM(2)) THEN 'the instramental is playing
LastPlay& = TIMER '86399
IF LastPlay& > 86350 THEN LastPlay& = 0 'make the midnight jump (what are little kids doing up?)
ELSE
IF TIMER > LastPlay& + 20 AND TIMER < 86350 THEN _SNDPLAY BGM(2)
END IF
'==========================================================================================
ELSEIF G.Status = GameMode THEN 'player is in game
'================================Game Music Area===========================================
IF _SNDPLAYING(BGM(3)) THEN 'the instramental is playing
LastPlay& = TIMER '86399
IF LastPlay& > 86250 THEN LastPlay& = 0 'make the midnight jump (what are little kids doing up?)
ELSE
IF TIMER > LastPlay& + 10 AND TIMER < 86250 THEN _SNDPLAY BGM(3)
END IF
'==========================================================================================
END IF
'-------------------------------------------------------------------------------------------
END SUB
SUB SetVolumes
FOR i%% = 1 TO LoadedMusic
_SNDVOL BGM(i%%), G.BGMVol / 100
NEXT i%%
FOR i%% = 1 TO LoadedSounds 'start at 1 so if 0 sounds loaded nothing is affected
_SNDVOL SFX(i%%), G.SFXVol / 100
NEXT i%%
END SUB
SUB Display_Card (X%, Y%, id%%, Scale!)
'Scale options 1,1.5,2,2.5(Full,1\2,1\4,1\8[these values for refernce only, not correct])
'full-12 cards, 1.5- 24 cards, 2-48 cards, 2.5- 96 cards!
IF id%% THEN
_PUTIMAGE (X%, Y%)-STEP(157 / Scale!, 157 / Scale!), Layer(2), Layer(1), (Cards(id%%).X1, Cards(id%%).Y1)-(Cards(id%%).X2, Cards(id%%).Y2)
ELSE 'card 0 is back side
_PUTIMAGE (X%, Y%)-STEP(157 / Scale!, 157 / Scale!), Layer(2), Layer(1), (384, 166)-STEP(159, 159)
END IF
END SUB
SUB Game_Mode1
DIM card(1) AS _BYTE 'what 2 cards are flipped
CardsLeft%% = (BoardX(G.Level * 2 - 1) + 1) * (BoardY(G.Level * 2 - 1) + 1) 'how many cards to match
Create_ClickMap GameMode 'set the click space
Setup_Cards G.Level 'ready the cards for matching
_DEST Layer(12)
DO
nul% = _MOUSEINPUT
IF _MOUSEBUTTON(1) THEN 'lets see where the user clicked
Opt%% = Mouse_Over
ButtonDown%% = TRUE
Clicked%% = TRUE
ELSE
ButtonDown%% = FALSE
END IF
IF NOT ButtonDown%% AND Clicked%% THEN
IF Opt%% THEN 'dont allow 0 click area(black area)
IF Board(Opt%%).Flipped = FALSE THEN
Board(Opt%%).Flipped = TRUE
Clicked%% = FALSE
card(flipped%%) = Opt%% 'watch which cards are flipped
flipped%% = flipped%% + 1
END IF
END IF
END IF
tmp%% = Mouse_Over
'-------------------------screen update-----------------------
ClearLayer Layer(1)
_PRINTSTRING (5, 5), "Time :", Layer(1)
_PRINTSTRING (5, 34), "Matches:", Layer(1)
Display_Game_Board_II
Display_Time_Elapsed
Display_Matches_Made
_PUTIMAGE , Layer(1), Layer(0)
_PUTIMAGE , Layer(12), Layer(0)
'-------------------------------------------------------------
IF flipped%% = 2 THEN
flipped%% = 0 'reset our flipped card count
IF Board(card(0)).Id = Board(card(1)).Id THEN ' we have a match! 
Board(card(0)).Matched = TRUE
Board(card(1)).Matched = TRUE
CardsLeft%% = CardsLeft%% - 2
G.Match = G.Match + 1
Card_Match_Animation card()
ELSE 'no match
Board(card(0)).Flipped = FALSE
Board(card(1)).Flipped = FALSE
_DELAY .5
END IF
END IF
_LIMIT 60
DO: Nul = _MOUSEINPUT: LOOP WHILE _MOUSEINPUT 'clear the mouse buffer
IF INKEY$ = CHR$(27) THEN ExitFlag%% = TRUE: G.Quit = TRUE
IF CardsLeft%% = 0 THEN 'player wins this level!
G.Level = G.Level + .5
ExitFlag%% = TRUE
END IF
LOOP UNTIL ExitFlag%%
END SUB
SUB Setup_Cards (opt%%)
FOR i%% = 0 TO 96 'erase card data
Board(i%%).Id = 0
Board(i%%).Flipped = FALSE
Board(i%%).Matched = FALSE
NEXT i%%
SELECT CASE G.Level
CASE Level_1 '12 cards
'not enough cards so just load the first 6 cards to match(pups and 1 badge{marshal's})
FOR i%% = 1 TO 12 STEP 2
J%% = J%% + 1
Board(i%%).Id = J%%
Board(i%% + 1).Id = Board(i%%).Id
NEXT i%%
cc%% = 12 'Card Count for the scramble
CASE Level_2 '24 cards
'add the 10 base cards then repeat 2
FOR i%% = 1 TO 24 STEP 2
J%% = J%% + 1
Board(i%%).Id = J%%
Board(i%% + 1).Id = Board(i%%).Id
IF J%% = 10 THEN J%% = 0 'start over
NEXT i%%
cc%% = 24 'Card Count for the scramble
CASE Level_3 '48 cards
'add the 10 base cards then repeat 2
FOR i%% = 1 TO 48 STEP 2
J%% = J%% + 1
Board(i%%).Id = J%%
Board(i%% + 1).Id = Board(i%%).Id
IF J%% = 10 THEN J%% = 0 'start over
NEXT i%%
cc%% = 48 'Card Count for the scramble
CASE Level_4 '70 cards
'add the 10 base cards then repeat 2
FOR i%% = 1 TO 70 STEP 2
J%% = J%% + 1
Board(i%%).Id = J%%
Board(i%% + 1).Id = Board(i%%).Id
IF J%% = 10 THEN J%% = 0 'start over
NEXT i%%
cc%% = 70 'Card Count for the scramble
END SELECT
'scramble cards
FOR i% = 0 TO 200
SWAP Board(INT(RND * cc%%) + 1), Board(INT(RND * cc%%) + 1)
NEXT i%
END SUB
SUB Display_Game_Board (opt%%)
SELECT CASE opt%%
CASE Level_1 ' 12 full sized cards
FOR y%% = 0 TO 2
FOR x%% = 0 TO 3
C%% = C%% + 1
Board(C%%).X = x%%: Board(C%%).Y = y%%
IF NOT Board(C%%).Matched THEN
IF Board(C%%).Flipped THEN
Display_Card 50 + x%% * 175, 75 + y%% * 175, Board(C%%).Id, 1
ELSE
Display_Card 50 + x%% * 175, 75 + y%% * 175, 0, 1
END IF
END IF
NEXT x%%, y%%
CASE Level_2 '24 half sized cards
FOR y%% = 0 TO 3
FOR x%% = 0 TO 5
C%% = C%% + 1
IF NOT Board(C%%).Matched THEN
IF Board(C%%).Flipped THEN
Display_Card 50 + x%% * 115, 75 + y%% * 115, Board(C%%).Id, 1.5
ELSE
Display_Card 50 + x%% * 115, 75 + y%% * 115, 0, 1.5
END IF
END IF
NEXT x%%, y%%
CASE Level_3
FOR y%% = 0 TO 4
FOR x%% = 0 TO 7
C%% = C%% + 1
IF NOT Board(C%%).Matched THEN
IF Board(C%%).Flipped THEN
Display_Card 50 + x%% * 88, 75 + y%% * 88, Board(C%%).Id, 2
ELSE
Display_Card 50 + x%% * 88, 75 + y%% * 88, 0, 2
END IF
END IF
NEXT x%%, y%%
CASE Level_4
FOR y%% = 0 TO 6
FOR x%% = 0 TO 9
C%% = C%% + 1
IF NOT Board(C%%).Matched THEN
IF Board(C%%).Flipped THEN
Display_Card 50 + x%% * 64, 75 + y%% * 64, Board(C%%).Id, 2
ELSE
Display_Card 50 + x%% * 64, 75 + y%% * 64, 0, 2
END IF
END IF
NEXT x%%, y%%
END SELECT
END SUB
SUB Display_Game_Board_II
Offset% = 175 / G.Level 'card spacing
FOR y%% = 0 TO BoardY(G.Level * 2 - 1)
FOR x%% = 0 TO BoardX(G.Level * 2 - 1)
C%% = C%% + 1
Board(C%%).X = x%%: Board(C%%).Y = y%%
IF NOT Board(C%%).Matched THEN 'if the card is matched do not display
IF Board(C%%).Flipped THEN 'if player has flipped card then display image
Display_Card 50 + x%% * Offset%, 75 + y%% * Offset%, Board(C%%).Id, G.Level
ELSE 'otherwise display back of card
Display_Card 50 + x%% * Offset%, 75 + y%% * Offset%, 0, G.Level
END IF
END IF
NEXT x%%, y%%
END SUB
SUB CountTime
IF G.Status = GameMode THEN 'count time while playing
G.time = G.time + 1
ELSE 'when in menu reset game time
G.time = 0
END IF
END SUB
SUB Display_Time_Elapsed
min$ = LTRIM$(STR$(G.time \ 60))
sec$ = LTRIM$(STR$(G.time MOD 60))
IF LEN(sec$) = 1 THEN sec$ = "0" + sec$
IF G.time \ 60 THEN T$ = min$ + ":" + sec$ ELSE T$ = sec$
_PRINTSTRING (160, 8), T$, Layer(1)
END SUB
SUB Display_Matches_Made
_PRINTSTRING (160, 32), LTRIM$(STR$(G.Match)), Layer(1)
END SUB
SUB Run_Victory
SND_FadeOut
MFI_Loader_victory "Victory.ANI"
END SUB
SUB Card_Match_Animation (c() AS _BYTE)
TIMER(M&) OFF
_DEST Layer(0)
Offset% = 175 / G.Level 'card spacing
'blank out cards
LINE (50 + Board(c(0)).X * Offset%, 75 + Board(c(0)).Y * Offset%)-STEP(157 / G.Level, 157 / G.Level), _RGB32(0), BF
LINE (50 + Board(c(1)).X * Offset%, 75 + Board(c(1)).Y * Offset%)-STEP(157 / G.Level, 157 / G.Level), _RGB32(0), BF
'make a tme copy of the desktop
tmp& = _COPYIMAGE(_DISPLAY)
'----------------------card start points----------------------------
StartX! = 50 + Board(c(0)).X * Offset%
StartY! = 75 + Board(c(0)).Y * Offset%
Start2X! = 50 + Board(c(1)).X * Offset%
Start2Y! = 75 + Board(c(1)).Y * Offset%
'-------------------------------------------------------------------
'----------------------distance to center---------------------------
IF StartX! < 320 THEN Card1X_dist% = 320 - StartX! ELSE Card1X_dist% = -(StartX! - 320)
IF StartY! < 220 THEN Card1Y_dist% = 220 - StartY! ELSE Card1Y_dist% = -(StartY! - 220)
IF Start2X! < 320 THEN Card2X_dist% = 320 - Start2X! ELSE Card2X_dist% = -(Start2X! - 320)
IF Start2Y! < 220 THEN Card2Y_dist% = 220 - Start2Y! ELSE Card2Y_dist% = -(Start2Y! - 220)
'-------------------------------------------------------------------
'------------travel per frame for 60 moves----------------
x1! = Card1X_dist% / 60
y1! = Card1Y_dist% / 60
x2! = Card2X_dist% / 60
y2! = Card2Y_dist% / 60
'---------------------------------------------------------
DO
StartX! = StartX! + x1!
StartY! = StartY! + y1!
Start2X! = Start2X! + x2!
Start2Y! = Start2Y! + y2!
_PUTIMAGE , tmp&, Layer(1)
Display_Card StartX!, StartY!, Board(c(0)).Id, G.Level
Display_Card Start2X!, Start2Y!, Board(c(1)).Id, G.Level
_PUTIMAGE , Layer(1), Layer(0)
IF INKEY$ = CHR$(27) THEN Exitflag%% = TRUE
_LIMIT 48
count% = count% + 1
IF count% = 61 THEN Exitflag%% = TRUE
LOOP UNTIL Exitflag%%
Startx% = INT(StartX!)
Starty% = INT(StartX!) - 48
FOR i! = 1 TO .25 STEP -.05
_PUTIMAGE , tmp&, Layer(1)
c% = c% + 15
Display_Card 5 + Startx% - c%, Starty% - c%, Board(c(0)).Id, i!
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 30
NEXT i!
_DELAY .75
FOR i! = .25 TO 3.5 STEP .1
_PUTIMAGE , tmp&, Layer(1)
c% = c% - 20
Display_Card Startx% - c%, Starty% - c%, Board(c(0)).Id, i!
_PUTIMAGE (Startx% - c% - 33, Starty% - c% - 33)-STEP(190 / (i! - .05), 183 / (i! - .05)), Layer(14), Layer(1), (0 + 191 * f%%, 0)-STEP(190, 183)
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 17
f%% = f%% + 1
IF f%% = 30 THEN f%% = 0
NEXT i!
TIMER(M&) ON
END SUB
'$include:'PPMG_GFXRoutines.bas'
SUB MFI_Loader_victory (FN$)
DIM Size(128) AS LONG, FOffset(128) AS LONG
OPEN FN$ FOR BINARY AS #1
GET #1, , c~%% 'retrieve number of files
FOR I~%% = 1 TO c~%%
GET #1, , FOffset(I~%%)
GET #1, , Size(I~%%)
FOffset&(I~%%) = FOffset&(I~%%) + 1
NEXT I~%%
ClearLayer Layer(1)
ClearLayer Layer(0)
_SNDPLAY SFX(1)
DO
fr%% = fr%% + 1
tmp& = LoadGFX(FOffset(fr%%), Size(fr%%))
_PUTIMAGE (100, 192), tmp&, Layer(1)
_PUTIMAGE (135, 16), Layer(13), Layer(1)
_PUTIMAGE , Layer(1), Layer(0)
_LIMIT 16
IF fr%% = 95 THEN Exitflag%% = TRUE
_FREEIMAGE tmp&
LOOP UNTIL Exitflag%%
tmp& = LoadGFX(FOffset(92), Size(92))
_PUTIMAGE (100, 192), tmp&, Layer(1)
_PUTIMAGE (135, 16), Layer(13), Layer(1)
_PUTIMAGE , Layer(1), Layer(0)
_FREEIMAGE tmp&
_DELAY 4
CLOSE #1
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
END SUB
FUNCTION LoadGFX& (Foff&, Size&)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadGFX& = _LOADIMAGE("temp.dat", 32)
END FUNCTION
FUNCTION LoadFFX& (Foff&, Size&, Fize%%, Att$)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadFFX& = _LOADFONT("temp.dat", Fize%%, Att$)
END FUNCTION
FUNCTION LoadSFX& (Foff&, Size&)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
LoadSFX& = _SNDOPEN("temp.dat")
END FUNCTION
SUB LoadData (Foff&, Size&)
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
OPEN "temp.dat" FOR BINARY AS #3
dat$ = SPACE$(Size&)
GET #1, Foff&, dat$
PUT #3, , dat$
CLOSE #3
END SUB
SUB MFI_Loader (FN$)
DIM Size(128) AS LONG, FOffset(128) AS LONG
OPEN FN$ FOR BINARY AS #1
GET #1, , c~%% 'retrieve number of files
FOR I~%% = 1 TO c~%%
GET #1, , FOffset(I~%%)
GET #1, , Size(I~%%)
FOffset&(I~%%) = FOffset&(I~%%) + 1
NEXT I~%%
'-----------------------Splash Screen setup-------------------------
_PRINTSTRING (0, 574), "Loading...", _DISPLAY
Splash& = LoadGFX(FOffset(9), Size(9)) 'Splash screen
BGM(1) = LoadSFX(FOffset(1), Size(1))
TIMER(T&) ON 'start the background musics
SetVolumes 'adjust volume levels
DO: _LIMIT 60: LOOP UNTIL _SNDGETPOS(BGM(1)) > 1
Fade_In Splash&
_PUTIMAGE , Splash&, _DISPLAY 'show the splash screen while loading
_PRINTSTRING (0, 574), "Loading..."
'-------------------------------------------------------------------
Layer(0) = _DISPLAY
Layer(1) = _COPYIMAGE(_DISPLAY) 'Mix layer
Layer(7) = _NEWIMAGE(800, 600, 32) 'click map layer
Layer(8) = _NEWIMAGE(800, 600, 32) 'Main Menu\Options Layer
Layer(9) = _NEWIMAGE(800, 600, 32) 'High Score\Help layer
Layer(10) = _NEWIMAGE(800, 600, 32) 'Mouse Over hi-lite layer
Layer(12) = _NEWIMAGE(800, 600, 32) 'debug info
Layer(2) = LoadGFX(FOffset(2), Size(2)) 'Tiles
Layer(3) = LoadGFX(FOffset(3), Size(3)) 'Title
Layer(4) = LoadGFX(FOffset(4), Size(4)) 'BackGround
Layer(5) = LoadGFX(FOffset(5), Size(5)) 'Pups
Layer(6) = LoadGFX(FOffset(6), Size(6)) 'bitmap font
Layer(11) = LoadGFX(FOffset(7), Size(7)) 'high score title
Layer(13) = LoadGFX(FOffset(8), Size(8)) 'Victory screen title
Layer(14) = LoadGFX(FOffset(14), Size(14)) 'Match sparkle animation
BGM(2) = LoadSFX(FOffset(10), Size(10)) 'instramental theme
BGM(3) = LoadSFX(FOffset(11), Size(11)) 'extended instramental
SFX(1) = LoadSFX(FOffset(12), Size(12)) 'victory cheer
FFX(0) = LoadFFX(FOffset(13), Size(13), 36, "BOLD") 'main font
FFX(1) = LoadFFX(FOffset(13), Size(13), 24, "") 'high score font
FFX(2) = LoadFFX(FOffset(13), Size(13), 24, "MONOSPACE") 'help font
CLOSE #1
IF _FILEEXISTS("temp.dat") THEN KILL "temp.dat"
END SUB
|
|
|
|
| Redo Board Game |
|
Posted by: SMcNeill - 12-24-2023, 05:17 AM - Forum: Donald Foster
- No Replies
|
|
Quote:Hello All,
Thanks to the new features of v1.2, I was able to write this game in just 2 days. My biggest problem has been careless mistakes, misspelled variable names that can take days, weeks or months to find.
Redo is a 2 player board game played on a 7x8 board with 28 double sided pieces. Each player has 14 pieces lined up in the last 2 columns on their side of the board. Player 1 plays the white side pieces and player 2 plays the red. Piece are similar to those in Othello with the same goal, to have the most pieces flipped to their color at the end of the game. The game is tracked by points. The game ends in 1 of 2 ways, if neither player can make any move or if both players skip their turn consecutively.
player's pieces move forward direction only, straight, diagonally forward right or diagonally forward left. The can not move sideways or backwards. A single piece counts as 1 point. A single piece can move 1 space in it's allowed direction and land on 1 of it's own single pieces, then a tower is formed of the 2 pieces together. The tower is identified by having double sets of rings in it. However, the tower only counts for 1 point and now you have less pieces on the board your color. But, you can use the tower to jump over an opponent's piece, moving in it's allowed direction, and landing in an empty space just beyond the jumped piece. The jumped piece is flipped to your color.
After a piece is moved, some of the pieces surrounding it is flipped to your color. The piece that flip is in front you, straight, diagonally forward left and diagonally forward right and both sides. And, of course if you jump over a piece, that pieces is also flipped, even if it's behind you.
If on your turn, the only move you can make is forming a tower, than you can skip your turn. But only if it is the only move you can make. There is a Pass Move but that is grey during normal game play. If making towers is the only moves left, then the button should change to white and you are allowed to pass your turn by pressing the button and the play goes to the next player. If by chance that player on its next turn also presses the pass Move button, the game will end.
At the end of the game, if both players have the same score, the game ends in a tie, else the winner is the player with the highest score.
Hope you enjoy playing.
Donald
Redo Board Game Rules.docx (Size: 341.47 KB / Downloads: 31)
Code: (Select All)
Option _Explicit
_Title "Redo - Programmed by Donald L. Foster Jr. 2018"
Screen _NewImage(1084, 734, 256)
_PaletteColor 1, _RGB32(99, 29, 0) 'Board Color
_PaletteColor 2, _RGB32(255, 255, 255) ' Player 1 Piece Color
_PaletteColor 3, _RGB32(220, 0, 0) ' Player 2 Piece Color
_PaletteColor 4, _RGB32(222, 222, 0) ' Yellow Color
_PaletteColor 5, _RGB32(0, 227, 0) ' Cursor Color
_PaletteColor 6, _RGB32(80, 80, 80) ' Pass Move Grey Color
_Limit 10
Dim A As String
Dim U As Integer
Dim V As Integer
Dim W As Integer
Dim X As Integer
Dim Y As _Unsigned _Byte
Dim Z As _Unsigned _Byte
Dim X1 As _Unsigned Integer
Dim X2 As _Unsigned Integer
Dim X3 As _Unsigned Integer
Dim X4 As _Unsigned Integer
Dim Player As _Unsigned _Byte
Dim Opponent As _Unsigned _Byte
Dim Winner As _Unsigned _Byte
Dim NoMoves As _Unsigned _Byte
Dim PassMove As _Unsigned _Byte
Dim Passed As _Unsigned _Byte
Dim BoardX1 As _Unsigned Integer
Dim BoardY1 As _Unsigned Integer
Dim BoardX2 As _Unsigned Integer
Dim BoardY2 As _Unsigned Integer
Dim Piece As _Unsigned _Byte
Dim Row1 As _Unsigned _Byte
Dim Column1 As _Unsigned _Byte
Dim Row2 As _Unsigned _Byte
Dim Column2 As _Unsigned _Byte
Dim PlayerColor(2) As Integer
Dim Score(2) As _Unsigned _Byte
Dim BoardX(7, 8) As _Unsigned Integer
Dim BoardY(7, 8) As _Unsigned Integer
Dim BoardPlayer(7, 8) As _Unsigned _Byte
Dim BoardPiece(7, 8) As _Unsigned _Byte
Dim Playable(9, 10) As _Unsigned _Byte
Dim Cursor As String
Dim Cursor1 As String
Player = 1: Opponent = 2: NoMoves = 0: PassMove = 0: Passed = 0
PlayerColor(1) = 15: PlayerColor(2) = 3: Score(1) = 14: Score(2) = 14
Cursor$ = "BU46BL46C5D92R92U92L92BF3D86R86U86L86BH1P5,5"
Cursor1$ = "BU46BL46C1D92R92U92L92BF3D86R86U86L86BH1P1,1"
' Draw Board
Line (10, 10)-(820, 724), 1, BF: Line (30, 30)-(800, 704), 15, BF
X = 79
For Z = 1 To 7
W = 79
For Y = 1 To 8
Line (W - 46, X - 46)-(W + 46, X + 46), 1, BF
If Y < 3 Then BoardPlayer(Z, Y) = 1: BoardPiece(Z, Y) = 1: Circle (W, X), 40, 15: Paint (W, X), 15
If Y > 6 Then BoardPlayer(Z, Y) = 2: BoardPiece(Z, Y) = 1: Circle (W, X), 40, 3: Paint (W, X), 3
BoardX(Z, Y) = W: BoardY(Z, Y) = X
W = W + 96
Next
X = X + 96
Next
Locate 2, 112: Print "R E D O";
Locate 16, 112: Print "S C O R E S";
Locate 17, 110: Print "--------------------";
Locate 19, 114: Print "Player 1:";
Locate 21, 114: Print "Player 2:";
StartGame:
' Draw Player Indicator
Circle (949, 100), 40, PlayerColor(Player): Paint (949, 100), PlayerColor(Player)
Color 15, 0: Locate 11, 115: Print "Player:"; Player;
' Draw Scores
Color 4, 0: Locate 19, 123: Print Score(1);
Color 4, 0: Locate 21, 123: Print Score(2);
' Check Playable Moves
For Z = 1 To 7
For Y = 1 To 8
If BoardPlayer(Z, Y) = Player Then Piece = BoardPiece(Z, Y): GoSub CheckPlayableMoves
Next
Next
' Check if No Moves
If X = 0 Then
Color 4, 0: Locate 45, 107: Print " No Moves to Play";: Color 15, 0: Print " <ENTER> ";
PressENTER: A$ = InKey$: If A$ = "" GoTo PressENTER Else If Asc(A$) <> 13 GoTo PressENTER
NoMoves = NoMoves + 1: If NoMoves = 2 GoTo Winner Else GoTo EndTurn
End If
' Check if Tower Move is The Only Move, Allow Pass Move
If V = 0 And X = 1 Then PassMove = 1 Else PassMove = 0
' Draw Pass Move Button
If PassMove = 1 Then W = 15 Else W = 6
Color W, 0: Locate 38, 111: Print "P A S S M O V E";
Line (850, 570)-(1054, 630), W, B
Color 4, 0: Locate 45, 107: Print " Choose A Piece To Move ";
ChooseAPieceInput:
Do While _MouseInput
If _MouseButton(1) = -1 And _MouseX > 850 And _MouseX < 1054 And _MouseY > 570 And _MouseY < 630 And PassMove = 1 Then
Passed = Passed + 1: GoSub ReleaseMouseButton: GoTo EndTurn
End If
For Z = 1 To 7
For Y = 1 To 8
If _MouseButton(1) = -1 And _MouseX > BoardX(Z, Y) - 47 And _MouseX < BoardX(Z, Y) + 47 And _MouseY > BoardY(Z, Y) - 47 And _MouseY < BoardY(Z, Y) + 47 Then
If BoardPlayer(Z, Y) = Player Then Row1 = Z: Column1 = Y: GoSub ReleaseMouseButton: GoTo EndChoice1
End If
Next
Next
Loop
GoTo ChooseAPieceInput
EndChoice1:
NoMoves = 0: Passed = 0: Piece = BoardPiece(Row1, Column1): BoardX1 = BoardX(Row1, Column1): BoardY1 = BoardY(Row1, Column1)
' Set Playable Moves to 0
For Z = 1 To 7: For Y = 1 To 8: Playable(Z, Y) = 0: Next: Next
' Check Playable Moves
Playable(Row1, Column1) = 1: Z = Row1: Y = Column1: GoSub CheckPlayableMoves: If X = 0 GoTo ChooseAPieceInput
' Draw Cursor
PSet (BoardX1, BoardY1), PlayerColor(Player): Draw Cursor
Color 4, 0: Locate 45, 107: Print "Choose Location To Move To";
ChooseALocationInput:
Do While _MouseInput
For Z = 1 To 7
For Y = 1 To 8
If _MouseButton(1) = -1 And _MouseX > BoardX(Z, Y) - 44 And _MouseX < BoardX(Z, Y) + 44 And _MouseY > BoardY(Z, Y) - 44 And _MouseY < BoardY(Z, Y) + 44 Then
If Playable(Z, Y) > 0 Then Row2 = Z: Column2 = Y: GoSub ReleaseMouseButton: GoTo EndChoice2
End If
Next
Next
Loop
GoTo ChooseALocationInput
EndChoice2:
BoardX2 = BoardX(Row2, Column2): BoardY2 = BoardY(Row2, Column2)
' Check If New Location Same as Old
If Row2 = Row1 And Column2 = Column1 Then PSet (BoardX1, BoardY1), PlayerColor(Player): Draw Cursor1: GoTo ChooseAPieceInput
' Clear Piece From Old Location
Line (BoardX1 - 46, BoardY1 - 46)-(BoardX1 + 46, BoardY1 + 46), 1, BF
BoardPlayer(Row1, Column1) = 0: BoardPiece(Row1, Column1) = 0
' Check if Piece is Now a Tower
If Playable(Row2, Column2) = 2 Then Piece = 2: Score(Player) = Score(Player) - 1
' Draw Piece in New Location
Circle (BoardX2, BoardY2), 40, PlayerColor(Player): Paint (BoardX2, BoardY2), PlayerColor(Player)
BoardPlayer(Row2, Column2) = Player: BoardPiece(Row2, Column2) = Piece
' If Piece is a Tower Draw Extra Rings
If Piece = 2 Then
Circle (BoardX2, BoardY2), 35, PlayerColor(Opponent): Paint (BoardX2, BoardY2), PlayerColor(Opponent)
Circle (BoardX2, BoardY2), 30, PlayerColor(Player): Paint (BoardX2, BoardY2), PlayerColor(Player)
End If
' Check if Move was a Jump
If Playable(Row2, Column2) = 3 Then
Score(Player) = Score(Player) + 1: Score(Opponent) = Score(Opponent) - 1
If Row2 - Row1 = 2 Then V = 1 Else If Row2 - Row1 = -2 Then V = -1 Else V = 0
If Column2 - Column1 = 2 Then W = 1 Else If Column2 - Column1 = -2 Then W = -1 Else W = 0
BoardPlayer(Row1 + V, Column1 + W) = Player
Circle (BoardX(Row1 + V, Column1 + W), BoardY(Row1 + V, Column1 + W)), 40, PlayerColor(Player)
Paint (BoardX(Row1 + V, Column1 + W), BoardY(Row1 + V, Column1 + W)), PlayerColor(Player)
End If
' Check Surrounding Pieces for Opponent to Flip
If Row2 - 1 >= 1 Then If BoardPlayer(Row2 - 1, Column2) = Opponent Then V = -1: W = 0: GoSub ChangePiece
If Row2 + 1 <= 7 Then If BoardPlayer(Row2 + 1, Column2) = Opponent Then V = 1: W = 0: GoSub ChangePiece
If Player = 1 Then
If Row2 - 1 >= 1 And Column2 + 1 <= 8 Then If BoardPlayer(Row2 - 1, Column2 + 1) = Opponent Then V = -1: W = 1: GoSub ChangePiece
If Column2 + 1 <= 8 Then If BoardPlayer(Row2, Column2 + 1) = Opponent Then V = 0: W = 1: GoSub ChangePiece
If Row2 + 1 <= 7 And Column2 + 1 <= 8 Then If BoardPlayer(Row2 + 1, Column2 + 1) = Opponent Then V = 1: W = 1: GoSub ChangePiece
ElseIf Player = 2 Then
If Row2 - 1 >= 1 And Column2 - 1 >= 1 Then If BoardPlayer(Row2 - 1, Column2 - 1) = Opponent Then V = -1: W = -1: GoSub ChangePiece
If Column2 - 1 >= 1 Then If BoardPlayer(Row2, Column2 - 1) = Opponent Then V = 0: W = -1: GoSub ChangePiece
If Row2 + 1 <= 7 And Column2 - 1 >= 1 Then If BoardPlayer(Row2 + 1, Column2 - 1) = Opponent Then V = 1: W = -1: GoSub ChangePiece
End If
EndTurn:
If Passed = 2 GoTo Winner
Swap Player, Opponent
GoTo StartGame
ReleaseMouseButton:
Do While _MouseInput
If _MouseButton(1) = 0 Then Return
Loop
GoTo ReleaseMouseButton
CheckPlayableMoves:
X = 0: V = 0
If Player = 1 Then
' Check Up Right
If Z - 1 >= 1 And Y + 1 <= 8 Then
If BoardPlayer(Z - 1, Y + 1) = 0 Then X = 1: V = 1: Playable(Z - 1, Y + 1) = 1
If BoardPlayer(Z - 1, Y + 1) = Player And BoardPiece(Z - 1, Y + 1) = 1 And Piece = 1 Then X = 1: Playable(Z - 1, Y + 1) = 2
If Z - 2 >= 1 And Y + 2 <= 8 Then
If BoardPlayer(Z - 1, Y + 1) = Opponent And BoardPiece(Z - 1, Y + 1) = 1 And BoardPlayer(Z - 2, Y + 2) = 0 And Piece = 2 Then X = 1: V = 1: Playable(Z - 2, Y + 2) = 3
End If
End If
' Check Right
If Y + 1 <= 8 Then
If BoardPlayer(Z, Y + 1) = 0 Then X = 1: V = 1: Playable(Z, Y + 1) = 1
If BoardPlayer(Z, Y + 1) = Player And BoardPiece(Z, Y + 1) = 1 And Piece = 1 Then X = 1: Playable(Z, Y + 1) = 2
If Y + 2 <= 8 Then
If BoardPlayer(Z, Y + 1) = Opponent And BoardPiece(Z, Y + 1) = 1 And BoardPlayer(Z, Y + 2) = 0 And Piece = 2 Then X = 1: V = 1: Playable(Z, Y + 2) = 3
End If
End If
' Check Down Right
If Z + 1 <= 7 And Y + 1 <= 8 Then
If BoardPlayer(Z + 1, Y + 1) = 0 Then X = 1: V = 1: Playable(Z + 1, Y + 1) = 1
If BoardPlayer(Z + 1, Y + 1) = Player And BoardPiece(Z + 1, Y + 1) = 1 And Piece = 1 Then X = 1: Playable(Z + 1, Y + 1) = 2
If Z + 2 <= 7 And Y + 2 <= 8 Then
If BoardPlayer(Z + 1, Y + 1) = Opponent And BoardPiece(Z + 1, Y + 1) = 1 And BoardPlayer(Z + 2, Y + 2) = 0 And Piece = 2 Then X = 1: V = 1: Playable(Z + 2, Y + 2) = 3
End If
End If
ElseIf Player = 2 Then
' Check Up Left
If Z - 1 >= 1 And Y - 1 >= 1 Then
If BoardPlayer(Z - 1, Y - 1) = 0 Then X = 1: V = 1: Playable(Z - 1, Y - 1) = 1
If BoardPlayer(Z - 1, Y - 1) = Player And BoardPiece(Z - 1, Y - 1) = 1 And Piece = 1 Then X = 1: Playable(Z - 1, Y - 1) = 2
If Z - 2 >= 1 And Y - 2 >= 1 Then
If BoardPlayer(Z - 1, Y - 1) = Opponent And BoardPiece(Z - 1, Y - 1) = 1 And BoardPlayer(Z - 2, Y - 2) = 0 And Piece = 2 Then X = 1: V = 1: Playable(Z - 2, Y - 2) = 3
End If
End If
' Check Left
If Y - 1 >= 1 Then
If BoardPlayer(Z, Y - 1) = 0 Then X = 1: V = 1: Playable(Z, Y - 1) = 1
If BoardPlayer(Z, Y - 1) = Player And BoardPiece(Z, Y - 1) = 1 And Piece = 1 Then X = 1: Playable(Z, Y - 1) = 2
If Y - 2 >= 1 Then
If BoardPlayer(Z, Y - 1) = Opponent And BoardPiece(Z, Y - 1) = 1 And BoardPlayer(Z, Y - 2) = 0 And Piece = 2 Then X = 1: V = 1: Playable(Z, Y - 2) = 3
End If
End If
' Check Down Left
If Z + 1 <= 7 And Y - 1 >= 1 Then
If BoardPlayer(Z + 1, Y - 1) = 0 Then X = 1: V = 1: Playable(Z + 1, Y - 1) = 1
If BoardPlayer(Z + 1, Y - 1) = Player And BoardPiece(Z + 1, Y - 1) = 1 And Piece = 1 Then X = 1: Playable(Z + 1, Y - 1) = 2
If Z + 2 <= 7 And Y - 2 >= 1 Then
If BoardPlayer(Z + 1, Y - 1) = Opponent And BoardPiece(Z + 1, Y - 1) = 1 And BoardPlayer(Z + 2, Y - 2) = 0 And Piece = 2 Then X = 1: V = 1: Playable(Z + 2, Y - 2) = 3
End If
End If
End If
Return
ChangePiece:
BoardPlayer(Row2 + V, Column2 + W) = Player: Score(Player) = Score(Player) + 1: Score(Opponent) = Score(Opponent) - 1
Line (BoardX(Row2 + V, Column2 + W) - 46, BoardY(Row2 + V, Column2 + W) - 46)-(BoardX(Row2 + V, Column2 + W) + 46, BoardY(Row2 + V, Column2) + W + 46), 1, BF
Circle (BoardX(Row2 + V, Column2 + W), BoardY(Row2 + V, Column2 + W)), 40, PlayerColor(Player)
Paint (BoardX(Row2 + V, Column2 + W), BoardY(Row2 + V, Column2 + W)), PlayerColor(Player)
If BoardPiece(Row2 + V, Column2 + W) = 2 Then
Circle (BoardX(Row2 + V, Column2 + W), BoardY(Row2 + V, Column2 + W)), 35, PlayerColor(Opponent)
Paint (BoardX(Row2 + V, Column2 + W), BoardY(Row2 + V, Column2 + W)), PlayerColor(Opponent)
Circle (BoardX(Row2 + V, Column2 + W), BoardY(Row2 + V, Column2 + W)), 30, PlayerColor(Player)
Paint (BoardX(Row2 + V, Column2 + W), BoardY(Row2 + V, Column2 + W)), PlayerColor(Player)
End If
Return
Winner:
If Score(1) > Score(2) Then Winner = 1 Else If Score(2) > Score(1) Then Winner = 2 Else Winner = 3
If Winner = 3 Then
Paint (949, 100), 0
Circle (899, 100), 40, PlayerColor(1): Paint (899, 100), PlayerColor(1)
Circle (999, 100), 40, PlayerColor(2): Paint (999, 100), PlayerColor(2)
Color 15, 0: Locate 11, 115: Print " ";
Locate 43, 105: Print " The Game Ended in a Draw ";
Else
Circle (949, 100), 40, PlayerColor(Winner): Paint (949, 100), PlayerColor(Winner)
Color 15, 0: Locate 11, 115: Print "Player:"; Winner;
Locate 43, 105: Print " Player"; Winner; "is the Winner! ";
End If
Locate 45, 104: Print " Play Another Game? (Y or N) ";
GetYorN:
A$ = UCase$(InKey$)
If A$ = "" Then GoTo GetYorN
If A$ = "Y" Then Run
If A$ = "N" Then System
GoTo GetYorN
|
|
|
|
| Quads Board Game |
|
Posted by: SMcNeill - 12-24-2023, 04:43 AM - Forum: Donald Foster
- No Replies
|
|
Quote:Hello Everyone,
Quads is a 2 player abstract strategy board game. The game is played with 36 tiles on a 6 X 6 game board. Player 1 plays 1 neutral tile and 17 light colored tiles. Player 2 plays the other neutral tile and their dark colored tiles. The player who can not place a tile on their turn loses the game.
At the start of the game each player places their tiles face up on their side of the board in view of both players. There is a variation the players can choose to agree to hide their tiles from their opponent. In a real game the players would stand their tiles up facing them. On my game, the opponent’s tiles are removed from the screen while the player takes their turn.
The game starts with player 1 places their neutral tiles any where on the board. Then player 2 places their neural tile anywhere empty space on the board, except next the other neutral tile placed. Then players take turns placing 1 of their tiles on any empty space on the board that is next to an adjacent tile. The edges of the tile being placed must match the edges of the adjacent tile on the board. In example: If the adjacent tile edge has vertical lines, the tile being place must have mating vertical lines on the same edge face each other. The same is true if the tile has horizontal lines. However, 2 tiles adjacent from each other both has a solid edge, but different colors, these tiles are not a match and can not be placed next to each other, were as same color tiles can. There is a border that surrounds the game board with horizontal lines. A player does not half to match the edges of the border for a normal game. There is a variation to the game that players can agree to have to match the borders edges also. The players are asked at the beginning of the game, weather to use the variations or not.
Playing the game on the computer: The game starts with an empty game board in the center. Player 1’s tiles are positioned on the left side of the board, while player 2’s is on the right side. There is a white cursor surrounding player 1’s neutral tile. You are prompted to choose a location on the board to place that tile. After clicking on the location, the tile is moved to that location. Then the turn go to placing player 2’s neutral tile on the board. From this point forward, the players are asked to choose the tile to placed and a cursor will surround the tile when clicked on. If at that point you wish to choose a different tile, just click on that same tile again and you are unlocked from that tile and able to choose a different. After choosing a tile, the player is asked to choose a space to place the tile on the game board. After clicking the location, a cursor surrounds that space on the board and leaves a cursor at the location where the tile was selected. At this point, the tile is not permanently locked to that space. If the player decides to choose a different tile, they click on the location where the tile was taken from the table and the tile will be unlocked and returned to that location. If a player wishes to rotate the tile, while the mouse pointer is on the tile place, clicking the right mouse button will rotate the tile clockwise. If the player decides o keep the tile at that space on the board, while the mouse pointer over that tile, left click and the tiles is permanently placed there and the turn passes to the other player.
This game is playable, but not complete. I’m a still working on the game, but wanted to get it out there anyway. The parts I'm still working on: At the beginning of a players turn, the computer check every rotation of every player’s tile still on the table to see if it will fit onto the board. If it determined it can’t be placed, then that tile will be highlighted in white and grey on the table and can not be selected for placement during this turn. It may become playable on a future turn. If it is determined that none of the tiles are playable during this turn, the game is considered over and the winner is declared.
There are imperfections in the visualizations of the tiles and I am usually a more perfectionist in my graphics, but in this case, I think it’s good enough. Making the tiles look perfect could have been possible, but a tremendous about of work would have had to be put into it and it wasn’t worth it. I feel It’s good enough for an amateur game. I will be uploading the completed version when ready. Hope you enjoy playing. Pressing ESC will alternate between window and full screen.
Donald
Quads Board Game Screenshot.bmp (Size: 2.82 MB / Downloads: 39)
QUADS-CLASSIC-USGB.pdf (Size: 170.79 KB / Downloads: 59)
Code: (Select All)
_Title "Quads by Donald L. Foster Jr."
Screen _NewImage(1310, 735, 256)
_Limit 100
_PaletteColor 1, _RGB32(245, 222, 179) ' Light
_PaletteColor 2, _RGB32(170, 92, 55) ' Dark
_PaletteColor 3, _RGB32(127, 127, 127) ' Grey
_PaletteColor 4, _RGB32(215, 192, 149)
_PaletteColor 5, _RGB32(120, 42, 5)
Dim Pattern$(17, 4)
Dim TableX(2, 17), TableY(2, 17), TableTile(2, 17): ClearTableX(1) = 10: ClearTableX(2) = 992
Player = 1: Opponant = 2
For Z = 1 To 2: For Y = 0 To 17: TableTile(Z, Y) = 1: Next: Next
For Z = 1 To 6: For Y = 1 To 6: BoardPlayer(Z, Y) = 0: BoardTile$(Z, Y) = "": Next: Next
Neutral$(1) = "HHHH": Neutral$(2) = "VVVV"
Pattern$(1, 1) = "VSSS": Pattern$(1, 2) = "SVSS": Pattern$(1, 3) = "SSVS": Pattern$(1, 4) = "SSSV"
Pattern$(2, 1) = "HSSS": Pattern$(2, 2) = "SHSS": Pattern$(2, 3) = "SSHS": Pattern$(2, 4) = "SSSH"
Pattern$(3, 1) = "VSVS": Pattern$(3, 2) = "SVSV": Pattern$(3, 3) = "VSVS": Pattern$(3, 4) = "SVSV"
Pattern$(4, 1) = "HSHS": Pattern$(4, 2) = "SHSH": Pattern$(4, 3) = "HSHS": Pattern$(4, 4) = "SHSH"
Pattern$(5, 1) = "VSHS": Pattern$(5, 2) = "SVSH": Pattern$(5, 3) = "HSVS": Pattern$(5, 4) = "SHSV"
Pattern$(6, 1) = "VHSS": Pattern$(6, 2) = "SVHS": Pattern$(6, 3) = "SSVH": Pattern$(6, 4) = "HSSV"
Pattern$(7, 1) = "HVSS": Pattern$(7, 2) = "SHVS": Pattern$(7, 3) = "SSHV": Pattern$(7, 4) = "VSSH"
Pattern$(8, 1) = "VVSS": Pattern$(8, 2) = "SVVS": Pattern$(8, 3) = "SSVV": Pattern$(8, 4) = "VSSV"
Pattern$(9, 1) = "HHSS": Pattern$(9, 2) = "SHHS": Pattern$(9, 3) = "SSHH": Pattern$(9, 4) = "HSSH"
Pattern$(10, 1) = "SHVH": Pattern$(10, 2) = "HSHV": Pattern$(10, 3) = "VHSH": Pattern$(10, 4) = "HVHS"
Pattern$(11, 1) = "SVHV": Pattern$(11, 2) = "VSVH": Pattern$(11, 3) = "HVSV": Pattern$(11, 4) = "VHVS"
Pattern$(12, 1) = "SHHH": Pattern$(12, 2) = "HSHH": Pattern$(12, 3) = "HHSH": Pattern$(12, 4) = "HHHS"
Pattern$(13, 1) = "SVVV": Pattern$(13, 2) = "VSVV": Pattern$(13, 3) = "VVSV": Pattern$(13, 4) = "VVVS"
Pattern$(14, 1) = "SHHV": Pattern$(14, 2) = "VSHH": Pattern$(14, 3) = "HVSH": Pattern$(14, 4) = "HHVS"
Pattern$(15, 1) = "SVHH": Pattern$(15, 2) = "HSVH": Pattern$(15, 3) = "HHSV": Pattern$(15, 4) = "VHHS"
Pattern$(16, 1) = "SHVV": Pattern$(16, 2) = "VSHV": Pattern$(16, 3) = "VVSH": Pattern$(16, 4) = "HVVS"
Pattern$(17, 1) = "SVVH": Pattern$(17, 2) = "HSVV": Pattern$(17, 3) = "VHSV": Pattern$(17, 4) = "VVHS"
Rotation$(1) = "TA0"
Rotation$(4) = "TA90"
Rotation$(3) = "TA180"
Rotation$(2) = "TA270"
Vertical$ = "C2E2U46L4D46F2BU3P2,2D4BE13U36L4D40E4BL2BU2P2,2R2BD2BL22D3U39L4D36F4U5BL2P2,2R2D5BH11U29L4D24F4U5BL2P2,2R2D5BR40U28R4D24G4U5BR2P2,2L2D5BE11U17R4D14G4U5BR2P2,2L2D5BL62U18L4D14F4U5BL2P2,2R2D5BH11U7L4D3F4U3BL1P2,2R1D3BR84U7R4D3G4U3BR1P2,2"
Horizontal$ = "C2BE46L92F4R85E4L5BD2P2,2U2R5BG11L72F4R64E4L5BD2P2,2U2R5BG11L50F4R42E4L5BD2P2,2U2R5BG11L26F4R18E4L5BD2P2,2"
Solid$ = "C2E48L96F48BU5BU5P2,2"
Cursor$ = "TA0BU49L49D98R98U98L49U1L50D100R100U100L51"
Color1$(1) = "C1TA0H15D30E15BL5P1,1BR234E15D30H15BR5P1,1"
Color1$(2) = "C0TA0H15D30E15BL5P0,0BR234E15D30H15BR5P0,0"
Color2$(1) = "C0TA0H15D30E15BL5P0,0BR234E15D30H15BR5P0,0"
Color2$(2) = "C2TA0H15D30E15BL5P2,2BR234E15D30H15BR5P2,2"
rootpath$ = Environ$("SYSTEMROOT")
fontfile$ = rootpath$ + "\Fonts\cour.ttf"
style$ = "monospace"
f& = _LoadFont(fontfile$, 30, style$)
_Font f&
' Draw Board
Line (329, 41)-(981, 693), 1, BF
' Draw Stripes
X = 41
For Z = 1 To 60
Line (329, X)-(981, X + 4), 2, BF
X = X + 11
Next
Line (358, 70)-(953, 665), 3, BF
' Draw Board Spaces
X = 120
For Z = 1 To 6
V = 408
For Y = 1 To 6
Line (V - 48, X - 48)-(V + 48, X + 48), 4, BF
BoardX(Z, Y) = V: BoardY(Z, Y) = X
V = V + 99
Next
X = X + 99
Next
Line (612, 667)-(700, 694), 1, BF
_Font 16: Color 2, 1: _PrintString (620, 673), "Q U A D S"
_Font f&: Color 15, 0: _PrintString (540, 7), "Q U A D S"
fontfile$ = rootpath$ + "\Fonts\lucon.ttf"
f& = _LoadFont(fontfile$, 22, style$)
_Font f&: Color 15, 0: _PrintString (61, 18), "Player 1's Tiles"
_PrintString (1042, 18), "Player 2's Tiles"
' Draw Tiles on Table
X = 103: W = 0
For Z = 1 To 6
V1 = 58: V2 = 1040
For Y = 1 To 3
If W = 0 Then
X1 = V1: X2 = X: X3 = 1: X4 = W: Tile$ = Neutral$(1): GoSub DrawPiece
X1 = V2: X2 = X: X3 = 2: X4 = W: Tile$ = Neutral$(2): GoSub DrawPiece
Else
Tile$ = Pattern$(W, 1)
X1 = V1: X2 = X: X3 = 1: X4 = W: GoSub DrawPiece
X1 = V2: X2 = X: X3 = 2: X4 = W: GoSub DrawPiece
End If
TableX(1, W) = V1: TableY(1, W) = X: TableX(2, W) = V2: TableY(2, W) = X
W = W + 1: V1 = V1 + 106: V2 = V2 + 106
Next
X = X + 106
Next
Color 15, 0: _PrintString (340, 708), "Use Variation 1: Hide Opponant's Pieces? (Y or N)"
GetVariationInput1:
A$ = UCase$(InKey$): If A$ = "" GoTo GetVariationInput1
If Asc(A$) = 27 And FS = 0 Then _FullScreen _SquarePixels , _Smooth: FS = 1 Else If Asc(A$) = 27 Then _FullScreen _Off: FS = 0
If A$ = "Y" Then Variation1 = 1 Else If A$ = "N" Then Variation1 = 0 Else GoTo GetVariationInput1
If Variation1 = 1 Then Color 2, 0: _PrintString (28, 700), "Hide Opponant's Tiles"
Color 15, 0: _PrintString (340, 708), " Use Variation 2: Must Match Borders? (Y or N) "
GetVariationInput2:
A$ = UCase$(InKey$): If A$ = "" GoTo GetVariationInput2
If Asc(A$) = 27 And FS = 0 Then _FullScreen _SquarePixels , _Smooth: FS = 1 Else If Asc(A$) = 27 Then _FullScreen _Off: FS = 0
If A$ = "Y" Then Variation2 = 1 Else If A$ = "N" Then Variation2 = 0 Else GoTo GetVariationInput2
If Variation2 = 1 Then Color 2, 0: _PrintString (1005, 700), "Must Match Border Edge"
For Player = 1 To 2
'DRaw Player Indicator Arrows
PSet (50, 27), 0: Draw Color1$(Player) + "BR748" + Color2$(Player)
' Place Cursor Around Player 1' Neutral Tile
Line (TableX(Player, 0) - 53, TableY(Player, 0) - 53)-(TableX(Player, 0) + 53, TableY(Player, 0) + 53), 15, B
If Player = 1 Then
Color 15, 0: _PrintString (330, 708), " Player 1, Place Your Neutral Tile on the Board "
Else
Color 15, 0: _PrintString (330, 708), " Player 2, Place Your Neutral Tile on the Board "
End If
' Get Neutral Tile Location
GetNeutralBoardLocation:
Do While _MouseInput
For Z = 1 To 6
For Y = 1 To 6
If _MouseX > BoardX(Z, Y) - 50 And _MouseY > BoardY(Z, Y) - 50 And _MouseX < BoardX(Z, Y) + 50 And _MouseY < BoardY(Z, Y) + 50 Then Selected1 = 1 Else Selected1 = 0
If _MouseButton(1) = -1 And Selected1 = 1 Then
GoSub ButtonRelease1
If Player = 2 Then
If BoardPlayer(Z, Y) > 0 GoTo GetNeutralBoardLocation
If Z - 1 >= 1 Then If BoardPlayer(Z - 1, Y) > 0 GoTo GetNeutralBoardLocation
If Z + 1 <= 6 Then If BoardPlayer(Z + 1, Y) > 0 GoTo GetNeutralBoardLocation
If Y - 1 >= 1 Then If BoardPlayer(Z, Y - 1) > 0 GoTo GetNeutralBoardLocation
If Y + 1 <= 6 Then If BoardPlayer(Z, Y + 1) > 0 GoTo GetNeutralBoardLocation
End If
If Variation2 = 1 Then
If Player = 1 And (Y = 1 Or Y = 6) GoTo GetNeutralBoardLocation
If Player = 2 And (Z = 1 Or Z = 6) GoTo GetNeutralBoardLocation
End If
Line (TableX(Player, 0) - 53, TableY(Player, 0) - 53)-(TableX(Player, 0) + 53, TableY(Player, 0) + 53), 0, BF
X1 = BoardX(Z, Y): X2 = BoardY(Z, Y): X3 = Player: Tile$ = Neutral$(Player): GoSub DrawPiece
TableTile(Player, 0) = 0: BoardPlayer(Z, Y) = 3: BoardTile$(Z, Y) = Neutral$(Player): GoTo EndLoop1
End If
Next
Next
Loop
A$ = InKey$: If A$ <> "" Then If Asc(A$) = 27 And Full = 0 Then _FullScreen _SquarePixels , _Smooth: Full = 1 Else If Asc(A$) = 27 Then _FullScreen _Off: Full = 0
GoTo GetNeutralBoardLocation
EndLoop1:
Next
Player = 1
StartGame:
'DRaw Player Indicator Arrows
PSet (50, 27), 0: Draw Color1$(Player) + "BR748" + Color2$(Player)
If Variation1 = 1 Then
' Clear Opponant's Pieces from View
Line (ClearTableX(Opponant), 55)-(ClearTableX(Opponant) + 309, 682), 0, BF
' Redraw Player's Pieces
For Z = 1 To 17
If TableTile(Player, Z) = 1 Then X1 = TableX(Player, Z): X2 = TableY(Player, Z): X3 = Player: Tile$ = Pattern$(Z, 1): GoSub DrawPiece
Next
End If
Table:
If Player = 1 Then
Color 15, 0: _PrintString (336, 708), " Player 1, Choose a Tile to Place on the Board "
Else
Color 15, 0: _PrintString (336, 708), " Player 2, Choose a Tile to Place On The Board "
End If
ChooseTile:
Do While _MouseInput
For Z = 1 To 17
If _MouseX > TableX(Player, Z) - 48 And _MouseX < TableX(Player, Z) + 48 And _MouseY > TableY(Player, Z) - 48 And _MouseY < TableY(Player, Z) + 48 Then TileChoice = 1 Else TileChoice = 0
If _MouseButton(1) = -1 And TileChoice = 1 Then
GoSub ButtonRelease1: Tile = Z
If TableTile(Player, Z) = 1 Then
Tile$ = Pattern$(Z, 1)
' Draw Cursor Around Piece
Line (TableX(Player, Z) - 53, TableY(Player, Z) - 53)-(TableX(Player, Z) + 53, TableY(Player, Z) + 53), 15, B: GoTo EndLoop2
End If
End If
Next
Loop
A$ = InKey$: If A$ <> "" Then If Asc(A$) = 27 And Full = 0 Then _FullScreen _SquarePixels , _Smooth: Full = 1 Else If Asc(A$) = 27 Then _FullScreen _Off: Full = 0
GoTo ChooseTile
EndLoop2:
If Player = 1 Then
Color 15, 0: _PrintString (339, 708), " Player 1, Choose a Board Location to Place Tile "
Else
Color 15, 0: _PrintString (339, 708), " Player 2, Choose a Board Location to Place Tile "
End If
ChooseLocation:
Do While _MouseInput
' Check Unlock Tile
For Z = 1 To 17
If _MouseX > TableX(Player, Z) - 48 And _MouseX < TableX(Player, Z) + 48 And _MouseY > TableY(Player, Z) - 48 And _MouseY < TableY(Player, Z) + 48 Then TileSelect = 1 Else TileSelect = 0
If _MouseButton(1) = -1 And TileSelect = 1 Then
GoSub ButtonRelease1: Line (TableX(Player, Z) - 53, TableY(Player, Z) - 53)-(TableX(Player, Z) + 53, TableY(Player, Z) + 53), 0, B: GoTo Table
End If
Next
' Check Board Locations
For Z = 1 To 6
For Y = 1 To 6
If _MouseX > BoardX(Z, Y) - 50 And _MouseX < BoardX(Z, Y) + 50 And _MouseY > BoardY(Z, Y) - 50 And _MouseY < BoardY(Z, Y) + 50 Then LocationChoice = 1 Else LocationChoice = 0
If _MouseButton(1) = -1 And LocationChoice = 1 Then
GoSub ButtonRelease1: Row = Z: Column = Y
'Is Board Location Empty?
If BoardPlayer(Z, Y) > 0 GoTo ChooseLocation
' Is Adjacent to a Tile?
If Z - 1 >= 1 Then
If BoardPlayer(Z - 1, Y) = 0 Then W1 = 0 Else W1 = 1
Else
W1 = 2
End If
If Z + 1 <= 6 Then
If BoardPlayer(Z + 1, Y) = 0 Then W3 = 0 Else W3 = 1
Else
W3 = 2
End If
If Y - 1 >= 1 Then
If BoardPlayer(Z, Y - 1) = 0 Then W4 = 0 Else W4 = 1
Else
W4 = 2
End If
If Y + 1 <= 6 Then
If BoardPlayer(Z, Y + 1) = 0 Then W2 = 0 Else W2 = 1
Else
W2 = 2
End If
If W1 = 0 And W2 = 0 And W3 = 0 And W4 = 0 GoTo ChooseLocation
' Remove Tile from Table
Line (TableX(Player, Tile) - 48, TableY(Player, Tile) - 48)-(TableX(Player, Tile) + 50, TableY(Player, Tile) + 48), 0, BF
' Draw Tile on to Board
X1 = BoardX(Z, Y): X2 = BoardY(Z, Y): X3 = Player: GoSub DrawPiece
' Draw Cursor Around Tile on the Board
PSet (BoardX(Z, Y), BoardY(Z, Y)), Point(BoardX(Z, Y), BoardY(Z, Y)): Draw "C15" + Cursor$: GoTo EndLoop3
End If
Next
Next
Loop
A$ = InKey$: If A$ <> "" Then If Asc(A$) = 27 And Full = 0 Then _FullScreen _SquarePixels , _Smooth: Full = 1 Else If Asc(A$) = 27 Then _FullScreen _Off: Full = 0
GoTo ChooseLocation:
EndLoop3:
If Player = 1 Then
Color 15, 0: _PrintString (339, 708), " Player 1, Lock Tile, Rotate Tile or Return Tile "
Else
Color 15, 0: _PrintString (339, 708), " Player 2, Lock Tile, Rotate Tile or Return Tile "
End If
Rotation = 1
GetMouseClick:
Do While _MouseInput
' Check for Return to Table
For Z = 1 To 17
If _MouseX > TableX(Player, Z) - 48 And _MouseX < TableX(Player, Z) + 48 And _MouseY > TableY(Player, Z) - 48 And _MouseY < TableY(Player, Z) + 48 Then MouseChoice = 1 Else MouseChoice = 0
If _MouseButton(1) = -1 And MouseChoice = 1 Then
GoSub ButtonRelease1:
If Z = Tile Then
' Remove Cursor from Tile on the Board
PSet (BoardX(Row, Column), BoardY(Row, Column)), 5: Draw "C3" + Cursor$
' Remove Tile from the Board
Line (BoardX(Row, Column) - 48, BoardY(Row, Column) - 48)-(BoardX(Row, Column) + 48, BoardY(Row, Column) + 48), 4, BF
' Set Tile Back to First Rotation
Tile$ = Pattern$(Tile, 1)
' Redraw the Tile on the Table
X1 = TableX(Player, Tile): X2 = TableY(Player, Tile): X3 = Player: X4 = 1: GoSub DrawPiece
' Remove Cursor from the Table
Line (TableX(Player, Z) - 53, TableY(Player, Z) - 53)-(TableX(Player, Z) + 53, TableY(Player, Z) + 53), 0, B
GoTo Table
End If
End If
Next
For Z = 1 To 6
For Y = 1 To 6
If _MouseX > BoardX(Z, Y) - 50 And _MouseX < BoardX(Z, Y) + 50 And _MouseY > BoardY(Z, Y) - 50 And _MouseY < BoardY(Z, Y) + 50 Then LocationChoice = 1 Else LocationChoice = 0
If _MouseButton(2) = -1 And LocationChoice = 1 Then
GoSub ButtonRelease2: If Rotation = 4 Then Rotation = 1 Else Rotation = Rotation + 1
Tile$ = Pattern$(Tile, Rotation): X1 = BoardX(Row, Column): X2 = BoardY(Row, Column): X3 = Player: X4 = Rotation: GoSub DrawPiece: GoTo GetMouseClick
End If
If _MouseButton(1) = -1 And LocationChoice = 1 Then
GoSub ButtonRelease1: Tile$ = Pattern$(Tile, Rotation): X = 1
' Get Tile 4 Sides
TopSide$ = Mid$(Tile$, 1, 1): RightSide$ = Mid$(Tile$, 2, 1): BottomSide$ = Mid$(Tile$, 3, 1): LeftSide$ = Mid$(Tile$, 4, 1)
' Does Tile Edges Match?
If W1 = 1 Then
Edge$ = Mid$(BoardTile$(Row - 1, Column), 3, 1)
If Edge$ = "S" And Edge$ = TopSide$ And BoardPlayer(Row - 1, Column) = Opponant Then X = 0
If Edge$ <> TopSide$ Then X = 0
End If
If W2 = 1 Then
Edge$ = Mid$(BoardTile$(Row, Column + 1), 4, 1)
If Edge$ = "S" And Edge$ = RightSide$ And BoardPlayer(Row, Column + 1) = Opponant Then X = 0
If Edge$ <> RightSide$ Then X = 0
End If
If W3 = 1 Then
Edge$ = Mid$(BoardTile$(Row + 1, Column), 1, 1)
If Edge$ = "S" And Edge$ = BottomSide$ And BoardPlayer(Row + 1, Column) = Opponant Then X = 0
If Edge$ <> BottomSide$ Then X = 0
End If
If W4 = 1 Then
Edge$ = Mid$(BoardTile$(Row, Column - 1), 2, 1)
If Edge$ = "S" And Edge$ = LeftSide$ And BoardPlayer(Row, Column - 1) = Opponant Then X = 0
If Edge$ <> LeftSide$ Then X = 0
End If
If Variation2 = 1 Then
If W1 = 2 And TopSide$ <> "H" Then X = 0
If W2 = 2 And RightSide$ <> "V" Then X = 0
If W3 = 2 And BottomSide$ <> "H" Then X = 0
If W4 = 2 And LeftSide$ <> "V" Then X = 0
End If
If X = 0 GoTo GetMouseClick
' Remove Tile Information from the Table o Board
TableTile(Player, Tile) = 0: BoardPlayer(Row, Column) = Player: BoardTile$(Row, Column) = Tile$
' Remove Cursor from Tile on the Board
PSet (BoardX(Row, Column), BoardY(Row, Column)), 5: Draw "C3" + Cursor$
' Remove Cursor from the Table
Line (TableX(Player, Tile) - 53, TableY(Player, Tile) - 53)-(TableX(Player, Tile) + 53, TableY(Player, Tile) + 53), 0, B
GoTo EndLoop4
End If
Next
Next
Loop
A$ = InKey$: If A$ <> "" Then If Asc(A$) = 27 And Full = 0 Then _FullScreen _SquarePixels , _Smooth: Full = 1 Else If Asc(A$) = 27 Then _FullScreen _Off: Full = 0
GoTo GetMouseClick
EndLoop4:
Swap Player, Opponant: GoTo StartGame
Sleep
DrawPiece:
Line (X1 - 48, X2 - 48)-(X1 + 48, X2 + 48), 1, BF
'PSET (X1, X2), 0: DRAW "NH48NE48NF48NG48"
For Side = 1 To 4
If X4 = 0 Then
Side$ = Mid$(Neutral$(X3), Side, 1)
Else
Side$ = Mid$(Tile$, Side, 1)
End If
If Side$ = "S" And X3 = 1 Then
Else
If Side$ = "S" Then TileSide$ = Solid$
If Side$ = "V" Then TileSide$ = Vertical$
If Side$ = "H" Then TileSide$ = Horizontal$
PSet (X1, X2), 1: Draw Rotation$(Side) + TileSide$
End If
Next
Return
ButtonRelease1:
Do While _MouseInput
If _MouseButton(1) = 0 Then Return
Loop
GoTo ButtonRelease1
ButtonRelease2:
Do While _MouseInput
If _MouseButton(2) = 0 Then Return
Loop
GoTo ButtonRelease2
|
|
|
|
| QB64 Simon by Terry Ritchie |
|
Posted by: SMcNeill - 12-24-2023, 04:27 AM - Forum: Games
- No Replies
|
|
Quote:I was going through some of my old code and came across the Simon game I created back in 2015. I don't believe I ever posted it here. It's an exact replica of the Simon game from the 1980's (well, I added the QB64 bee graphic).
Game play can be done with keyboard, mouse, or both. Press F1 for a help screen.
The .ZIP file below contains the source code and asset files needed to compile and play the game.
Required files (plus BAS source):
Simon.zip (Size: 236.77 KB / Downloads: 27)
Code: (Select All)
'*
'* ------------------
'* --- QB64 Simon ---
'* ------------------
'*
'* By Terry Ritchie
'*
'* Written from March 22nd to March 28th, 2015
'* Version 1.0
'*
'--------------------------------
'- VARIABLE DECLARATION SECTION -
'--------------------------------
Const FALSE = 0 ' boolean: false indicator
Const TRUE = Not FALSE ' boolean: true indicator
Const MOUSE% = 200 ' call PADPRESS with mouse button
Dim Pad&(3, 1) ' color pads: 0,x=BLUE, 1,x=RED, 2,x=GREEN, 3,x=YELLOW
Dim PadXY%(3, 1) ' x,y locations of color pads
Dim Tone&(4) ' game sounds: 0=BLUE, 1=RED, 2=GREEN, 3=YELLOW, 4=LOSE
Dim Simon& ' simon graphics image
Dim SimonHelp& ' simon help screen
Dim Keys&(3, 1) ' keyboard key images 0=Q, 1=W, 2=S, 3=A
Dim Bslider& ' blue slider switch image
Dim Rslider& ' red slider switch image
Dim OnOff& ' on/off slider switch
Dim KeysXY%(3, 1) ' location of keyboard key images on play screen
Dim GameOver% ' boolean: true when game has ended
Dim Game% ' the position the blue slider switch is in (0-2)
Dim Skill% ' the position the red slider switch is in (0-3)
Dim GameDir% ' the direction blue slider switch will move (1, -1)
Dim SkillDir% ' the direction red slider switch will move (1, -1)
Dim Longest$ ' the longest tune correctly played by a player
Dim Last$ ' the last tune played by the player
Dim Count% ' generic counter
Dim KeyPress$ ' any keys pressed by the player
Dim Pcolor~&(3) ' color pad base colors: 0=BLUE, 1=RED, 2=GREEN, 3=YELLOW
'----------------
'- MAIN PROGRAM -
'----------------
INITIALIZE ' prepare graphics, sounds and variables
Screen _NewImage(640, 640, 32) ' create game screen
_Title "QB64 SIMON" ' give game screen a title
_ScreenMove _Middle ' move game screen to middle of desktop
_Delay .5 ' light delay to move to middle of screen
Cls ' remove black transparency
Do ' BEGIN MAIN GAME LOOP
GameOver% = FALSE ' reset game over flag
PRESSPAD 0, 0 ' reset game board
_Display
Do ' BEGIN PLAY GAME LOOP
_Limit 120 ' limit to 120 loops per second
While _MouseInput: Wend ' get to last mouse event
If _MouseButton(1) Then ' did player click left mouse button?
If POINTER%(232 + Game% * 10, 323, 289 + Game% * 10, 345) Then ' test blue slider area?
If Game% = 0 Or Game% = 2 Then ' yes, is blue slider at its limit?
GameDir% = -GameDir% ' yes, reverse blue slider direction
End If
Game% = Game% + GameDir% ' change game level
PRESSPAD 0, .125 ' display change on screen
WAIT4RELEASE
ElseIf POINTER%(319 + Skill% * 10, 323, 375 + Skill% * 10, 345) Then ' test red slider area?
If Skill% = 0 Or Skill% = 3 Then ' yes, is red slider at its limit?
SkillDir% = -SkillDir% ' yes, reverse red slider direction
End If
Skill% = Skill% + SkillDir% ' change skill level
PRESSPAD 1, .125 ' display change on screen
WAIT4RELEASE
ElseIf POINTER%(254, 371, 271, 388) Then ' test last button area?
WAIT4RELEASE
For Count% = 1 To Len(Last$) ' cycle through last tune string
PRESSPAD Val(Mid$(Last$, Count%, 1)), .5 ' play each individual tone
_Delay .125 ' pause for 1/8 second
Next Count%
ElseIf POINTER%(371, 371, 388, 388) Then ' test longest button area?
Count% = 0 ' yes, reset 1/120 counter
Do ' BEGIN MOUSE RELEASE LOOP
_Limit 120 ' don't hog CPU while looping
While _MouseInput: Wend ' get to last mouse event
Count% = Count% + 1 ' increment 1/120 second counter
If Count% > 360 Then ' have 3 seconds elapsed?
For Count% = 0 To 3 ' yes, cycle through all four color pads
PRESSPAD Count%, .125 ' light pad and play tone quickly
Next Count%
Longest$ = "" ' reset longest tune string
SIMONFILE 2 ' delete simon.sav file
End If
Loop Until Not _MouseButton(1) ' END MOUSE RELEASE LOOP when left button released
For Count% = 1 To Len(Longest$) ' cycle through longest tune string
PRESSPAD Val(Mid$(Longest$, Count%, 1)), .5 ' play each individual tone
_Delay .125 ' pause 1/8 second
Next Count%
ElseIf POINTER%(314, 371, 331, 388) Then ' test start button area?
_Delay .5 ' 1/2 second delay before game start
PLAYGAME ' play game
ElseIf POINTER%(321, 408, 332, 419) Then ' test power button slider area?
ENDGAME ' yes, end the game
End If
End If
KeyPress$ = InKey$ ' get any key player may have pressed
If KeyPress$ = Chr$(0) + Chr$(59) Then ' did player press the F1 key?
DISPLAYHELP ' yes, display help screen to player
End If
Loop Until GameOver% ' END PLAY GAME LOOP
Loop ' MAIN GAME LOOP end
'--------------------
'- END MAIN PROGRAM -
'--------------------
'---------------------------
'- SUBROUTINES & FUNCTIONS -
'---------------------------
'----------------------------------------------------------------------------------------------------------------------
' DISPLAYHELP
Sub DISPLAYHELP ()
'---------------------------------------
'- Display the help screen to the player
'---------------------------------------
Shared SimonHelp& ' simon help screen
_PutImage (0, 0), SimonHelp& ' display help screen
_Display ' update screen with change
Do ' BEGIN KEY/MOUSE LOOP
_Limit 120 ' don't hog the CPU
While _MouseInput: Wend ' get latest mouse events
Loop Until InKey$ <> "" Or _MouseButton(1) ' END KEY/MOUSE LOOP when left button clicked or key pressed
PRESSPAD 0, 0 ' restore game screen
End Sub
'----------------------------------------------------------------------------------------------------------------------
' WAIT4RELEASE
Sub WAIT4RELEASE ()
'--------------------------------------------
'- Waits for left mouse button to be released
'--------------------------------------------
Do ' BEGIN MOUSE RELEASE LOOP
_Limit 120 ' don't hog the CPU
While _MouseInput: Wend ' get to last mouse event
Loop Until Not _MouseButton(1) ' END MOUSE RELEASE LOOP when left button released
End Sub
'----------------------------------------------------------------------------------------------------------------------
' SIMONFILE
Sub SIMONFILE (Task%)
'------------------------------------------
'- Loads, updates, or deletes the save file
'-
'- Task%: 0 - load file
'- 1 - update file
'- 2 - delete file
'------------------------------------------
Shared Longest$ ' the longest tune correctly played by a player
Select Case Task% ' load, update, or delete?
Case 0 ' load file
If _FileExists("simon.sav") Then ' does the save file exist?
Open "simon.sav" For Input As #1 ' yes, open the file for reading
Line Input #1, Longest$ ' get the longest tune ever played
Close #1 ' close the file
End If
Case 1 ' update file
Open "simon.sav" For Output As #1 ' open the file for output
Print #1, Longest$ ' write the longest tune ever played
Close #1 ' close the file
Case 2 ' delete file
If _FileExists("simon.sav") Then ' does the save file exist?
Kill "simon.sav" ' yes, delete it
End If
End Select
End Sub
'----------------------------------------------------------------------------------------------------------------------
' POINTER%
Function POINTER% (x1%, y1%, x2%, y2%)
'------------------------------------------------------------------------------
'- Returns TRUE if the mouse pointer falls within x1%,y1% - x2%,y2% coordinates
'-
'- x1%: upper left hand corner x coordinate of box area
'- y1%: upper left hand corner y coordinate of box area
'- x2%: lower right hand corner x coordinate of box area
'- y2%: lower right hand corner y coordinate of box area
'------------------------------------------------------------------------------
Dim mx% ' current mouse pointer x coordinate
Dim my% ' current mouse pointer y coordinate
POINTER% = FALSE ' assume pointer does not fall within coordinates
While _MouseInput: Wend ' get latest mouse event
mx% = _MouseX ' get current mouse pointer x coordinate
my% = _MouseY ' get current mouse pointer y coordinate
If mx% >= x1% Then ' could pointer be within x coordinates?
If mx% <= x2% Then ' yes, is pointer within x coordinates?
If my% >= y1% Then ' yes, could pointer be within y coordinates?
If my% <= y2% Then ' yes, is pointer within y coordinates?
POINTER% = TRUE ' yes, report back that pointer falls within coordinates
End If
End If
End If
End If
End Function
'----------------------------------------------------------------------------------------------------------------------
' PLAYGAME
Sub PLAYGAME ()
'-----------------------
'- Plays a game of simon
'-----------------------
Shared GameOver% ' boolean: true when game has ended
Shared Game% ' the position the blue slider switch is in (0-2)
Shared Skill% ' the position the red slider switch is in (0-3)
Shared Longest$ ' the longest tune correctly played by a player
Shared Last$ ' the last tune played by the player
Dim Tune$ ' string of random tunes generated during game play
Dim KeyPress& ' contains value of any key pressed
Dim PlaySpeed! ' speed that simon plays notes
Dim Count% ' generic counter
Dim Notes% ' player note counter
Dim PadPress% ' value of colored pad pressed by player
Dim Plongest$ ' current player's longest tune
Dim Win% ' number of correct tones to win
'-------------
'- MAIN CODE -
'-------------
PRESSPAD 0, 0 ' reset game screen
PlaySpeed! = 1 ' reset game speed
Win% = 12 + Skill% * 6 ' calculate number of tones to win
Tune$ = "" ' reset random tune string
Do ' BEGIN PLAY GAME LOOP
For Count% = 1 To Game% + 1 ' number of notes to add
Tune$ = Tune$ + LTrim$(RTrim$(Str$(Int(Rnd(1) * 4)))) ' add a random tone
If Len(Tune$) Mod 3 = 0 Then ' divisible evenly by 3?
PlaySpeed! = PlaySpeed! - .125 ' yes, increase speed of play
If PlaySpeed! < .125 Then PlaySpeed! = .125 ' keep play speed at certain minimum
End If
Next Count%
For Count% = 1 To Len(Tune$) ' cycle through the tones
PRESSPAD Val(Mid$(Tune$, Count%, 1)), PlaySpeed! ' play the tone
_Delay PlaySpeed! / 4 ' pause between tones
Next Count%
Notes% = 0 ' reset player note count
Do ' BEGIN PLAY ROUND LOOP
Do ' BEGIN BUFFER CLEAR LOOP
_Limit 120 ' don't hog CPU
KeyPress& = _KeyHit ' get keypress from keyboard buffer
Loop While KeyPress& ' END BUFFER CLEAR LOOP when buffer clear
Notes% = Notes% + 1 ' increment player note count
PadPress% = PLAYERINPUT% ' get player's next color pad press
If PadPress% <> Val(Mid$(Tune$, Notes%, 1)) Then ' did the player press the right color pad?
GameOver% = TRUE ' no, set game over flag
PRESSPAD 4, 2 ' play loser sound and light up simon
End If
Loop Until Notes% = Len(Tune$) Or GameOver% ' END PLAY ROUND LOOP when player success or game over
If Not GameOver% Then Plongest$ = Tune$ ' remember last attempt as player's longest
If Notes% = Win% Then ' did player win?
GameOver% = TRUE ' yes, set game over
For Win% = 1 To 6 ' cycle 6 times
For Count% = 0 To 3 ' cycle through all color pads
PRESSPAD Count%, .125 ' press color pad
Next Count%
Next Win%
End If
_Delay PlaySpeed! * 2 ' slight delay between rounds
Loop Until GameOver% ' END PLAY GAME LOOP when game over
Last$ = Tune$ ' remember the entire last tune played
If Len(Plongest$) > Len(Longest$) Then ' did player set a new longest record?
Longest$ = Plongest$ ' yes, remember the new longest tune
SIMONFILE 1 ' update simon.sav with new longest tune
End If
End Sub
'----------------------------------------------------------------------------------------------------------------------
' PLAYERINPUT%
Function PLAYERINPUT% ()
' -----------------------------------------------------------------------
' Waits for player input then returns the color pad pressed by the player
' -----------------------------------------------------------------------
Shared Pcolor~&() ' color pad base colors: 0=BLUE, 1=RED, 2=GREEN, 3=YELLOW
Dim PadPress% ' the color pad that was pressed
Dim KeyPress& ' a key the player has pressed
Dim mx% ' current mouse pointer x coordinate
Dim my% ' current mouse pointer y coordinate
Dim Clr~& ' color of pixel clicked on
PadPress% = -1 ' reset pad press indicator
Do ' BEGIN INPUT LOOP
_Limit 120 ' don't hog the CPU
KeyPress& = _KeyHit ' get the latest key status
While _MouseInput: Wend ' get the latest mouse status
If KeyPress& Then ' was a key pressed?
Select Case KeyPress& ' yes, which one?
Case 81, 113 ' Q or q key
PRESSPAD 0, KeyPress& ' press blue pad on simon
PadPress% = 0 ' remember blue pad pressed
Case 87, 119 ' W or w key
PRESSPAD 1, KeyPress& ' press red pad on simon
PadPress% = 1 ' remember red pad pressed
Case 83, 115 ' S or s key
PRESSPAD 2, KeyPress& ' press green pad on simon
PadPress% = 2 ' remember green pad pressed
Case 65, 97 ' A or a key
PRESSPAD 3, KeyPress& ' press yellow pad on simon
PadPress% = 3 ' remember yellow pad pressed
End Select
ElseIf _MouseButton(1) Then ' no, was the left mouse button clicked?
mx% = _MouseX ' yes, get x location of mouse pointer
my% = _MouseY ' get y location of mouse pointer
Clr~& = Point(mx%, my%)
If mx% < 320 And my% < 320 And Clr~& = Pcolor~&(0) Then ' pointer in blue area?
PRESSPAD 0, MOUSE% ' yes, press blue pad on simon
PadPress% = 0 ' remember blue pad pressed
ElseIf mx% > 319 And my% < 320 And Clr~& = Pcolor~&(1) Then ' no, pointer in red area?
PRESSPAD 1, MOUSE% ' yes, press red pad on simon
PadPress% = 1 ' remember red pad pressed
ElseIf mx% > 319 And my% > 319 And Clr~& = Pcolor~&(2) Then ' no, pointer in green area?
PRESSPAD 2, MOUSE% ' yes, press green pad on simon
PadPress% = 2 ' remember green pad pressed
ElseIf mx% < 320 And my% > 319 And Clr~& = Pcolor~&(3) Then ' no, pointer in yellow area?
PRESSPAD 3, MOUSE% ' yes, press yellow pad on simon
PadPress% = 3 ' remember yellow pad pressed
End If
End If
Loop Until PadPress% <> -1 ' END INPUT LOOP when simon pad pressed
PLAYERINPUT% = PadPress% ' return the pad that was pressed
End Function
'----------------------------------------------------------------------------------------------------------------------
' PRESSPAD
Sub PRESSPAD (PadNum%, Behavior!)
' -----------------------------------------------------------------------------------------
' Simulates pressing a colored pad by lighting it up and playing its corresponding sound
'
' PadNum% - The colored pad to press: 0=BLUE, 1=RED, 2=GREEN, 3=YELLOW, 4=ALL
' Behavior! - If value is less than 5 then sound plays for this duration
' - If value is less than 120 then sound plays until scancode of key is released
' - if value > 120 then sound plays until left mouse button is released
' - if value is zero then game board is redrawn only
' -----------------------------------------------------------------------------------------
Shared Tone&() ' game sounds
Shared Pad&() ' color pads: 0,x=BLUE, 1,x=RED, 2,x=GREEN, 3,x=YELLOW
Shared PadXY%() ' x,y locations of color pads
Shared Simon& ' simon graphics image
Shared Keys&() ' keyboard key images 0=Q, 1=W, 2=S, 3=A
Shared KeysXY%() ' location of keyboard key images
Shared Bslider& ' blue slider switch image
Shared Rslider& ' red slider switch image
Shared OnOff& ' on/off slider switch
Shared Game% ' the position the blue slider switch is in (0-2)
Shared Skill% ' the position the red slider switch is in (0-3)
Dim KeyPress& ' key press value
Dim KeyStatus% ' 0=no key animation, 1=key animation
'-------------
'- MAIN CODE -
'-------------
KeyStatus% = 1 ' assume key animation
If Behavior! Then ' just a board redraw?
If Behavior! = MOUSE% Or Behavior! < 5 Then ' turn key animation off?
KeyStatus% = 0 ' yes, turn animation off
End If
If PadNum% <> 4 Then ' single color pad selected?
_PutImage (PadXY%(PadNum%, 0), PadXY%(PadNum%, 1)), Pad&(PadNum%, 1) ' yes, light color pad
_PutImage (KeysXY%(PadNum%, 0), KeysXY%(PadNum%, 1)), Keys&(PadNum%, KeyStatus%) ' animate key if needed
Else ' no, all color pads selected
For Count% = 0 To 3 ' cycle through all color pads
_PutImage (PadXY%(Count%, 0), PadXY%(Count%, 1)), Pad&(Count%, 1) ' light color pad
_PutImage (KeysXY%(Count%, 0), KeysXY%(Count%, 1)), Keys&(Count%, 0) ' set keys to raised position
Next Count%
End If
_PutImage (200, 200), Simon& ' place round simon image
_PutImage (232 + Game% * 10, 323), Bslider& ' place blue slider
_PutImage (319 + Skill% * 10, 323), Rslider& ' place red slider
_PutImage (321, 408), OnOff& ' place power button slider
_Display ' update screen with changes
_SndLoop Tone&(PadNum%) ' sound into continuous loop
Select Case Behavior! ' how was SUB called?
Case Is < 5 ' computer pressing color pad
_Delay Behavior! ' use value as a delay
Case Is < 120 ' player is pressing a key
_Delay .125 ' pause for 1/8 second
Do ' BEGIN KEYBOARD SCAN LOOP
_Limit 120 ' don't hog CPU
KeyPress% = _KeyHit ' get value of key pressed
Loop Until KeyPress% = -Behavior! ' END LOOP when key released
Case Else ' player using mouse button
_Delay .125 ' pause for 1/8 second
WAIT4RELEASE ' wait left button released
End Select
_SndStop Tone&(PadNum%) ' stop the sound
End If
For Count% = 0 To 3 ' cycle through all color pads
_PutImage (PadXY%(Count%, 0), PadXY%(Count%, 1)), Pad&(Count%, 0) ' unlight color pad
_PutImage (KeysXY%(Count%, 0), KeysXY%(Count%, 1)), Keys&(Count%, 0) ' set keys to raised position
Next Count%
_PutImage (200, 200), Simon& ' place round simon image
_PutImage (232 + Game% * 10, 323), Bslider& ' place blue slider
_PutImage (319 + Skill% * 10, 323), Rslider& ' place red slider
_PutImage (321, 408), OnOff& ' place power button slider
_Display ' update screen with changes
End Sub
'----------------------------------------------------------------------------------------------------------------------
' INITIALIZE
Sub INITIALIZE ()
' --------------------------------------------------------------------------------------------
' Initialize all variables, create color pad images, load sounds and load spritesheet graphics
' --------------------------------------------------------------------------------------------
Shared Pad&() ' color pads: 0,x=BLUE, 1,x=RED, 2,x=GREEN, 3,x=YELLOW
Shared PadXY%() ' x,y locations of color pads
Shared Tone&() ' game sounds
Shared Simon& ' simon graphics image
Shared SimonHelp& ' simon help screen
Shared Keys&() ' keyboard key images 0=Q, 1=W, 2=S, 3=A
Shared Bslider& ' blue slider switch image
Shared Rslider& ' red slider switch image
Shared OnOff& ' on/off slider switch
Shared KeysXY%() ' location of keyboard key images
Shared Game% ' the position the blue slider switch is in (0-2)
Shared Skill% ' the position the red slider switch is in (0-3)
Shared GameDir% ' the direction blue slider switch will move (1, -1)
Shared SkillDir% ' the direction red slider switch will move (1, -1)
Shared Pcolor~&() ' color pad base colors: 0=BLUE, 1=RED, 2=GREEN, 3=YELLOW
Dim Sheet& ' sprite sheet containing game graphics
Dim Mask& ' color pad mask image
Dim Count% ' increasing color brightness counter
Dim Pcount% ' pad counter
Dim x% ' x location of pad circles
Dim y% ' y location of pad circles
Dim Clr~& ' temporary color pad color holder
'-------------
'- MAIN CODE -
'-------------
Randomize Timer ' seed random number generator
Tone&(0) = _SndOpen("SimonB209.ogg", "VOL,SYNC") ' load blue sound 209 Hz
Tone&(1) = _SndOpen("SimonR310.ogg", "VOL,SYNC") ' load red sound 310 Hz
Tone&(2) = _SndOpen("SimonG415.ogg", "VOL,SYNC") ' load green sound 415 Hz
Tone&(3) = _SndOpen("SimonY252.ogg", "VOL,SYNC") ' load yellow sound 252 Hz
Tone&(4) = _SndOpen("SimonL042.ogg", "VOL,SYNC") ' load lose sound 42 Hz
Simon& = _NewImage(242, 242, 32) ' simon image holder
Bslider& = _NewImage(57, 22, 32) ' blue slider image holder
Rslider& = _NewImage(57, 22, 32) ' red slider image holder
OnOff& = _NewImage(11, 11, 32) ' power button slider image holder
Sheet& = _LoadImage("SimonGFX.png", 32) ' load simon sprite sheet of images
SimonHelp& = _LoadImage("SimonHELP.png", 32) ' load simon help screen
_PutImage (0, 0), Sheet&, Simon&, (0, 94)-(241, 335) ' extract simon from spritesheet
_PutImage (0, 0), Sheet&, Bslider&, (200, 0)-(256, 21) ' extract blue slider from spritesheet
_PutImage (0, 0), Sheet&, Rslider&, (200, 22)-(256, 43) ' extract red slider from spritesheet
_PutImage (0, 0), Sheet&, OnOff&, (200, 44)-(210, 54) ' extract power button slider from spritesheet
For Count% = 0 To 3 ' cycle through 4 color pads
Pad&(Count%, 0) = _NewImage(320, 320, 32) ' create color pad off image
Pad&(Count%, 1) = _NewImage(320, 320, 32) ' create color pad on image
Keys&(Count%, 0) = _NewImage(50, 47, 32) ' create q,w,s,a raised key image holders
Keys&(Count%, 1) = _NewImage(50, 47, 32) ' create q,w,s,a pressed key image holders
_PutImage (0, 0), Sheet&, Keys&(Count%, 0), (Count% * 50, 0)-(Count% * 50 + 49, 46) ' extract key raised images
_PutImage (0, 0), Sheet&, Keys&(Count%, 1), (Count% * 50, 47)-(Count% * 50 + 49, 93) ' extract key pressed images
Next Count%
PadXY%(0, 0) = 0 ' color pad locations
PadXY%(0, 1) = 0
PadXY%(1, 0) = 320
PadXY%(1, 1) = 0
PadXY%(2, 0) = 320
PadXY%(2, 1) = 320
PadXY%(3, 0) = 0
PadXY%(3, 1) = 320
KeysXY%(0, 0) = 20 ' keyboard key image locations
KeysXY%(0, 1) = 20
KeysXY%(1, 0) = 570
KeysXY%(1, 1) = 20
KeysXY%(2, 0) = 570
KeysXY%(2, 1) = 573
KeysXY%(3, 0) = 20
KeysXY%(3, 1) = 573
Pcolor~&(0) = _RGB32(0, 0, 128) ' blue color of pad in off condition
Pcolor~&(1) = _RGB32(128, 0, 0) ' red color of pad in off condition
Pcolor~&(2) = _RGB32(0, 128, 0) ' green color of pad in off condition
Pcolor~&(3) = _RGB32(128, 128, 0) ' yellow color of pad in off condition
Game% = 0 ' set initial game level
Skill% = 0 ' set initial skill level
GameDir% = -1 ' set intial blue slider direction
SkillDir% = -1 ' set initial red slider direction
SIMONFILE 0 ' load longest tune ever played if available
'*
'* Create the eight semi-circle color pads, four off, four on
'*
For Pcount% = 0 To 3 ' cycle through four color pads
_Dest Pad&(Pcount%, 0) ' set color pad off image as destination
Cls ' remove black transparency
Select Case Pcount% ' which color pad is being worked on?
Case 0 ' blue color pad
x% = 319: y% = 319 ' set x,y coordinates of circles
Case 1 ' red color pad
x% = 0: y% = 319 ' set x,y coordinates of circles
Case 2 ' green color pad
x% = 0: y% = 0 ' set x,y coordinates of circles
Case 3 ' yellow color pad
x% = 319: y% = 0 ' set x,y coordinate of circles
End Select
Circle (x%, y%), 319, _RGB32(16, 16, 16) ' draw simon outer circle segment
Paint (x%, y%), _RGB32(16, 16, 16), _RGB32(16, 16, 16) ' paint simon color
Circle (x%, y%), 300, Pcolor~&(Pcount%) ' draw color pad outer circle segment
Circle (x%, y%), 140, Pcolor~&(Pcount%) ' draw color pad inner circle segment
Paint (159, 159), Pcolor~&(Pcount%), Pcolor~&(Pcount%) ' paint color pad circle segment interior
Line (x%, y%)-(Abs(319 - x%), Abs(10 - y%)), _RGB32(16, 16, 16), BF ' separate color pads horizontally
Line (x%, y%)-(Abs(10 - x%), Abs(319 - y%)), _RGB32(16, 16, 16), BF ' separate color pads vertically
Circle (x%, y%), 319, _RGB32(32, 32, 32) ' highlight edge of simon
Mask& = _CopyImage(Pad&(Pcount%, 0)) ' create an image mask
_Dest Mask& ' set the mask as the destination
_ClearColor Pcolor~&(Pcount%) ' set circle segment as transparent
_Dest Pad&(Pcount%, 1) ' set color pad on image as destination
Cls ' remove black transparency
Clr~& = Pcolor~&(Pcount%) ' remember color being worked on
Line (0, 0)-(319, 319), Clr~&, BF ' fill entire image with color pad color
For Count% = 129 To 255 ' cycle 126 times
Select Case Pcount% ' which color pad is being worked on?
Case 0 ' blue color pad
Clr~& = Clr~& + 1 ' increase blue component
Case 1 ' red color pad
Clr~& = Clr~& + 65536 ' increase red component
Case 2 ' green color pad
Clr~& = Clr~& + 256 ' increase green component
Case 3 ' yellow color pad
Clr~& = Clr~& + 65792 ' increase red and green component (yellow)
End Select
Circle (159, 159), (255 - Count%) * 2, Clr~& ' draw circle with new color component
Paint (159, 159), Clr~&, Clr~& ' paint inside circle new color component
Next Count%
_PutImage (0, 0), Mask& ' place mask over circles
Next Pcount%
_FreeImage Mask& ' remove mask image from RAM (no longer needed)
_FreeImage Sheet& ' remove spritesheet from RAM (no longer needed)
End Sub
'----------------------------------------------------------------------------------------------------------------------
' ENDGAME
Sub ENDGAME ()
'--------------------------------------------------------------------
'- Removes game's assets from RAM and returns to the operating system
'--------------------------------------------------------------------
Shared Pad&() ' color pads: 0,x=BLUE, 1,x=RED, 2,x=GREEN, 3,x=YELLOW
Shared Tone&() ' game sounds
Shared Simon& ' simon graphics image
Shared SimonHelp& ' simon help screen
Shared Keys&() ' keyboard key images 0=Q, 1=W, 2=S, 3=A
Shared Bslider& ' blue slider switch image
Shared Rslider& ' red slider switch image
Shared OnOff& ' on/off slider switch
Dim Count% ' generic counter
Line (321, 408)-(331, 418), _RGB32(0, 0, 0), BF ' clear power button
_PutImage (313, 408), OnOff& ' place power button in new position
_Display ' update screen with changes
For Count% = 0 To 3 ' cycle through assets
_SndClose Tone&(Count%) ' close sound files
_FreeImage Keys&(Count%, 0) ' remove key raised images
_FreeImage Keys&(Count%, 1) ' remove key pressed images
_FreeImage Pad&(Count%, 0) ' remove color pad unlit images
_FreeImage Pad&(Count%, 1) ' remove color pad lit images
Next Count%
_SndClose Tone&(4) ' close last sound file
_FreeImage Simon& ' remove simon image
_FreeImage SimonHelp& ' remove simon help screen image
_FreeImage Bslider& ' remove blue slider switch image
_FreeImage Rslider& ' remove red slider switch image
_FreeImage OnOff& ' remove on/off power switch image
_Delay 1 ' pause for 1 second
System ' return control to the operating system
End Sub
|
|
|
|
|
