TriQuad Puzzle from long ago, still like playing once and awhile.
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
b = b + ...