Smallish Games

[PhilOfPerth]

TriQuad Puzzle from long ago, still like playing one and a while.

Code: (Select All)

Option _Explicit
_Title "TriQuad Puzzle" 'B+ start 2019-07-17 trans to QB64 from:
' TriQuad.bas  SmallBASIC 0.12.8 [B+=MGA] 2017-03-26
' inspired by rick3137's recent post at Naalaa of cute puzzle
' 2019-07 Complete remake for N X N puzzles, not just 3 X 3's.
' post at QB64 forum 2019-10-14

Randomize Timer

Const xmax = 1000, margin = 50 'screen size, margin that should allow a line above and below the puzzle display
Const topLeftB1X = margin, topLeftB2X = xmax / 2 + .5 * margin, topY = margin

'these have to be decided from user input from Intro screen
Dim Shared ymax, N, Nm1, NxNm1, sq, sq2, sq4
ymax = 500 'for starters in intro screen have resizing in pixels including ymax

ReDim Shared B1(2, 2), B2(2, 2) ' B1() box container for scrambled pieces of C(), B2 box container to build solution
ReDim Shared C(8, 3) '9 squares 4 colored triangles, C() contains the solution as created by code, may not be the only one!

Dim mx, my, mb, bx, by, holdF, ky As String, again As String

Screen _NewImage(xmax, ymax, 32)
_ScreenMove 300, 40
intro
restart:
assignColors
holdF = N * N
While 1
    Cls
    showB (1)
    showB (2)
    While _MouseInput: Wend
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mb Then
        Do While mb
            While _MouseInput: Wend
            mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
        Loop
        If topY <= my And my <= topY + N * sq Then
            by = Int((my - topY) / sq)
            If topLeftB1X <= mx And mx <= topLeftB1X + N * sq Then 'mx in b1
                bx = Int((mx - topLeftB1X) / sq)
                If holdF < N * N Then 'trying to put the piece on hold here?
                    If B1(bx, by) = N * N Then
                        B1(bx, by) = holdF: holdF = N * N
                    End If
                ElseIf holdF = N * N Then
                    If B1(bx, by) < N * N Then
                        holdF = B1(bx, by): B1(bx, by) = N * N
                    End If
                End If
            ElseIf topLeftB2X <= mx And mx <= topLeftB2X + N * sq Then 'mx in b2
                bx = Int((mx - topLeftB2X) / sq)
                If holdF < N * N Then
                    If B2(bx, by) = N * N Then
                        B2(bx, by) = holdF: holdF = N * N
                    End If
                ElseIf holdF = N * N Then
                    If B2(bx, by) < N * N Then
                        holdF = B2(bx, by): B2(bx, by) = N * N
                    End If
                End If 'my out of range
            End If
        End If
    End If
    If solved Then
        Color hue(9)
        Locate 2, 1: centerPrint "Congratulations puzzle solved!"
        _Display
        _Delay 3
        Exit While
    End If
    ky = InKey$
    If Len(ky) Then
        If ky = "q" Then
            showSolution
            Color hue(9)
            Locate 2, 1: centerPrint "Here is solution (for 10 secs), Goodbye!"
            _Display
            _Delay 10
            System
        End If
    End If
    _Display
    _Limit 100
Wend
Color hue(9): Locate 2, 1: centerPrint Space$(50): Locate 2, 1
centerPrint "Press enter to play again, any + enter ends... "
_Display
again = InKey$
While Len(again) = 0: again = InKey$: _Limit 200: Wend
If Asc(again) = 13 Then GoTo restart Else System

Function solved
    'since it is possible that a different tile combination could be a valid solution we have to check points
    Dim x, y
    'first check that there is a puzzle piece in every slot of b2
    For y = 0 To Nm1
        For x = 0 To Nm1
            If B2(x, y) = N * N Then Exit Function
        Next
    Next
    'check left and right triangle matches in b2
    For y = 0 To Nm1
        For x = 0 To Nm1 - 1
            If Point(topLeftB2X + x * sq + sq2 + sq4, topY + y * sq + sq2) <> Point(topLeftB2X + (x + 1) * sq + sq4, topY + y * sq + sq2) Then Exit Function
        Next
    Next
    'check to and bottom triangle matches in b2
    For y = 0 To Nm1 - 1
        For x = 0 To Nm1
            'the color of tri4 in piece below = color tri1 of piece above
            If Point(topLeftB2X + x * sq + sq2, topY + y * sq + sq2 + sq4) <> Point(topLeftB2X + x * sq + sq2, topY + (y + 1) * sq + sq4) Then Exit Function
        Next
    Next
    'if made it this far then solved
    solved = -1
End Function

Sub showSolution
    Dim x, y, index
    For y = 0 To Nm1
        For x = 0 To Nm1
            drawSquare index, x * sq + topLeftB2X, y * sq + topY
            index = index + 1
        Next
    Next
End Sub

Sub showB (board)
    Dim x, y, index
    For y = 0 To Nm1
        For x = 0 To Nm1
            If board = 1 Then
                index = B1(x, y)
                drawSquare index, x * sq + topLeftB1X, y * sq + topY
            Else
                index = B2(x, y)
                drawSquare index, x * sq + topLeftB2X, y * sq + topY
            End If
        Next
    Next
