03-21-2025, 02:12 AM
This is a rendition of the old PegBoard game, with a few little additions
Thanks to DSMan and bplus for assistance with scoring.
Thanks to DSMan and bplus for assistance with scoring.
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, T2, Name$, Distance, OK$, Bad$, Pick$, HiFrame$, Picks
Dim Cells(49, 5), Best$(18) ' each cell has 4 positions and a char-number
OK$ = "l32o3cg": Bad$ = "l16o1gc": Pick$ = "l32o3g": HiFrame$ = "r145d83l145u83"
Data "435","DEFLT","290","DEFLT","220","DEFLT","395","DEFLT","265","DEFLT","200","DEFLT","135","DEFLT","90","DEFLT","68","DEFLT"
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
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) ' create new hi-scores file for this mode
Next
Close
Run
End If
Open "best" For Input As #1
For a = 1 To 18: Input #1, Best$(a): Next ' get hi-scores from file
Close
Intro
ShowBest ' display hi-scores for all modes
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 these hi-scores not wanted, replace with defaults
Run
End If
Cls
End If
Cls
Play OK$
PlayerName:
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" ' if no name given, use default
End If
Name$ = UCase$(Name$): WIPE "12": centre Name$, 12
Play OK$
_Delay .5
Cls
ChooseMode:
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: ' 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 = 25 ' 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)
ShowPegs:
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
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
Locate 18, 38: Print "END" ' show END cell
Yellow
PSet (473, 330): Draw "r52d36l52u36" ' draw END frame
ShowBest
txt$ = "Mode" + Str$(Mode) + " selected"
centre txt$, 24
Select Case Mode
Case Is = 1
centre "Jump in ANY direction", 25
Case Is = 2
centre "Jump Vertically or Horizontally only", 25
Case Is = 3
centre "Jump DIAGONALLY only", 25
End Select
T1 = Timer
ChooseFrom:
GetFrom ' call sub to select FROM cell
If FROM = 50 Then Done ' clicked in the END cell
If FROM <= 0 Then GoTo ChooseFrom
ChooseToo: ' TO is a keyword so use TOO
Play Pick$
GetToo
If Too = 50 Then Done ' clicked in the END cell
If Too <= 0 Then Play Bad$: GoTo ChooseFrom
FindMidCell
If Distance = 0 Then GoTo ChooseFrom
ChangeCells
Picks = Picks + 1
CalcScore
GoTo ChooseFrom
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 "Hi-Scores", 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)
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 ' horiz, vert or diag 2 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 ' horiz or vert 2 is +/-2 or 14
If Distance <> 2 And Distance <> 14 Then
Distance = 0
Red: centre "Horizontal or vertical hops of 2 cells only", 22
Play Bad$: Sleep 2: Yellow
WIPE "22": Exit Sub
End If
Case 3 ' diag 2 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"
Score = Picks * 20
txt$ = "Points:" + Str$(Score)
WIPE "27": centre txt$, 27
Play OK$
Print
End Sub
Sub Done ' Player has finished
Cls
T2 = Timer
Score = Score - Int((T2 - T1) / 30) ' calculate time adjustment
Play OK$: Play OK$
txt$ = "After Time adjustment, 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)) ' beat first
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$(sc2)) ' beat second
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$(sc3)) ' beat third
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 ' horiz centre
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 twenty points for each hop, reduced by one point for each"
Print " 30 seconds. This means a ";: Yellow: Print "PERFECT";: White: Print " score of 940 points for any mode can"
Print " only be achieved by removing all but the last peg within 30 seconds"
Print " (but good luck with that!)": 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 in 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/
857 on my second. 