Smallish Games

[bplus]

Down to 79 Loc

Instructions: after choosing the number of cells per side you want to try, you will be presented a grid with number along each row and col. Those numbers represent a run of white squares in that row or col. By clicking the cells on or off, your goal is to match those runs in rows and cols.

Code: (Select All)

_Title "Nonogram Trainer" ' b+ 2023-01-12
DefLng A-Z
Randomize Timer
Dim Shared As _Unsigned Long White, Black, Blue
White = &HFFFFFFFF: Black = &HFF000000: Blue = &HFF0000FF
ReDim Shared Sq, Game(1 To 1, 1 To 1), Board(1 To 1, 1 To 1), RowRuns$(1 To 1), ColRuns$(1 To 1)
Screen _NewImage(800, 600, 32)
makeGame
Do
    10 If _MouseInput Then GoTo 10
    mx = _MouseX: my = _MouseY: mb = _MouseButton(1)
    If mb Then
        _Delay .2
        If mx > 20 And mx <= Sq * 20 + 40 Then
            If my > 20 And my <= Sq * 20 + 40 Then
                x = Int(mx / 20): y = Int(my / 20)
                If Board(x, y) Then Board(x, y) = 0 Else Board(x, y) = 1
                If Board(x, y) Then Color White Else Color Black
                Line (x * 20, y * 20)-Step(20, 20), , BF
                Line (x * 20, y * 20)-Step(20, 20), Blue, B
            End If
        End If
    End If
    If Solved Then _MessageBox "Solved", "Hurray you've solved the puzzle!": makeGame
    _Limit 60
Loop Until _KeyDown(27)

Sub makeGame
    Cls
    inputAgain:
    Input "How many cells per square side (1 to 9) "; test
    If test < 1 Or test > 9 Then GoTo inputAgain Else Cls: Sq = test
    ReDim Game(1 To Sq, 1 To Sq), Board(1 To Sq, 1 To Sq), RowRuns$(1 To Sq), ColRuns$(1 To Sq)
    Line (18, 18)-(Sq * 20 + 22, Sq * 20 + 22), White, B
    For y = 1 To Sq
        For x = 1 To Sq
            If Rnd < .5 Then Game(x, y) = 0 Else Game(x, y) = 1
            Line (x * 20, y * 20)-Step(20, 20), Blue, B
        Next
    Next
    Color White
    For i = 1 To Sq
        RowRuns$(i) = Runs$(1, i, Game())
        _PrintString (Sq * 20 + 30, i * 20 + 4), RowRuns$(i)
        ColRuns$(i) = Runs$(0, i, Game())
    Next
    For i = 1 To Sq
        row = Sq
        For j = 1 To Len(ColRuns$(i)) Step 2
            row = row + 1
            _PrintString (i * 20 + 6, row * 20 + 10), Mid$(ColRuns$(i), j, 1)
        Next
    Next
End Sub

Function Runs$ (rowTF, number, arr())
    For i = 1 To Sq
        If (arr(i, number) And rowTF) Or (arr(number, i) And rowTF = 0) Then
            If flag Then flag = flag + 1 Else flag = 1
        Else
            If flag Then
                If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
                flag = 0
            End If
        End If
    Next
    If flag Then
        If Len(b$) Then b$ = b$ + " " + _Trim$(Str$(flag)) Else b$ = _Trim$(Str$(flag))
    End If
    Runs$ = b$
End Function

Function Solved
    For i = 1 To Sq
        If RowRuns$(i) <> Runs$(1, i, Board()) Then Exit Function 'not done
        If ColRuns$(i) <> Runs$(0, i, Board()) Then Exit Function
    Next
    Solved = -1
End Function

Best solve yet!