End Sub

Sub drawSquare (index, x, y)
    Line (x, y)-Step(sq, sq), &HFF000000, BF
    Line (x, y)-Step(sq, sq), &HFFFFFFFF, B
    If index < N * N Then
        Line (x, y)-Step(sq, sq), &HFFFFFFFF
        Line (x + sq, y)-Step(-sq, sq), &HFFFFFFFF
        Paint (x + sq2 + sq4, y + sq2), hue(C(index, 0)), &HFFFFFFFF
        Paint (x + sq2, y + sq2 + sq4), hue(C(index, 1)), &HFFFFFFFF
        Paint (x + sq4, y + sq2), hue(C(index, 2)), &HFFFFFFFF
        Paint (x + sq2, y + sq4), hue(C(index, 3)), &HFFFFFFFF
    End If
End Sub

Sub assignColors ()
    'the pieces are indexed 0 to N X N -1  (NxNm1)
    ' y(index) = int(index/N) : x(index) = index mod N
    ' index(x, y) = (y - 1) * N + x

    Dim i, j, x, y
    'first assign a random color rc to every triangle
    For i = 0 To NxNm1 'piece index
        For j = 0 To 3 'tri color index for piece
            C(i, j) = rand(1, 9)
        Next
    Next
    'next match c0 to c3 of square to right
    For y = 0 To Nm1
        For x = 0 To Nm1 - 1
            'the color of tri3 of next square piece to right = color of tri0 to left of it
            C(y * N + x + 1, 2) = C(y * N + x, 0)
        Next
    Next
    For y = 0 To Nm1 - 1
        For x = 0 To Nm1
            'the color of tri4 in piece below = color tri1 of piece above
            C((y + 1) * N + x, 3) = C(y * N + x, 1)
        Next
    Next

    ' C() now contains one solution for puzzle, may not be the only one

    ' scramble pieces to box1
    Dim t(0 To NxNm1), index 'temp array
    For i = 0 To NxNm1: t(i) = i: Next
    For i = NxNm1 To 1 Step -1: Swap t(i), t(rand(0, i)): Next
    For y = 0 To Nm1
        For x = 0 To Nm1
            B1(x, y) = t(index)
            index = index + 1
            B2(x, y) = N * N
            'PRINT B1(x, y), B2(x, y)
        Next
    Next
End Sub

Function hue~& (cn)
    Select Case cn
        Case 0: hue~& = &HFF000000
        Case 1: hue~& = &HFFA80062
        Case 2: hue~& = &HFF000050
        Case 3: hue~& = &HFFE3333C
        Case 4: hue~& = &HFFFF0000
        Case 5: hue~& = &HFF008000
        Case 6: hue~& = &HFF0000FF
        Case 7: hue~& = &HFFFF64FF
        Case 8: hue~& = &HFFFFFF00
        Case 9: hue~& = &HFF00EEEE
        Case 10: hue~& = &HFF663311
    End Select
End Function

Function rand% (n1, n2)
    Dim hi, lo
    If n1 > n2 Then hi = n1: lo = n2 Else hi = n2: lo = n1
    rand% = (Rnd * (hi - lo + 1)) \ 1 + lo
End Function

Sub intro 'use intro to select number of pieces
    Dim test As Integer
    Cls: Color hue(8): Locate 3, 1
    centerPrint "TriQuad Instructions:": Print: Color hue(9)
    centerPrint "This puzzle has two boxes that contain up to N x N square pieces of 4 colored triangles."
    centerPrint "The object is to match up the triangle edges from left Box to fill the Box on the right.": Print
    centerPrint "You may move any square piece to an empty space on either board by:"
    centerPrint "1st clicking the piece to disappear it,"
    centerPrint "then clicking any empty space for it to reappear.": Print
    centerPrint "You may press q to quit and see the solution displayed.": Print
    centerPrint "Hint: the colors without matching"
    centerPrint "complement, are edge pieces.": Print
    centerPrint "Good luck!": Color hue(5)
    Locate CsrLin + 2, 1: centerPrint "Press number key for square pieces per side (3 to 9, 1 to quit)..."
    While test < 3 Or test > 9
        test = Val(InKey$)
        If test = 1 Then System
    Wend
    N = test ' pieces per side of 2 boards
    Nm1 = N - 1 ' FOR loops
    NxNm1 = N * N - 1 ' FOR loop of piece index
    'sizing
    sq = (xmax / 2 - 1.5 * margin) / N 'square piece side size
    sq2 = sq / 2: sq4 = sq / 4
    ymax = sq * N + 2 * margin
    ReDim B1(Nm1, Nm1), B2(Nm1, Nm1), C(NxNm1, 3)
    Screen _NewImage(xmax, ymax, 32)
    '_SCREENMOVE 300, 40    'need again?
    'PRINT ymax
End Sub

Sub centerPrint (s$)
    Locate CsrLin, (xmax / 8 - Len(s$)) / 2: Print s$
End Sub

Nice one (again!)
I haven't mastered it yet, but hope to soon - I solved it once already (with 3x3)
I experimented with adding a "tries" counter, but it's a bit hard to check if it works when I can't even solve it!