Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
WORM - another word-game
#1
This is a word-game for two players, where they take turns to build a word, by adding a letter either on the ends or anywhere in the body of the "worm". 
The group of letters must always be part of a legit word, but must not complete the word. A player may "Claim" a completed word, "Challenge" a group of letters and earns points based on the length of the worm.The worm can also be "flipped" (reversed) before adding a letter. A dictionary which checks all submitted words ( up to length 15 letters) is included.
Code: (Select All)
Common Shared Name$(), Score(), MinSize, WinScore, Plr, OK$, Bad$, Alert$, CPL, LN$, DumWrd$, Found, DictWord$, Srch$
Common Shared Wrd$, CsrH, WdPos, Picked, Flipped, L$, Words$(), TLimit, WordVal, TryVal, Try$, A$

SW = 1020: SH = 720
Screen _NewImage(SW, SH, 32)
SetFont: F& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font F& '       choose monospace font
SMode = 32
CPL = Int(SW / _PrintWidth("X")) '                                                        find chars per line for this window width
CTR = Int((CPL + 1) / 2) '                                                                find horiz screen centre
_ScreenMove (_DesktopWidth - SW) / 2, 90 '                                                place window there

CheckDictionary: '                                                                        need random-access word list
If Not (_FileExists("R_ALL15")) Then
    Centre "This game requires the random-access file R_ALL15 to be present", 12
    Sleep: System
End If

Randomize Timer

MinSize = 3 '                                                                             minimum word size
Dim Name$(2), Score(2), Words$(2)
OK$ = "o4l32ce": Bad$ = "o3l32ec": Alert$ = "o4l32msep32ep32ep32ep32e" '                                                       sound for good and bad actions
Name$(1) = "PLAYER 1": Name$(2) = "PLAYER 2" '                                            default names

instructions

Names:
_KeyClear: k$ = ""
Centre "Name of first player (enter for default PLAYER 1)    ", 15
Locate 15, 62
Input k$
If k$ > Chr$(13) Then
    Name$(1) = UCase$(k$)
Else Name$(1) = "PLAYER 1"
End If
Play OK$
Centre Name$(1), 17: Sleep 1: Cls
k$ = ""
Centre "Name of second player (enter for default PLAYER 2)", 15
Locate 15, 64
Input k$
If k$ > Chr$(13) Then
    Name$(2) = UCase$(k$)
Else Name$(2) = "PLAYER 2"
End If
Play OK$
Centre Name$(2), 17: Sleep 1: Cls

WinningScore:
Centre "Winning score  level (1=100 to 9=900, default 100) ?", 15
SetWinScore:
k$ = InKey$
If k$ = "" Then GoTo SetWinScore
If k$ < "1" Or k$ > "9" Then
    WinScore = 100 '                                                                      default winning score
Else
    WinScore = Val(k$) * 100
End If
Play OK$
Centre LTrim$(Str$(WinScore)), 17: Sleep 1: Cls

SetTimeLimit:
Centre "Time limit for new letter (1=30, 2=60, 3=90, 4=120 seconds, default=30) ?", 15
TimeLimit:
k$ = InKey$
If k$ = "" Then GoTo SetTimeLimit
If k$ < "1" Or k$ > "4" Then
    TLimit = 30 '                                                                         default time limit fo letter selection
Else
    TLimit = Val(k$) * 30
End If
Play OK$
txt$ = LTrim$(Str$(TLimit)) + " seconds"
Centre txt$, 17: Sleep 1: Cls

SetUpGame:
Plr = 2
Csr$ = " / "

NewWord:
If Score(1) >= WinScore Or Score(2) >= WinScore Then Winner
Flipped = 0
Wrd$ = Chr$(Int(Rnd * 26) + 65)

PlayerUp:
Cls
If Plr = 1 Then Plr = 2 Else Plr = 1
CsrH = CTR - 1: WdPos = CTR - Int((Len(Wrd$) + 1) / 2) + 1 '                                centre the word and centre cursor for start
wipe "17": Locate 17, WdPos: Print Wrd$
txt$ = Name$(1) + ":" + Str$(Score(1)) + Space$(15) + "Winning score:" + Str$(WinScore) + Space$(15) + Name$(2) + ":" + Str$(Score(2))
Centre txt$, 2
IP = Int((Len(Wrd$) + 1) / 2) + 1
wipe "19" '                                                                                 clear player input line
Locate 19, CsrH + 1: Print "?"
yellow

