Bogglish - a Boggle look-alike (almost)

Code: (Select All)
Common Shared LineNumum, LN$, CPR, Bad$, OK$, click$, Pip$, Plr, NRounds, Round, Name$(), Score(), Wd$, Found

Common Shared NumWds, Words$(), Size, Letter$(), Dice$(), DiceLetrs$, Passes, Time, TimeAdj, Mode

SW = 1040: sh = 720

Screen _NewImage(SW, sh, 32)

SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&

CPR = SW / _PrintWidth("X")

_ScreenMove (_DesktopWidth - SW) / 2, 100

Randomize Timer

Bad$ = "w1o2l16gc": OK$ = "w1o3l64ceg": click$ = "v100w8l32o5t240l64c"

Play OK$: Instructions



GetNumRounds:

_KeyClear

Centre "How many rounds (1 to 5)?", 12

While NRounds$ = "": NRounds$ = InKey$: Wend

NRounds = Val(NRounds$): If NRounds < 1 Or NRounds > 5 Then NRounds = 2

Centre Str$(NRounds), 14: _Delay .5: WIPE "12"

Dim Name$(2), Score(2), Letter$(100)

For a = 1 To 2: Name$(a) = "Player " + LTrim$(Str$(a)): Next

Round = 0: Plr = Int(Rnd * 2) + 1

_Delay .5: Cls

Data "A","A","A","A","A","A","A","A","A","B","B","B","C","C","D","D","D","D","E","E","E","E","E","E","E","E"

Data "E","F","F","F","G","G","G","H","H","H","I","I","I","I","I","I","I","I","J","K","L","L","L","L","M","M"

Data "M","M","N","N","N","N","N","N","N","O","O","O","O","O","O","O","O","P","P","Q","R","R","R","R","R","R"

Data "S","S","S","S","T","T","T","T","T","T","U","U","U","U","V","V","W","W","X","Y","Y","Z"

Plr = Int(Rnd * 2) + 1



For a = 1 To 100: Read Letter$(a): Next '                                               letter-mix to give good range of useful letters



GetBoxSize:

_KeyClear

Centre "Box size (1=9 dice, 2=16 dice, 3=25 dice, 4=36 dice)?", 12 '                    size 1 very quick, 4 can give very long game

While size$ = "": size$ = InKey$: Wend

Size = Val(size$): If Size < 1 Or Size > 4 Then Size = 2

Centre Str$(Size), 14: _Delay .5: Cls

Play OK$



GeMode:

_KeyClear

Centre "Mode (1: multiple use of dice, 2: single use of dice; default 1)?", 12 '        mode 2 allows longer words and higher scores

While Mode$ = "": Mode$ = InKey$: Wend

Mode = Val(Mode$): If Mode < 1 Or Mode > 2 Then Mode = 1

txt$ = "Multiple use of dice allowed": If Mode = 2 Then txt$ = "Single use only"

Centre txt$, 14: Sleep 1: Cls

Play OK$



SetUpBox:

BoxV = 176: Row = 8 '                                                                   box always at row 8, centred

RowSize = Size + 2 '                                                                    number of dice per row 2 more than Size, so 3,4,5,6

NumDice = RowSize * RowSize '                                                           same number of rows and columns of dice

Dim Dice$(RowSize, RowSize)

Select Case RowSize

    Case 3

        Colm = 29

        Boxh = 400

        Box$ = "r195d180l195u180r65d180r65u180r65d60l195d60r195u60l195"

    Case 0, 4

        Colm = 28

        Boxh = 388

        Box$ = "r260d240l260u240r65d240r65u240r65d240r65u60l260u60r260u60l260"

    Case 5

        Colm = 25

        Boxh = 348

        Box$ = "r325d300l325u300r65d300r65u300r65d300r65u300r65d60l325d60r325d60l325d60r325"

    Case 6

        Colm = 23

        Boxh = 323

        Box$ = "r390d360l390u360r65d360r65u360r65d360r65u360r65d360dr65u60l390u60r390u60l390u60r390u60l390"

End Select



DrawBox:

If Round = NRounds Then EndGame

WIPE "0108"

PSet (Boxh, BoxV)

Draw Box$

Round = Round + 1

ShowDicePos:

For a = 1 To RowSize

    For b = 1 To RowSize

        Locate Row + a * 3, Colm + b * 5

        Print "*"

    Next

    Print

Next

Locate 1, 2: Print Name$(1); ": "; LTrim$(Str$(Score(1)))

Locate 1, 67: Print Name$(2); ": "; LTrim$(Str$(Score(2)))

txt$ = Name$(Plr) + " Playing"

Centre txt$, 8

