12-22-2025, 09:56 AM
(This post was last modified: 12-22-2025, 09:58 AM by PhilOfPerth.)
This is my version of the old "Peg Solitaire" game. It has a few changes, including a timer and 3 different "modes" and Hi-scores which are all explained inside the game.
Code: (Select All)
SW = 1020: SH = 780
Screen _NewImage(SW, SH, 32)
Common Shared CPL, MX, MY, From, FromH, FromV, Too, MidCell, TooH, Toov, Cells(), Mode, Score
Common Shared Best$(), T1, T2, Name$, Distance, OK$, Bad$, Pick$, HiFrame$
Dim Cells(49, 5), Best$(9, 2)
OK$ = "v100o3t255msl64eeeeeffffffp4" ' croak
Bad$ = "l16o1gc": Pick$ = "l32o3g"
HiFrame$ = "r198d62l198u62" ' frame for hi-scores
Data "100","???","60","???","50","???"
Data "80","???","50","???","40","???"
Data "60","???","40","???","30","???"
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&
SMode = 32
CPL = SW / _PrintWidth("X")
lhs = (_DesktopWidth - CPL) / 2
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' centre the screeen
PrepareBestList: ' ensure Best Scores records are present
If Not (_FileExists("LFBest.txt")) Then
Open "LFBest.txt" For Output As #1
For a = 1 To 9
Read Best$(a, 1), Best$(a, 2)
Write #1, Best$(a, 1), Best$(a, 2)
Next
centre "Hi-Score list refreshed", 14: Play OK$: Sleep 1
refreshed = 1
Close
Run
End If
LoadBest:
Open "LFBest.txt" For Input As #1
For a = 1 To 9
Input #1, Best$(a, 1), Best$(a, 2)
Next
Close
Intro
For a = 1 To 3: Play OK$: Next
ShowBest ' display Best Scores records
KeepOrKill: ' option to refresh Best Scores records
If refreshed = 0 Then
k$ = ""
Yellow: centre "Keep these records (y/n) ?", 37
While k$ = "": k$ = InKey$: Wend
If UCase$(k$) = "N" Then
Kill "LFBest.txt": GoTo PrepareBestList ' wipe old records, go back to create new ones
Run
End If
Cls
End If
Cls
Play OK$
PlayerName:
centre "Your name (to 6 characters) ? ", 12
Locate 12, 48: Input Name$
If Len(Name$) > 6 Then Name$ = Left$(Name$, 6)
If Len(Name$) < 2 Then Name$ = "ANON" ' default names if none entered
Name$ = UCase$(Name$): WIPE "12": centre Name$, 12
Play OK$
_Delay .5
Cls
ChooseMode: ' all directions, horiz & vert, or diagonal
centre "Select a mode (1 to 3)", 14: Sleep
While k$ < "1" And k$ > "3": Wend
k$ = InKey$
Mode = Val(k$)
If Mode < 1 Or Mode > 3 Then Mode = 1
Cls
SetPegs: ' location and place * for peg in each cell
For a = 0 To 6
For b = 0 To 6
Cells(a * 7 + b + 1, 1) = a * 52 + 314
Cells(a * 7 + b + 1, 2) = a * 52 + 366
Cells(a * 7 + b + 1, 3) = b * 40 + 48
Cells(a * 7 + b + 1, 4) = b * 40 + 88
Cells(a * 7 + b + 1, 5) = 42 ' place stars in array for all cells
Next
Next
SetVacantCell:
Vac = 25 ' identify centre (vacant) cell as cell 25
Do
Loop Until Vac Mod (7) <> 0 And Vac Mod (7) <> 1
vacv = 3 + Int(Vac / 7) * 2 + 1
vach = 19 + (Vac Mod (7) + 1) * 4
Cells(Vac, 5) = 32
Cells(Vac, 5) = 32
ShowPegs:
For a = 1 To 7
For b = 1 To 7
Locate 2 + a * 2, 23 + b * 4: Print "*" ' display stars in all cells
Next
Next
Green
Locate vacv, vach: Print "O" ' display o in empty cell
Yellow
H = 22
For a = 0 To 6
For b = 0 To 6
PSet (a * 52 + 316, b * 40 + 48)
Draw "r52d40l52u40" ' boxes for Best Scores tables
Next
Next
Locate 18, 38: Print "END"
Yellow
PSet (473, 330): Draw "r52d36l52u36" ' box for END button
ShowBest
txt$ = "Mode" + Str$(Mode) + " selected"
centre txt$, 24
Select Case Mode
Case Is = 1
centre "Leap in ANY direction", 25
Case Is = 2
centre "Leap Vertically or Horizontally only", 25
Case Is = 3
centre "Leap DIAGONALLY only", 25
End Select
T1 = Timer ' start timer
ChooseFrom:
GetFrom ' click the FROM cell
If From = 50 Then Done ' if END cell is clicked, finish
If From <= 0 Then GoTo ChooseFrom ' ignore clicks outside the grid
ChooseToo:
Play Pick$
GetToo ' click the TOO cell
If Too = 50 Then Done
If Too <= 0 Then Play Bad$: GoTo ChooseFrom ' bad click, back to choose FROM
FindMidCell ' find number and position of cell to remove
If Distance = 0 Then GoTo ChooseFrom ' if failed, go back to choose FROM
ChangeCells ' show changes and change array data
Score = Score + 20
txt$ = "Points:" + Str$(Score)
WIPE "27": centre txt$, 27
Play OK$
GoTo ChooseFrom
Sub CreateBest
If _FileExists("LFBest.txt") Then Kill "LFBest.txt"
Restore
Open "LFBest.txt" For Output As #1
For a = 1 To 3
For b = 1 To 3
For c = 1 To 2
Read Best$(a, b)
Write #1, Best$(a, b)
Next
Next
Next
Close
End Sub
Sub ShowBest
Yellow: centre "Hi-Scores", 30
Locate 31, 17
Print "Mode 1"; Tab(37); "Mode 2"; Tab(57); "Mode 3": White
WIPE "323334"
For a = 1 To 3
For b = 1 To 3
For c = 1 To 2
Locate 31 + a, 7 + (b - 1) * 20 + c * 6
Print Best$((a - 1) * 3 + b, c)
Next
Next
Next
Yellow: PSet (148, 618): Draw HiFrame$: PSet (407, 618): Draw HiFrame$: PSet (667, 618): Draw HiFrame$
End Sub
Sub GetFrom:
centre "Choose From location", 20
Do
While _MouseButton(1): m% = _MouseInput: Wend
m% = _MouseInput
If _MouseButton(1) Then
MX = _MouseX: MY = _MouseY
If MX > 473 And MX < 526 And MY > 330 And MY < 371 Then From = 50: Exit Sub '
If MX < 316 Or MX > 680 Or MY < 48 Or MY > 328 Then From = -2: Exit Sub
FromH = Int((MX - 316) / 52) + 1 ' horiz position of FROM cell
FromV = Int((MY - 48) / 40) + 1 ' vert position of TOO cell
From = (FromV - 1) * 7 + FromH
If Cells(From, 5) = 32 Then From = -1: Exit Sub
End If
Loop Until _MouseButton(1)
End Sub
Sub GetToo ' (call it TOO as TO is a keyword)
WIPE "20": centre "Choose TO location", 20
Do
While _MouseButton(1): m% = _MouseInput: Wend
m% = _MouseInput
If _MouseButton(1) Then
MX = _MouseX: MY = _MouseY
If MX > 473 And MX < 526 And MY > 330 And MY < 371 Then Too = 50: Exit Sub ' clicked END button - mark as cell 50
If MX < 316 Or MX > 680 Or MY < 48 Or MY > 328 Then Too = -2: Exit Sub ' clicked outside the grid
TooH = Int((MX - 316) / 52) + 1 ' horiz position of TOO cell
Toov = Int((MY - 48) / 40) + 1 ' vert position of TOO cell
Too = (Toov - 1) * 7 + TooH ' cell number
If Cells(Too, 5) <> 32 Then Too = -1: Exit Sub ' if TO cell is not empty, fail, try again
End If
Loop Until _MouseButton(1)
Play Pick$
End Sub
Sub FindMidCell ' identify cell between FROM and TOO
Distance = Abs(From - Too) ' how far apart the cells are by number
CheckDistance:
Select Case Mode
Case 1 ' leaps in any direction
If Distance <> 2 And Distance <> 12 And Distance <> 14 And Distance <> 16 Then ' hor/vert +/- 2 or +/- 12, diag +/- 14 or +/- 16
Distance = 0 ' if none of these, fail,try again
Red: centre "Cells must be 2 cells apart", 22
Play Bad$: Sleep 1: Yellow
WIPE "22": Exit Sub
End If
Case 2 ' horiz and vert leaps only
If Distance <> 2 And Distance <> 14 Then
Distance = 0
Red: centre "Horizontal or vertical hops of 2 cells only", 22
Play Bad$: Sleep 1: Yellow
WIPE "22": Exit Sub
End If
Case 3 ' diag leaps only
If Distance <> 12 And Distance <> 16 Then
Distance = 0
Red: centre "Diagonal hops of 2 cells only", 22
Play Bad$: Sleep 1: Yellow
WIPE "22": Exit Sub
End If
End Select
MidCell = (From + Too) / 2 ' mid cell number
MidCellv = (FromV + Toov) / 2 + 4: MidCellh = (FromH + TooH) / 2 + 4 ' mid cell position
If Cells(MidCell, 5) = 32 Then ' check if peg still there
Distance = 0 ' if not, fail, try again
Red: centre "Middle cell must be occupied!", 22
Play Bad$: Sleep 1: Yellow
WIPE "22": Exit Sub
End If
End Sub
Sub ChangeCells
Cells(From, 5) = 32 ' mark FROM cell empty in array
Cells(MidCell, 5) = 32 ' mark MidCell emty in array
Cells(Too, 5) = 42 ' mark TOO cell occupied in array
ShowChanges:
Yellow
Locate FromV * 2 + 2, FromH * 4 + 23: Print " " ' show these changes in the grid
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 Done
T2 = Timer
Play OK$: Play OK$
Cls
txt$ = "You cleared" + Str$(Score / 20) + " pegs, scoring" + Str$(Score) + " points"
centre txt$, 12
txt$ = "Time spent was" + Str$(Int(T2 - T1)) + " seconds "
centre txt$, 14
Score = Score - Int((T2 - T1) / 5)
txt$ = "After Time adjustment, you scored " + LTrim$(Str$(Score))
centre txt$, 16
Sleep 3
FindPlace:
Select Case Score
Case Is > Val(Best$(Mode, 1))
Best$(Mode + 6, 1) = Best$(Mode + 3, 1): Best$(Mode + 6, 2) = Best$(Mode + 3, 2)
Best$(Mode + 3, 1) = Best$(Mode, 1): Best$(Mode + 3, 2) = Best$(Mode, 2)
Best$(Mode, 1) = LTrim$(Str$(Score)): Best$(Mode, 2) = Name$
Case Is > Val(Best$(Mode + 3, 1))
Best$(Mode + 6, 1) = Best$(Mode + 3, 1): Best$(Mode + 6, 2) = Best$(Mode + 3, 2)
Best$(Mode + 3, 1) = LTrim$(Str$(Score)): Best$(Mode + 3, 2) = Name$
Case Is > Val(Best$(Mode + 6, 1))
Best$(Mode + 6, 1) = LTrim$(Str$(Score)): Best$(Mode + 6, 2) = Name$
End Select
Open "LFBest.txt" For Output As #1
For a = 1 To 9: Write #1, Best$(a, 1), Best$(a, 2): Next
Close
MoveOn:
Locate 23, 1
ShowBest: Sleep: 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)
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1
Locate linenum, ctr
Print txt$
End Sub
Sub WIPE (ln$)
For a = 1 To Len(ln$) - 1 Step 2
WL = Val(Mid$(ln$, a, 2))
Locate WL, 1: Print Space$(CPL);
Next
End Sub
Sub Intro
Yellow
centre "LeapFrog", 2: White: Print
Print " A board of 7x7 cells is displayed, all except one occupied by pegs."
Print " Remove as many pegs as you can, by leaping another peg over them, as"
Print " quickly as you can. Leaps 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
Print " Select the ";: Yellow: Print "END ";: White: Print "cell when you can find no more moves."
Print " You score twenty points for each leap, but your final score is reduced"
Print " by one point for each five seconds of play."
: 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). A Hi-score"
Print " list of the three best results for each mode is kept, and if you beat"
Print " one of these, your result will be placed in this list."
End Sub
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/