ShowChoices:
txt$ = Name$(Plr) + " playing"
Centre txt$, 4
Centre "Press A-Z to select a letter to add", 22
If Len(Wrd$) > 1 And Flipped = 0 Then '                                                     show only if more than 1 letter and word is not flipped
    Centre "or", 24
    Centre "1 to Claim a word    2 to Challenge a group    3 to Concede this round", 26 '
End If
Centre "Down-arrow to flip the word", 27 '                                                   can flip multiple times
Centre "Esc to close the game", 28
_KeyClear

GetChoice:
t1 = Timer
Action = 0
While Action < 1
    _Limit 30
    Action = _KeyHit
    t2 = Int(TLimit + 1 - Timer + t1)
    wipe "05": Centre LTrim$(Str$(t2)), 5
    If t2 < 1 Then
        Centre "Too late!", 5
        Sleep 2
        wipe "05"
        Play Bad$
        GoTo PlayerUp
    End If
Wend
wipe "05"
Select Case Action
    Case Is = 27 '                                                                          exit game
        System
    Case Is = 49 '                                                                          claim a completed word
        If Flipped = 0 Then
            Claim
        Else GoTo GetChoice '                                                               if flipped, ignore
        End If
        GoTo NewWord
    Case Is = 50 '                                                                          challenge a group
        If Flipped = 0 Then
            Challenge
        Else GoTo GetChoice '                                                               if flipped, ignore
        End If
        GoTo NewWord
    Case Is = 51 '                                                                         concede this group is unwinnable
        Concede '                                                                           can still concede after flipping
        GoTo NewWord
    Case Is = 20480 '                                                                       down-arrow to flip worm
        Flip
        GoTo PlayerUp
    Case 65 To 90 '                                                                         CAPITAL letter
        L$ = Chr$(Action)
        Locate 19, CsrH + 1: Print L$
        Locate 18, CsrH: Print Csr$
        Picked = 1
    Case 97 To 122 '                                                                        lower-case letter
        L$ = Chr$(Action - 32)
        Locate 19, CsrH + 1: Print L$
        Locate 18, CsrH: Print Csr$
        Picked = 1
    Case Else
        GoTo GetChoice
End Select
Play OK$

Move: '                                                                                     after letter selected, only left-, right- or up-arrow
Centre "Use Left/Right arrows to change its position, then up-arrow to place it", 22
Action = 0
While Action < 1
    Action = _KeyHit
Wend '
Select Case Action
    Case Is = 19200, 52 '                                                                   move left
        If IP > 1 Then
            CsrH = CsrH - 1: IP = IP - 1
            Locate 18, CsrH: Print Csr$
            Locate 19, CsrH + 1: Print L$; " "
        End If
        GoTo Move
    Case Is = 19712, 54 '                                                                   move right
        If CsrH < WdPos + Len(Wrd$) - 2 Then
            CsrH = CsrH + 1: IP = IP + 1
            Locate 18, CsrH: Print Csr$
            Locate 19, CsrH: Print " "; L$
        End If
        GoTo Move
    Case Is = 18432, 56 '                                                                   up (place letter at cursor)
        Wrd$ = Left$(Wrd$, IP - 1) + L$ + Right$(Wrd$, Len(Wrd$) - IP + 1)
        Flipped = 0: Picked = 0
        GoTo PlayerUp
    Case Else
        Play Bad$: GoTo Move
End Select
Sleep

Sub wipe (ln$) '                                                                            erase lines of text - e.g. "020308" for lines 2, 3 and 8
    For a = 1 To Len(ln$) - 1 Step 2 '                                                      ln$ is lines to erase, as string of 2 digit line numbers
        Locate Val(Mid$(ln$, a, 2))
        Print Space$(CPL)
    Next
End Sub

Sub Centre (Txt$, LineNum) '                                                                centres text on selected line
    ctr = Int(CPL / 2 - Len(Txt$) / 2) + 1 '                                                centre is half of Chars Per Line minus half Txt$ length
    Locate LineNum, ctr
    Print Txt$
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 Grey
    Color _RGB(128, 128, 128)
End Sub