White: Locate 1, 19: Print "Round:"; Round; "of"; NRounds: Locate 1, 49: Print "Passes:"; Passes;: Yellow



Shake:

Centre "Press any key to shake the Box", 31

Sleep

For a = 1 To 15: Play click$: _Delay .1: Next

_Delay .5



GetDice:

NumWds = 1: DiceLetrs$ = "" '                                                           NumWds is used to display used words and to search for repeats

Passes = 0

ReDim Words$(75)

For a = 1 To RowSize

    For b = 1 To RowSize

        Dice$(a, b) = Letter$(Int(Rnd * 100) + 1) '                                     get random letter for each die

        DiceLetrs$ = DiceLetrs$ + Dice$(a, b)

        Locate Row + a * 3, Colm + b * 5

        Print Dice$(a, b)

    Next

Next



PlayerUp:

If Passes = 2 Then Passes = 0: Cls: GoTo DrawBox '                                      if both have passed, go back and re-shake box

WIPE "0108"

Locate 1, 2: Print Name$(1); ": "; LTrim$(Str$(Score(1)))

Locate 1, 67: Print Name$(2); ": "; LTrim$(Str$(Score(2)))

txt$ = Name$(Plr) + " Playing"

Centre txt$, 8

White: Locate 1, 19: Print "Round:"; Round; "of"; NRounds: Locate 1, 49: Print "Passes:"; Passes;: Yellow



txt$ = " Type your word"

WIPE "31": Centre txt$, 30

Centre "?", 32

k$ = ""

Time = 0: t1 = Timer '                                                                  start timer for this player



GetLetter:

k$ = ""

_KeyClear

While k$ = ""

    k$ = InKey$

    Spent = Int(Timer - t1) '                                                           count time spent before submitting word

    Locate 1, 39: Print Spent

Wend

If k$ = Chr$(13) Then '                                                                 word (or pass) submitted

    Time = Int(Timer - t1)

    TimeAdj = 15 - Time '                                                               allow 15 sec free time

    If Len(Wd$) < 2 And TimeAdj > 1 Then TimeAdj = 0 '                                  don't grant bonus for quick pass

    CheckWord

    Wd$ = "": GoTo PlayerUp

End If

l$ = UCase$(k$)

Wd$ = Wd$ + l$

Centre Wd$, 32

GoTo GetLetter



Sub CheckWord '                                                                         length >2, valid letters, real word, not duplicated

    Fail = 0

    WIPE "30"

    Length:

    If Len(Wd$) < 3 Then

        Red: Centre "Word too short, or no word entered", 30

        Play Bad$: Fail = 1: GoTo GetScore '                                            when fail is flagged, skip other tests and evaluate

    End If

    ValidLetters:

    Found = 1

    Select Case Mode

        Case 1 '                                                                        mode 1 check letter is present, and allow re-use of dice

            Found = 1

            For a = 1 To Len(Wd$)

                L$ = Mid$(Wd$, a, 1)

                po = InStr(DiceLetrs$, L$)

                If po = 0 Then Found = 0: Exit For '                                    if any letter is not found, word fails so skip the rest

            Next

            If Found = 0 Then

                Red: Centre "One or more letters were not available", 30

                Play Bad$: Fail = 1: GoTo GetScore

            End If

        Case 2 '                                                                         no duplicated dice

            For a = 1 To Len(Wd$)

                L$ = Mid$(Wd$, a, 1)

                po = InStr(DiceLetrs$, L$)

                If po = 0 Then

                    Found = 0: Exit For '                                                if letter is not on any die, word fails so stop checking

                Else

                    Mid$(DiceLetrs$, po, 1) = LCase$(Mid$(DiceLetrs$, po, 1)) '          if found, change to lower-case to prevent re-find

                End If

            Next

            If Found = 0 Then

                Red: Centre "Letter duplicated or not available", 30

                Play Bad$: Fail = 1: GoTo GetScore

            End If

            DiceLetrs$ = UCase$(DiceLetrs$)

    End Select



    DupWords:

    For a = 1 To NumWds '                                                                check word against previous words

        If Wd$ = Words$(a) Then

            Red: Centre "This word has already been used in this round", 30

            Play Bad$: Fail = 1: GoTo GetScore

        End If

    Next



    Dictionary:

    Found = 0

    Open "R_ALL15" For Random As #1 Len = 19 '                                           binary search (dictionary is alpha-sorted

    FL = LOF(1) \ 19 + 1

    bot = 0: top = FL

    While Abs(top - bot) > 1

        srch = Int((top + bot) / 2)

        Get #1, srch, a$

        Select Case a$

            Case Is = Wd$

                Found = 1

                Exit While

            Case Is < Wd$

                bot = srch

            Case Is > Wd$

                top = srch

        End Select

    Wend

    Close

    If Found = 0 Then

        Red: Centre "Your word was not found in the Dictionary", 30

        Play Bad$: Fail = 1:

    End If



    GetScore:

    points = 0

    If Len(Wd$) = 0 Then

        Passes = Passes + 1 '                                                            if no letters, it's a pass

    Else

        Passes = 0 '                                                                     if it's not a pass, re-start count of passes

        If Fail = 0 Then '                                                               if the word passed tests

            NumWds = NumWds + 1 '                                                        inc number of words

            Words$(NumWds) = Wd$ '                                                       add the word to found words list

            White: For a = 0 To 4

                Locate a + 2, 1 '                                                        start display of found words on row 2

                For b = 1 To 15 '                                                        show 15 words in each row (to prevent splitting)

                    Print Words$(a * 15 + b); " ";

                Next

            Next

            For a = 1 To Len(Wd$)

                points = points + a '                                                    cumulative count of letters gives Points value

            Next

        End If

    End If

    AdjPoints = points + TimeAdj '                                                       find time adjustment

    Score(Plr) = Score(Plr) + AdjPoints '                                                apply time adjustment to give score



    Announce:

    Locate 1, 49: Print "Passes:"; Passes

    txt$ = "You scored" + Str$(points) + " points, and time adjustment was " + LTrim$(Str$(TimeAdj))

    txt$ = txt$ + ", giving " + LTrim$(Str$(AdjPoints)) + " points"

    WIPE "08": Yellow: Centre txt$, 8

    If Plr = 1 Then Plr = 2 Else Plr = 1 '                                               next player

    Sleep 2: WIPE "083032": Wd$ = ""

