+- QB64 Phoenix Edition (https://qb64phoenix.com/forum)
+-- Forum: QB64 Rising (https://qb64phoenix.com/forum/forumdisplay.php?fid=1)
+--- Forum: Code and Stuff (https://qb64phoenix.com/forum/forumdisplay.php?fid=3)
+---- Forum: Games (https://qb64phoenix.com/forum/forumdisplay.php?fid=57)
+---- Thread: Variations on Peg Solitaire (/showthread.php?tid=2915)
Variations on Peg Solitaire - PhilOfPerth - 08-08-2024
This game is another rendition of the old Peg Solitaire, with a few extra twists.
It uses a square grid, and players can choose between 3 modes, with horizontal+vertical jumps, diagonal jumps, or both, with a timer for each level. Hi-Scores are kept for the best 3 results for each mode. Score is based on pegs removed and time taken.
Code: (Select All)
SW = 1020: SH = 780 ' select window size
Screen _NewImage(SW, SH, 32)
Common Shared CPL, MX, MY, FROM, FromH, FromV, TOO, MidCell, TooH, Toov, Cells(), Mode, Score
Common Shared Best$(), T1, Name$, Distance, OK$, Bad$, Pick$, HiFrame$
Dim Cells(49, 5), Best$(18) ' each cell has 4 positions and a char-number
OK$ = "l32o3cg": Bad$ = "l16o1gc": Pick$ = "o4l54g": HiFrame$ = "r145d83l145u83"
Data "40","HAMMER","30","HAMMER","20","HAMMER","35","HAMMER","25","HAMMER","15","HAMMER","30","HAMMER","20","HAMMER","10","HAMMER"
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' monospace font
SMode = 32
CPL = SW / _PrintWidth("X") ' chars per line for this window width
lhs = (_DesktopWidth - CPL) / 2 ' position for LHS of window
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' place window there
Play OK$
PrepareBestList:
Cls
If Not (_FileExists("best")) Then ' if hi-score list is not found, create it
centre "Hi-Score list refreshed", 14: Play OK$: Sleep 1: Restore
refreshed = 1
ReDim Best$(18)
Open "best" For Output As #1
For a = 1 To 18
Read Best$(a)
Write #1, Best$(a)
Next
Close
End If
Open "best" For Input As #1
For a = 1 To 18: Input #1, Best$(a): Next ' place hi-scores in Best$()
Close
Intro
ShowBest
KeepOrKill:
If refreshed = 0 Then
k$ = ""
Yellow: centre "Keep these records (y/n) ?", 37
While k$ = "": k$ = InKey$: Wend
If UCase$(k$) = "N" Then
Kill "best": GoTo PrepareBestList ' if not wanted, delete and create a new one
End If
Cls
End If
Cls
Play OK$
PlayerPrefs:
centre "Your name (to 6 characters) ? ", 12 ' spaces move centre to left
Locate 12, 48: Input Name$
If Len(Name$) > 6 Then
Name$ = Left$(Name$, 6)
Else If Len(Name$) < 2 Then Name$ = "ANON"
End If
Name$ = UCase$(Name$): WIPE "12": centre Name$, 12
Play OK$
Sleep 1
Cls
centre "Select a mode (1 to 3)", 14: Sleep
While k$ < "1" And k$ > "3": Wend
k$ = InKey$
Mode = Val(k$)
Cls
SetPegs: ' 7*7 cells, 5 elements each
For a = 0 To 6
For b = 0 To 6
Cells(a * 7 + b + 1, 1) = a * 52 + 314 ' 1st element left top of cell
Cells(a * 7 + b + 1, 2) = a * 52 + 366 ' 2nd elementright top of cell
Cells(a * 7 + b + 1, 3) = b * 40 + 48 ' 3rd element left bottom of cell
Cells(a * 7 + b + 1, 4) = b * 40 + 88 ' 4th element right bottom of cell
'Set Cells(49,5) for all cells to 42
Cells(a * 7 + b + 1, 5) = 42 ' 5th element chr$(42) * in all cells
Next
Next
SetVacantCell: ' Select Vacant cell, not on edge of grid
Do
vac = Int(Rnd * 33) + 9 ' select (random) empty cell
Loop Until vac Mod (7) <> 0 And vac Mod (7) <> 1 ' if this is an edge cell, try again
vacv = 3 + Int(vac / 7) * 2 + 1 ' vacant cell vertical position in grid
vach = 19 + (vac Mod (7) + 1) * 4 ' vacant cell horizontal position in grid
Cells(vac, 5) = 32 ' mark vac as vacant in cells() array
Cells(vac, 5) = 32 ' mark vacant cell as chr$(32) space in cells() (32 is space)
ShowCells:
For a = 1 To 7 ' for each row of grid
For b = 1 To 7 ' for each cell of row
Locate 2 + a * 2, 23 + b * 4: Print "*" ' fill all with *
Next
Next
Green
Locate vacv, vach: Print "O" ' place green O in vacant cell to identify it
DrawGridFrame:
Play OK$
Yellow
H = 22 ' start frame from horizontal 22
For a = 0 To 6 ' 7 horizontal squares in frame
For b = 0 To 6 ' 7 vertical rows of squares
PSet (a * 52 + 316, b * 40 + 48)
Draw "r52d40l52u40"
Next
Next
ShowEnd:
Locate 18, 38: Print "END" ' show END cell
Yellow
PSet (473, 330): Draw "r52d36l52u36" ' draw END frame
ShowBest
T1 = Timer ' start timer
txt$ = "Mode" + Str$(Mode) + " selected"
centre txt$, 24
ChooseFROM:
GetFrom ' call sub to select FROM cell
If FROM < 0 Then Play Bad$: GoTo ChooseFROM
If FROM = 50 Then Done
ChooseTO:
GetToo
If TOO <= 0 Then Play Bad$: GoTo ChooseFROM
If TOO = 50 Then Done
FindMidCell
If Distance = 0 Then Play Bad$: GoTo ChooseFROM
ChangeCells
CalcScore
GoTo ChooseFROM
' *** Subs below here ***
Sub CreateBest
If _FileExists("best") Then Kill "best"
Restore
ReDim Best$(18)
Open "best" For Output As #1
For a = 1 To 18
Read Best$(a)
Write #1, Best$(a)
Next
Close
'End If
Open "best" For Input As #1
For a = 1 To 18: Input #1, Best$(a): Next
Close
End Sub
Sub ShowBest
Yellow: centre "Scores to Beat", 30
Locate 32, 17
Print "Mode 1"; Tab(37); "Mode 2"; Tab(57); "Mode 3": White
For a = 0 To 2
For b = 1 To 5 Step 2
Locate 33 + a, 10 * b + 4
Print Best$(a * 6 + b); Tab(10 * b + 8); Best$(a * 6 + b + 1)
Next
Next
Yellow: PSet (160, 618): Draw HiFrame$: PSet (420, 618): Draw HiFrame$: PSet (680, 618): Draw HiFrame$
End Sub
Sub GetFrom:
centre "Choose FROM location", 20
Do
While _MouseButton(1): m% = _MouseInput: Wend ' wait for left-mouse to restore
m% = _MouseInput ' prepare mouse
If _MouseButton(1) Then ' get left-mouse status
MX = _MouseX: MY = _MouseY ' horiz and vert position
If MX > 473 And MX < 526 And MY > 330 And MY < 371 Then FROM = 50: Exit Sub ' END cell, mark FROM as 50
If MX < 316 Or MX > 680 Or MY < 48 Or MY > 328 Then FROM = -2: Exit Sub ' outside the grid, mark FROM as -2
FromH = Int((MX - 316) / 52) + 1 ' horiz column of FROM cell
FromV = Int((MY - 48) / 40) + 1 ' vert row of FROM cell
FROM = (FromV - 1) * 7 + FromH ' number of FROM cell, 1 to 49
If Cells(FROM, 5) = 32 Then FROM = -1: Exit Sub ' vacant cell, mark From as -1
End If
Loop Until _MouseButton(1)
Play Pick$
End Sub
Sub GetToo
WIPE "20": centre "Choose TO location", 20
Do
While _MouseButton(1): m% = _MouseInput: Wend ' wait for left-mouse to restore
m% = _MouseInput ' prepare mouse
If _MouseButton(1) Then ' get left-mouse status
MX = _MouseX: MY = _MouseY ' horiz and vert position
If MX > 473 And MX < 526 And MY > 330 And MY < 371 Then TOO = 50: Exit Sub ' END cell, mark FROM as 50
If MX < 316 Or MX > 680 Or MY < 48 Or MY > 328 Then TOO = -2: Exit Sub ' outside the grid, mark FROM as -2
TooH = Int((MX - 316) / 52) + 1 ' horiz column of FROM cell
Toov = Int((MY - 48) / 40) + 1 ' vert row of FROM cell
TOO = (Toov - 1) * 7 + TooH ' number of FROM cell, 1 to 49
If Cells(TOO, 5) <> 32 Then TOO = -1: Exit Sub ' vacant cell, mark From as -1
End If
Loop Until _MouseButton(1)
Play Pick$
End Sub
Sub FindMidCell
Distance = Abs(FROM - TOO) ' FROM and TOO are selected cell numbers
CheckDistance: ' check relative positions of cells
Select Case Mode
Case 1 ' 2 horiz, vert or diag is +/- 2, 12, 14 or 16
If Distance <> 2 And Distance <> 12 And Distance <> 14 And Distance <> 16 Then
Distance = 0
Red: centre "Cells must be 2 cells apart", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
Case 2 ' 2 horiz or vert is +/-2 or 14
If Distance <> 2 And Distance <> 14 Then
Distance = 0
centre "Horizontal or vertical hops of 2 cells only", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
Case 3 ' 2 diag is +/- 12 or 16
If Distance <> 12 And Distance <> 16 Then
Distance = 0
Red: centre "Diagonal hops of 2 cells only", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
End Select
MidCell = (FROM + TOO) / 2: MidCellv = (FromV + Toov) / 2 + 4: MidCellh = (FromH + TooH) / 2 + 4
If Cells(MidCell, 5) = 32 Then
Distance = 0
Red: centre "Middle cell must be occupied!", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub ' if not, get another FROM cell
End If
End Sub
Sub ChangeCells ' update grid display
Cells(FROM, 5) = 32
Cells(MidCell, 5) = 32
Cells(TOO, 5) = 42
ShowChanges: ' show changed pegs
Yellow
Locate FromV * 2 + 2, FromH * 4 + 23: Print " "
Locate Toov * 2 + 2, TooH * 4 + 23: Print "*"
Locate (FromV * 2 + 2 + Toov * 2 + 2) / 2, (FromH * 4 + 23 + TooH * 4 + 23) / 2: Print " "
End Sub
Sub CalcScore ' update score
WIPE "2628"
Picks = Picks + 1
Score = Picks * 10 + Int(T1 - Timer)
txt$ = "Score:" + Str$(Score)
centre txt$, 26
txt$ = "Pegs Remaining:" + Str$(48 - Picks)
centre txt$, 28
Play OK$
End Sub
Sub Done ' Player has finished
Cls
Play OK$: Play OK$
txt$ = "You scored " + LTrim$(Str$(Score))
centre txt$, 17
CheckHi
Sleep: Run
End Sub
Sub CheckHi
txt$ = "Checking against Hi-Scores for Mode" + Str$(Mode) + "..."
centre txt$, 19
win = 0
sc1 = 1 + (Mode - 1) * 2: nm1 = 2 + (Mode - 1) * 2
sc2 = 7 + (Mode - 1) * 2: nm2 = 8 + (Mode - 1) * 2
sc3 = 13 + (Mode - 1) * 2: nm3 = 14 + (Mode - 1) * 2
Select Case Score
Case Is > Val(Best$(sc1)) ' better than first - move 2nd down, 1st down, place score and name in 1st
Best$(sc3) = Best$(sc2): Best$(nm3) = Best$(nm2)
Best$(sc2) = Best$(sc1): Best$(nm2) = Best$(nm1)
Best$(sc1) = LTrim$(Str$(Score)): Best$(nm1) = Name$
win = 1: txt$ = "Congratulations, you beat First place"
Case Is = Val(Best$(sc1)), Is > Val(Best$(sc2)) ' better than second - move 2nd down, place score and name in 2nd
Best$(sc3) = Best$(sc2): Best$(nm3) = Best$(nm2)
Best$(sc2) = LTrim$(Str$(Score)): Best$(nm2) = Name$
win = 1: txt$ = "Congratulations, you beat Second place"
Case Is = Val(Best$(sc2)), Is > Val(Best$(sc3)) ' better than third - place score and name in 3rd
Best$(sc3) = LTrim$(Str$(Score)): Best$(nm3) = Name$
win = 1: txt$ = "Congratulations, you beat Third place"
End Select
If win = 1 Then
centre txt$, 21: Sleep 3: Cls
Open "best" For Output As #1
For a = 1 To 18: Write #1, Best$(a): Next ' save new Best score
Close
End If
ShowBest: Sleep 3: Run
End Sub
Sub White
Color _RGB(255, 255, 255)
End Sub
Sub Red
Color _RGB(255, 0, 0)
End Sub
Sub Green
Color _RGB(0, 255, 0)
End Sub
Sub Yellow
Color _RGB(255, 255, 0)
End Sub
Sub centre (txt$, linenum) ' centres text on selected line
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1 ' centre is half of chars per line minus half string-length
Locate linenum, ctr
Print txt$
End Sub
Sub WIPE (ln$) ' (ln$ is string of 2-digit line-numbers) "0122" wold mean lines 1 and 22
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2)) ' get 2 digits of line to be wiped (wl),
Locate wl, 1: Print Space$(CPL); ' and write full row of spaces to that line
Next
End Sub
Sub Intro
'Show intro text
Yellow
centre "LeapFrog", 2: White: Print: Print
Print " A board of 7x7 cells is displayed, all except one occupied by pegs."
Print " Remove as many pegs as you can, by hopping another peg over them, as"
Print " quickly as you can. Hops may be in any direction (but see";: Yellow: Print " Modes";: White: Print " below),"
Print " over a single occupied cell, and the landing cell must be vacant.": Print
Print " With the mouse, choose a ";: Yellow: Print "FROM";: White: Print " cell, then a ";: Yellow
Print "TO";: White: Print " cell, with one occupied"
Print " cell between them. If these conditions are met, the cell between them"
Print " is cleared, and the action can be repeated. Otherwise, the move is"
Print " rejected, and you must try again with different cells."
Print " Select the ";: Yellow: Print "END ";: White:
Print " cell when you can find no more moves.": Print
Print " You receive ten points for each hop, but the final score is reduced by"
Print " one point per second of game time, so you need to be quick!"
Print " Or you can ignore the timer and just play to remove maximum pegs.": Print
Yellow: centre "Modes", 20: White
Print " There are 3 Modes of play, each with different directions for hops:"
Print " 1: Hop in any direction, horizontal, vertical or diagonal (Easy)"
Print " 2: Horizontal or vertical hops only, any of four directions (Medium)"
Print " 3: Diagonal hops only, any of four directions (Hard).": Print
Print " A Hi-score list of the three best results for each mode is kept, and"
Print " if you beat one of these, your result will be placed on this list."
End Sub