OmniPeg

[PhilOfPerth]

Here is my version of the Peg Solitaire game, which has a couple of twists to the original. 
Coding is not economized, and could be probably halved by some members (?), but it works.

Code: (Select All)

Screen _NewImage(1024, 820, 32)
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 24, "monospace") '                                                 31 rows, 73 columns text, allows chr$(95)
_Font f&
dw = _DesktopWidth: dh = _DesktopHeight
lhs = (dw - 1024) / 2: top = 100
_ScreenMove lhs, top '                                                                                                     centre display horiz on screen, down 100

Common Shared board$(), cell$, v, h, pick$, bad$, Mode, score
Dim board$(7, 7)
pick$ = "o2l32dg": ok$ = "l32o2cego3c": bad$ = "l32o2co1bagfedc"

Intro:
yellow
Locate 4, 30: Print "Peg Solitaire": white
Locate 7, 1
Print " A board of 49 cells is displayed, with 48 of these occupied by pegs."
Print " Try to remove all pegs (except one) by jumping another peg over them."
Print " Jumps may be in any direction (but see ";: yellow: Print "Modes";: white: Print " below), over a single"
Print " peg, and the landing cell must be vacant."
Print
Print " Enter each jump as a ";: yellow: Print "FROM";: white: Print ", then a";
yellow: Print " TO";: white: Print " row and column e.g. A3, then C5."
Print " Each move must jump 2 cells, over an existing ";: yellow: Print "REMOVE";: white: Print " peg."
Print
Print " The FROM and REMOVE cells must be occupied, and the ";: yellow: Print "TO";: white: Print " cell must be"
Print " empty, otherwise the move is rejected."
Print
Print " If legal, the REMOVE cell is cleared, and the action can be repeated"
Print " until no more jumps are possible."
Print
Print " There are 3 ";: yellow: Print "Modes";: white: Print " of play, each with different directions for jumps:"
Print "  1: Jump in any direction   2: Hor and Vert only   3: Diagonal only."
Print Tab(12); "(Mode 1 is a simple version, mostly for children)."
yellow: Print: Print Tab(24); " Which Mode would you like?"

GetMode:
k$ = InKey$
If k$ = "" Then GoTo GetMode
If k$ <= "1" Or k$ > "3" Then Mode = 1 Else Mode = Val(k$)
Cls

drawgrid

Locate 2, 32: Print "Mode"; Mode

GetFrom:
_KeyClear
Locate 26, 32: Print "Score:"; score
WIPE "2829": Play pick$
white: Locate 28, 24: Print "Input ";: yellow: Print "FROM";: white: Print " as VH (e.g. A3)"
Print Tab(30); "or Q to quit"
Locate 28, 50: Input cell$
cell$ = UCase$(cell$)
If cell$ = "Q" Then Finish
v = Asc(Left$(cell$, 1)) - 64: h = Val(Right$(cell$, 1))

CheckFROM:
If Len(cell$) <> 2 Or Left$(cell$, 1) < "A" Or Left$(cell$, 1) > "G" Or Val(Right$(cell$, 1)) < 1 Or Val(Right$(cell$, 1)) > 7 Then
    fromfailed:
    WIPE "28": Locate 28, 13: red: Print "FROM must be entered as VH (vert and horiz) e.g. A3"
    Play bad$: yellow: Sleep 1: WIPE "28": GoTo GetFrom
Else
    fromv = Asc(Left$(cell$, 1)) - 64: fromh = Val(Right$(cell$, 1))
End If

FROMcontent:
If board$(fromv, fromh) = " " Then
    WIPE "28": Locate 28, 27: red: Print "That cell is empty"
    Play bad$: yellow: Sleep 1: WIPE "28": GoTo GetFrom
End If

AcceptFROM: '                                                                                                                     FROM meets specs
red: Locate 8 + (fromv - 1) * 2, 27 + (fromh - 1) * 3: Print Chr$(249): yellow
WIPE "24"
white: Locate 24, 33: Print cell$; " -"

GetTO:
WIPE "28": Play pick$
Locate 28, 25: Print "Input ";: yellow: Print "TO";: white: Print " as VH (e.g. A3)"; Tab(21); "(or <Space> to restart this move)"
Locate 28, 49: Input cell$
cell$ = UCase$(cell$)
Locate 24, 38: Print cell$

Restart: '                                                                                                                  player pressed <Space> to restart their move
If cell$ = " " Then
    yellow: Locate 8 + (fromv - 1) * 2, 27 + (fromh - 1) * 3: Print "*"
    board$(fromv, fromh) = "*"
    Play bad$: yellow: Sleep 1: WIPE "2428": GoTo GetFrom
End If

v = Asc(Left$(cell$, 1)) - 64: h = Val(Right$(cell$, 1))

tov = v: toh = h '                                                                                                           we have fromh, fromv, toh and tov to identify middle cell

CheckTOchars:
If Len(cell$) <> 2 Or Left$(cell$, 1) < "A" Or Left$(cell$, 1) > "H" Or Right$(cell$, 1) < "1" Or Right$(cell$, 1) > "8" Then
    WIPE "28": Locate 28, 13: red: Print "TO must be entered as vh (vert and horiz) e.g. C5"
    Play bad$: yellow: Sleep 1: WIPE "28": Locate 24, 38: Print "      ": GoTo GetTO