End Sub



Sub EndGame

    Cls

    Play OK$

    Yellow: Centre "Game Finished", 10: Sleep 2

    Cls: Centre "Final Scores", 12: White

    Print: Print Tab(33); Name$(1); Tab(46); Score(1)

    Print: Print Tab(33); Name$(2); Tab(46); Score(2)

    Winr = 1 '                                                                           assume player 1 is winner

    If Score(2) > Score(1) Then Winr = 2 '                                               if player 2 score higher, change winner to player 2,

    txt$ = "Congratulations, " + Name$(Winr) '                                           and congratulate winner,

    If Score(2) = Score(1) Then txt$ = "A drawn game!" '                                 but if equal, anoounce drawn game

    Yellow: Centre txt$, 18: Sleep

End Sub



Sub Centre (txt$, linenum)

    ctr = Int(CPR / 2 - Len(txt$) / 2) + 1

    Locate linenum, ctr

    Print txt$

End Sub



Sub WIPE (ln$)

    If Len(ln$) = 1 Then ln$ = "0" + ln$

    For a = 1 To Len(ln$) - 1 Step 2

        wl = Val(Mid$(ln$, a, 2))

        Locate wl, 1: Print Space$(CPR);

    Next

End Sub



Sub White

    Color _RGB(255, 255, 255)

End Sub



Sub Yellow

    Color _RGB(255, 255, 0)



End Sub

Sub Red

    Color _RGB(255, 0, 0)

End Sub



Sub Instructions:

    Yellow: Centre "Bogglish Rules", 6: White: Print

    Print "  Bogglish is a game for 1 or 2 players, loosely based around the dice game of"

    Print "  Boggle. It uses 9, 16, 25 or 36 virtual dice, each with 6 letters that have"

    Print "  been selected for the frequency of their use in English words. Players take"

    Print "  turns to form words from the letters revealed when the dice are shaken.": Print

    Print "  Before the game starts, players select how many dice to use, and how many"

    Print "  rounds will be played. Each round is started by shaking the box containing"

    Print "  the dice, and players then take turns to find words of three or more letters"

    Print "  that they can form using the revealed letters. Points are scored for valid"

    Print "  words only, based on their length. Time taken for a turn beyond 15 seconds"

    Print "  incurs a time penalty of 1 point per second, but unused time earns a bonus."

    Print "  No reward is paid for a quick pass, but a penalty is paid if it's delayed.": Print

    Print "  Letters used may be anywhere in the box, but there are two modes of play. In"

    Print "  Mode 1, dice can only be used once in a word, while in Mode 2, they can be"

    Print "  re-used any number of times. Words can not be repeated in the same round. If"

    Print "  a player can't find a new word, they may pass, but continue to play, and can"

    Print "  submit words they find later.": Print

    Print "  When both players pass consecutively, that round ends and the next round is"

    Print "  started. The game ends after the agreed number of rounds have been played."

    Yellow: Centre "Press any key to start", 30

    Sleep: Play OK$: Cls

End Sub