Sub Claim
    wipe "2224262728"
    Play Alert$ '                                                        clear prompts
    txt$ = Name$(Plr) + " claims that this is a word"
    yellow: Centre txt$, 10
    WordVal = 0:
    For a = 1 To Len(Wrd$): WordVal = WordVal + a: Next
    txt$ = "(Points Value is" + Str$(WordVal) + ")" '                                       calc word value (summation of length)
    Centre txt$, 12
    Centre "Stand by, checking...", 11: Sleep 1
    wipe "04"
    Try$ = Wrd$
    WRdSearch
    claimResult:
    txt$ = "This word is "
    If Found = 0 Then '                                                                    if Found is still 0 (search failed to find this word),
        red: txt$ = txt$ + "not accepted"
        Play Bad$
        If Plr = 1 Then Plr = 2 Else Plr = 1 '                                              swap players and assign points to opponent
        Score(Plr) = Score(Plr) + WordVal
        If Plr = 1 Then Plr = 2 Else Plr = 1 '                                              and swap players back to normal flow
    Else '                                                                                  but if the word is valid,
        yellow: txt$ = txt$ + "acccepted"
        Play OK$
        Words$(Plr) = Words$(Plr) + "  " + Wrd$
        Score(Plr) = Score(Plr) + WordVal '                                                 assign points to player
    End If
    Centre txt$, 4: yellow
    Sleep 2
End Sub

Sub Challenge
    WordVal = 0: Found = 0 '                                                                flag word as not found
    wipe "2224262728": Play Alert$ '                                                        clear prompts
    txt$ = Name$(Plr) + " claims that this group is not part of a word"
    yellow: Centre txt$, 9
    If Plr = 1 Then Plr = 2 Else Plr = 1 '                                                  change Plr ito the CHALLENGED player
    txt$ = Name$(Plr) + " Please type a word containing this group"
    Centre txt$, 11
    _KeyClear
    wipe "13"
    Locate 13, 36
    Input Try$ '                                                                            get the challenged player's claim
    Try$ = UCase$(Try$)
    If Len(Try$) < Len(Wrd$) Or InStr(Try$, Wrd$) < 1 Then '                                if it's shorter than, or doesn't contain the group, fail it,
        For a = 1 To Len(Wrd$): WordVal = WordVal + a: Next: GoTo ChalResult '              and use the original Wrd$ for value (summation of length)
    End If
    wipe "13"
    Centre Try$, 13
    For a = 1 To Len(Try$): WordVal = WordVal + a: Next '                                   otherwise use the length of their try for value
    txt$ = "(Points Value is" + Str$(WordVal)
    Centre txt$, 15
    Centre "Stand by, checking...", 17 '                                                    search word-list for their try
    wipe "04"
    WRdSearch
    ChalResult: '                                                                           now analyze Found
    If Found = 0 Then '                                                                     if their try word is not found
        Play Bad$
        txt$ = Try$ + " is not accepted"
        red
        If Plr = 1 Then Plr = 2 Else Plr = 1 '                                              swap players back to normal and assign points to challenger,
        Score(Plr) = Score(Plr) + WordVal
        If Plr = 1 Then Plr = 2 Else Plr = 1
    Else '                                                                                  but if their word is found,
        Play OK$
        white: txt$ = Try$ + " is accepted"
        Score(Plr) = Score(Plr) + WordVal '                                                 assign points to challenged player
        Words$(Plr) = Words$(Plr) + "  " + Try$ '                                           add the word to their successful words list
    End If
    Centre txt$, 19: _Delay 2: wipe "19"
    yellow
    If Plr = 1 Then Plr = 2 Else Plr = 1 '                                                  swap players
End Sub

Sub Concede
    WordVal = 0
    Play Bad$
    For a = 1 To Len(Wrd$): WordVal = WordVal + a: Next '                                   calculate word value
    txt$ = Name$(Plr) + " concedes this group as unwinnable"
    yellow: Centre txt$, 9
    If Plr = 1 Then Plr = 2 Else Plr = 1 '                                                  swap players,
    Score(Plr) = Score(Plr) + WordVal '                                                     allocate points to other player,
    If Plr = 1 Then Plr = 2 Else Plr = 1 '                                                  and swap back to normal flow
    _Delay 3
End Sub


Sub WRdSearch
    Found = 0 '                                                                             start search with Found as 0 (failed)
    Open "R_ALL15" For Random As #1 Len = 19
    FL = LOF(1) \ 19 + 1 '                                                                  FL is number of words in file
    bot = 0: top = FL '                                                                     search area between top and bottom words of file
    While Abs(top - bot) > 1
        srch = Int((top + bot) / 2)
        Get #1, srch, A$ '                                                                  get word at centre of search area
        A$ = UCase$(A$)
        Select Case A$
            Case Is = Try$ '                                                                if the word=Wrd$
                Found = 1 '                                                                 mark Found as 1, and stop searching
                Exit While
            Case Is < Try$ '                                                                if the word is less than Wrd$
                bot = srch '                                                                move bottom of search to middle of search
            Case Is > Try$ '                                                                if the word is greater than wrd$
                top = srch '                                                                move top of search to middle of search
        End Select
    Wend '                                                                                  if gap top to bottom >1, repeat search with new search area
    Close