End If

CheckJump:
Select Case Mode
    Case 1 ' children
        fail = 0
        If Abs(fromv - tov) = 2 And (Abs(fromh - toh) <> 2 And Abs(fromh - toh) <> 0) Then fail = 1
        If fromv - tov = 0 And Abs(fromh - toh) <> 2 Then fail = 1
        If fail = 1 Then
            WIPE "28": Locate 28, 22: red: Print "Jump must be exactly 2 cells"
            Play bad$: yellow: Sleep 1: WIPE "28": Locate 24, 38: Print "      ": GoTo GetTO
        End If

    Case 2 ' horiz and vert
        fail = 0
        If ((Abs(fromv - tov) = 2 And Abs(fromh - toh) <> 0)) Or ((Abs(fromv - tov) = 2 And Abs(fromh - toh) <> 0)) Then
            WIPE "28": Locate 28, 14: red: Print "Jump must be 2 cells, vertically or horizontally"
            Play bad$: yellow: Sleep 1: WIPE "28": Locate 24, 38: Print "      ": GoTo GetTO
        End If

    Case 3 ' diag
        fail = 0
        If Abs(fromv - tov) <> 2 Or Abs(fromh - toh) <> 2 Then fail = 1
        If fail = 1 Then
            WIPE "28": Locate 28, 20: red: Print "Jump must be 2 cells, diagonally"
            Play bad$: yellow: Sleep 1: WIPE "28": Locate 24, 38: Print "      ": GoTo GetTO
        End If

End Select

CheckMiddleCell:
If fromv < tov Then midlv = fromv + 1
If fromv = tov Then midlv = fromv
If fromv > tov Then midlv = fromv - 1
If fromh < toh Then midlh = fromh + 1
If fromh = toh Then midlh = fromh
If fromh > toh Then midlh = fromh - 1


If board$(midlv, midlh) <> "*" Then
    WIPE "28": Locate 28, 25: red: Print "The jumped cell is not occupied"
    Play bad$: yellow: Sleep 1: WIPE "28": Locate 24, 38: Print "      ": GoTo GetTO
End If



TOcontent:
If oard$(tov, toh) = "*" Then
    WIPE "28": Locate 28, 25: red: Print "That cell is occupied"
    Play bad$: yellow: Sleep 1: WIPE "28": Locate 24, 38: Print "      ": GoTo GetTO

Else
    ShowMove:
    yellow
    Locate 8 + (tov - 1) * 2, 27 + (toh - 1) * 3: Print "*"
    Locate 8 + (fromv - 1) * 2, 27 + (fromh - 1) * 3: red: Print " "
    Locate 8 + (midlv - 1) * 2, 27 + (midlh - 1) * 3: red: Print " "

    ChangeBoard:
    board$(fromv, fromh) = " ": board$(tov, toh) = "*": board$(midlv, midlh) = " "
    score = score + 1
    WIPE "24"
    GoTo GetFrom
End If

Sub drawgrid
    white
    'labels
    Locate 6, 27: Print "1  2  3  4  5  6  7"
    For a = 1 To 7
        Locate 6 + a * 2, 24
        Print Chr$(64 + a)
    Next
    ' all pegs
    yellow
    For a = 1 To 7
        For b = 1 To 7
            board$(a, b) = "*"
            Locate a * 2 + 6, b * 3 + 24
            Print "*"
        Next
    Next
    'centre hole
    red: Locate 14, 36: Print Chr$(249)
    board$(4, 4) = " "
    'draw frame
    yellow
    top = 160
    For a = 0 To 6
        PSet (355, top + a * 48)
        For b = 1 To 7 '                                                                                      row of 7 boxes
            Draw "r30d33l30u33bm+42,0"
        Next
    Next
End Sub

Sub Finish
    Cls
    Locate 15, 18: Print "You scored"; score; "points, from a possible 47."
    Sleep
    System
End Sub

Sub red
    Color _RGB(255, 0, 0)
End Sub

Sub yellow
    Color _RGB(255, 255, 0)
End Sub
Sub white
    Color _RGB(255, 255, 255)
End Sub

Sub WIPE (ln$) '                                                                                                            call with string of 2-digit line numbers only  eg "0122"  for lines 1 and 23
    For a = 1 To Len(ln$) - 1 Step 2
        Locate Val(Mid$(ln$, a, 2))
        Print Space$(73)
    Next
End Sub

[mnrvovrfc]

The "WIPE" subprogram is handy for SCREEN 0 programs. Pete would love that one.

Have to use subprograms also just to set colors. Yellow! White! Because QB64 doesn't have "#define" like in C/C++ or something else to define a search-and-replacement macro. From this I could see Ethan Winer crying, "No! Stop! Use GOSUB subroutines instead, they are only three bytes per call!" LOL. I miss that PC-MAGAZINE BASIC primer that he wrote.

[justsomeguy]

Great little game! 

I had to make one change to it to work on a Linux machine. This font seemed generic enough to work a lot of distros.

Code: (Select All)

SetFont: f& = _LOADFONT("/usr/share/fonts/truetype/dejavu/DejaVuSansMono.ttf", 24, "monospace") '                                                 31 rows, 73 columns text, allows chr$(95)

Thanks for sharing!