08-08-2024, 09:32 AM
(This post was last modified: 08-08-2024, 09:34 AM by PhilOfPerth.)
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.
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
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/