End Sub

Sub Flip
    TmpWrd$ = String$(Len(Wrd$), ".") '                                                      create temporary word
    For a = 1 To Len(Wrd$)
        Mid$(TmpWrd$, a, 1) = Mid$(Wrd$, Len(Wrd$) - a + 1, 1) '                             write letters in reverse order into temp word
    Next
    Wrd$ = TmpWrd$ '                                                                         and change Wrd$ to TmpWrd$
    Flipped = 1 '                                                                            set Flipped flag to prevent their claiming or challenging
    If Plr = 1 Then Plr = 2 Else Plr = 1 '                                                   keep same player after flip
End Sub

Sub Winner
    Cls
    For a = 1 To 5: Play OK$: Next
    yellow
    Centre "We have a winner!", 12: white: Print
    txt$ = Name$(1) + ": " + LTrim$(Str$(Score(1))) + "     " + Name$(2) + ": " + LTrim$(Str$(Score(2)))
    Centre txt$, 14
    yellow: txt$ = "Congratulations "
    If Score(1) > Score(2) Then txt$ = txt$ + Name$(1) Else txt$ = txt$ + Name$(2)
    Centre txt$, 16
    Print: Print
    Print Name$(1); " words: ": white: Print Words$(1)
    Print
    yellow: Print Name$(2); " words: ": white: Print Words$(2)
    Print

    Sleep
    System
End Sub

Sub instructions
    Cls: yellow
    Centre "Worm - An original word-Game for two players by Phil Taylor", 3
    Centre "Instructions", 5: white
    Print
    Print " A random letter is presented, and two players take turns to add a letter to"
    Print " it, building towards a word, but avoiding completing it. The letter may be"
    Print " placed at either end, or anywhere inside the group, exending the "; Chr$(34); "Worm"; Chr$(34); ". By";
    Print " default, they have just 30 seconds in which to choose their letter, but a"
    Print " different time limit can be selected."
    Print
    Print " If a player sees that their opponent has completed a word, they can ";: yellow: Print "Claim";: white: Print " it"
    Print " to score points. If successful the challenger gains points based on the word"
    Print " length. If not,their opponent gains the points. A new word then starts."
    Print
    Print " Players may also";: yellow: Print " Flip";: white: Print " (reverse) the Worm before adding their letter (but the"
    Print " Found of the Flip can not be claimed as a word)."
    Print
    Print " If they think that the group is not part of a real word they may ";: yellow: Print "Challenge";: white: Print ","
    Print " and their opponent must then type a complete word containing the group. If"
    Print " they can"; Chr$(39); "t,  the challenger gains points, based on the size of the group, or"
    Print " the length of their attempt, whichever is greater."
    Print
    Print " If a player thinks that all the words that can be formed from the group will"
    Print " cost them points, they may ";: yellow: Print "Concede";: white: Print " the group, to limit the number of points"
    Print " they lose."
    Print
    Print " Word lengths of from two to fifteen letters allowed, and words are checked"
    Print " automatically by the computer. The game ends when a player reaches the chosen"
    Print " winning score."
    yellow: Centre "Press a key to continue.", 33
    Sleep
    Cls: Play OK$
End Sub


Attached Files
.7z   R_ALL15.7z (Size: 653.84 KB / Downloads: 30)
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#2
http://oldendayskids.blogspot.com/p/free-games.html

Free Games Link

File not found
Write name of program in 1st line to copy & paste & save filename.bas
Insert program pictures: press print-screen-shot button
Open paint & Paste & Save as PNG
Add picture file to program topic

Russia looks world from future. Big data is peace data.
I never recommend anything & always write only about myself
Reply
#3
(09-22-2024, 01:25 PM)DANILIN Wrote: http://oldendayskids.blogspot.com/p/free-games.html

Free Games Link

File not found

Hi Danilin. 
No, the file is not on there now - I decided to remove it as it seemed to get little attention. Sorry for the link oversight, I'll remove it.
Thanks for the post.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply




Users browsing this thread: 2 Guest(s)