01-02-2026, 11:15 AM
(This post was last modified: 01-03-2026, 01:25 AM by PhilOfPerth.)
Cherry Pie is a word game with just a touch of Christmas flavour, for up to 4 players. Instructions are in the code, and the word-list is attached.
Edit: Just added a Best Score recorder, and changed to optional single player.
Code: (Select All)
SW = 1020: SH = 780
Screen _NewImage(SW, SH, 32)
Common Shared CPL, MX, ok$, bad$, NRounds, NewRound$, Name$(), NP, Plr, Value, Score(), Goes, MaxTime, Time
Common Shared Word$, Found, High$(), Low$(), Vwl$(), Hi$, Low$, Words$(), RoundWords$(), Round, Record, RecName$
Randomize Timer
bad$ = "l16o1gc": NewRound$ = "l16o3cego4c": ok$ = "l16o2cg": NRounds = 12: MaxTime = 30
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f&
SMode = 32
CPL = SW / _PrintWidth("X")
lhs = (_DesktopWidth - CPL) / 2
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' centre the screeen
Data "B","F","J","K","Q","V","W","X","Y","Z": ' hi-value letters
Data "C","D","G","H","L","M","N","P","R","S","T": ' low-value letters
Data "A","E","I","O","U": ' vowels (low-value)
Dim Name$(4), High$(10), Low$(11), Vwl$(5)
CheckDictionaryPresent: ' R/A file of words to 15 chars length
If Not _FileExists("R_ALL15") Then
Play bad$
yellow: Centre "Random Access dictionary file R_ALL15 missing", 12
Sleep 5: System
End If
If _FileExists("CherryTop") Then
Open "CherryTop" For Input As #1
Input #1, Record, RecName$
Close
End If
SetDataArrays:
For a = 1 To 10: Read High$(a): Next
For a = 1 To 11: Read Low$(a): Next
For a = 1 To 5: Read Vwl$(a): Next
Instructions
GetNames ' get names, set NP and pick random first Plr
NewRound: ' pick 5 from 11 High, 8 from 10 Low, 2 from 5 Vwl (low)
ReDim RoundWords$(NP)
Play NewRound$
Hi$ = "": Low$ = ""
Round = Round + 1
If Round > NRounds Then finish
For a = 1 To 6
GetHigh:
L$ = High$(Int(Rnd * 10) + 1)
If InStr(Hi$, L$) > 0 Then GoTo GetHigh ' pick 5 hi letter numbers from 11
Hi$ = Hi$ + L$
Next
For a = 1 To 7
GetLow:
L$ = Low$(Int(Rnd * 11) + 1)
If InStr(Low$, L$) > 0 Then GoTo GetLow ' pick 8 lo letter numbers from 10
Low$ = Low$ + L$
Next
For a = 8 To 9
GetVowel:
L$ = Vwl$(Int(Rnd * 5) + 1)
If InStr(Low$, L$) > 0 Then GoTo GetVowel ' pick 2 lo vowels from 5 to add to lo
Low$ = Low$ + L$
Next
ShuffleLo: ' mix vwls
For a = 1 To 9
swp = Int(Rnd * 9) + 1
tmp$ = Mid$(Low$, swp, 1)
Mid$(Low$, swp, 1) = Mid$(Low$, a, 1)
Mid$(Low$, a, 1) = tmp$
Next
_KeyClear: Cls
ShowCherries:
yellow: Centre "HIGH", 9
white: Centre Hi$, 10
yellow: Centre "LOW", 12
white: Centre Low$, 13
txt$ = "Round" + Str$(Round) + " of " + Str$(NRounds): Centre txt$, 6
PlayerUp:
Hi$ = UCase$(Hi$): Low$ = UCase$(Low$) ' change Hi and Lo letters back to upper-case for next player
txt$ = "": Word$ = "": Value = 0
For a = 1 To NP: txt$ = txt$ + Name$(a) + ": " + LTrim$(Str$(Score(a))) + " ": Next
yellow: WIPE "02": Centre txt$, 2
Plr = Plr + 1: If Plr > NP Then Plr = 1
Goes = Goes + 1
If Goes > NP Then Goes = 0: GoTo NewRound ' when all players have played, next round will have new first player
txt$ = Name$(Plr) + " Type your word"
yellow: Centre txt$, 15
t1 = Timer: k = 0 ' start timer
GetWord:
While k = 0 ' while no key pressed
Time = MaxTime - Int(Timer - t1)
yellow: Centre Str$(Time), 4 ' show time remaining
k = _KeyHit
Wend
Select Case k
Case 13
CheckWord ' if Enter key pressed, word is finished or abandoned - check the word
GoTo PlayerUp
Case 97 To 122
k = k - 32 '
Word$ = Word$ + Chr$(k) ' change lower-case alpha to upper-case and add to word$
Case 65 To 90 '
Word$ = Word$ + Chr$(k) ' add upper-case alpha to word$
Case Else
End Select
Centre Word$, 17: k = 0: GoTo GetWord ' reset k for next key press
CheckWord
WIPE "17": GoTo PlayerUp
Sub GetNames ' get names, set NP and pick random first
_KeyClear
Do
Plr$ = ""
Play ok$
Locate 14, 18: yellow
Print "Name for player "; LTrim$(Str$(NP + 1)); ", to 8 letters (Enter for default)"; Tab(31); "or Space to finish";
Locate 18, 36: Input Plr$
If Plr$ = " " Then GoTo Done
NP = NP + 1
Name$(NP) = Left$(UCase$(Plr$), 8)
If Name$(NP) < "A" Then Name$(NP) = "ANON" + Str$(NP)
WIPE "18": Centre Name$(NP), 18: _Delay .3: WIPE "141618"
Loop Until NP = 4
Done:
If NP = 0 Then System
WIPE "141618"
Dim Score(NP), Words$(NP, 12), RoundWords$(NP) ' RoundWords is list of words for this round
Plr = Int(Rnd * NP) + 1 ' set random first player
End Sub
Sub CheckWord
DupWord:
For a = 1 To NP
If Word$ = RoundWords$(a) And Len(Word$) > 1 Then
Play bad$: red: Centre "This word has been used", 33: Sleep 1: fail = 1: WIPE "33": GoTo AllChecksDone
End If
Next
Value = 0: fail = 0 ' start with word no value
NotAWord:
Found = 0 ' set word Found flag to fail
Open "R_ALL15" For Random As #1 Len = 19
FL = LOF(1) \ 19 + 1 ' number of words in file number of words in file
bot = 0: top = FL
While Abs(top - bot) > 1
srch = Int((top + bot) / 2)
Get #1, srch, a$
Select Case a$
Case Is = Word$
Found = 1
Exit While
Case Is < Word$
bot = srch
Case Is > Word$
top = srch
End Select
Wend
Close
If Found = 0 Then
fail = 1
Play bad$
red
Centre "The word is not in the Dictionary", 33
_Delay .5: WIPE "33"
GoTo AllChecksDone ' word not found - set Fail flag, goto Done
Else
yellow: Centre "word is ok", 33
_Delay .5: WIPE "33"
End If
CheckLetters: ' check in Hi and Lo for each letter - if neither, set Fail, goto Done
For a = 1 To Len(Word$)
LetterOK = 0 ' assume letter will be bad
l$ = Mid$(Word$, a, 1) ' get letter
FindHigh:
po = InStr(Hi$, l$) ' find its position in Hi$
If po > 0 Then
Mid$(Hi$, po, 1) = LCase$(Mid$(Hi$, po, 1)) ' if found, change HiCher letter to lower case,
Value = Value + 10 ' inc value 10 points,
GoTo LetterChecked ' and get next letter
End If
FindLow: ' check if it's in Low$ string
po = InStr(Low$, l$) ' find its position in Low$
If po > 0 Then
Mid$(Low$, po, 1) = LCase$(Mid$(Low$, po, 1)) ' if found, change LoCher letter to lower case,
Value = Value + 5 ' and inc value 5 points
Else
fail = 1 ' but if not, letter is nowhere so set fail,
Exit For ' and don't check any more letters
End If
LetterChecked: ' jump here for next letter until all checked
Next
LetterCheckResult:
If fail = 1 Then
Play bad$: Value = 0
txt$ = "Letter missing or duplicated (" + l$ + ")"
red: Centre txt$, 33: Sleep 2: WIPE "33"
Else
Play "o4l32c"
For a = 1 To Len(Word$): Value = Value + a: Next ' if all letters were good, add length bonus
End If
AllChecksDone: ' all word checking finished - Fail will be set with value zero, or word value found
If fail = 1 Then
Word$ = LCase$(Word$): Word$ = "(" + Word$ + ")" ' change failed words to lower case in brackets
If Time > 0 Then Time = 0 ' failed words get no time bonus, but lose points for excess time
End If
Value = Value + Time ' add time bonus to Value
Score(Plr) = Score(Plr) + Value
Words$(Plr, Round) = Word$ ' add word to player's word list
RoundWords$(Goes) = Word$ ' store word in list of words for this round, to check for repeats
txt$ = "Score (time-adjusted) is " + Str$(Value)
Centre txt$, 20: Sleep 1: WIPE "1720"
End Sub
Sub finish
Cls
txt$ = " "
For a = 1 To NP
txt$ = txt$ + Name$(a) + ": " + LTrim$(Str$(Score(a))) + " "
yellow: WIPE "02": Centre txt$, 12:
Next: Print
For a = 1 To NP
yellow: Print Name$(a); ":";: white
For B = 1 To NRounds: Print Words$(a, B); " ";: Next
Print
Next
Winner = 1
For a = 1 To NP
If Score(a) > Score(Winner) Then Winner = a
Next
If NP > 1 Then txt$ = "Congratulations, " + Name$(Winner): yellow: Centre txt$, 23
If Score(Winner) > Record Then
Record = Score(Winner): RecName$ = Name$(Winner)
Open "CherryTop" For Output As #1
Write #1, Record, RecName$
Close
End If
Sleep: System
End Sub
Sub WIPE (ln$)
If Len(ln$) = 1 Then ln$ = "0" + ln$ ' catch single-digit line numbers
For a = 1 To Len(ln$) - 1 Step 2
wl = Val(Mid$(ln$, a, 2))
Locate wl, 1: Print Space$(CPL)
Next
End Sub
Sub Centre (txt$, linenum)
ctr = Int(CPL / 2 - Len(txt$) / 2) + 1
Locate linenum, ctr
Print txt$
End Sub
Sub white
Color _RGB(255, 255, 255)
End Sub
Sub red
Color _RGB(255, 0, 0)
End Sub
Sub dkred
Color _RGB(200, 0, 0)
End Sub
Sub yellow
Color _RGB(255, 255, 0)
End Sub
Sub Instructions
yellow: Centre "Cherry Pie", 3
Centre " A word game for up to 4 players", 4
white: Print
Print " In the orchard stands a cherry tree, loaded with juicy cherries. There are"
Print " some on the lower branches, but the nicest ones are up high, and are more"
Print " difficult to reach. Players pick cherries to make a delicious cherry pie.": Print
Print " The cherries are represented by letters. The lower branches hold 9 of the"
Print " more common letters, and will always include two vowels, while The upper"
Print " branches hold 6 of the less common letters. For each round, players are"
Print " shown the 15 "; Chr$(34); "cherries"; Chr$(34); ", and take turns to bake a";
Print " "; Chr$(34); "pie"; Chr$(34); ", by forming a word";
Print " from the letters.": Print
Print " Legitimate words score points for each letter. Each common letter scores 5"
Print " points, and uncommon letters score 10 points. Extra points are also scored"
Print " based on the word's length. Words that have already been used in that round"
Print " score zero. A Time allowance of 30 points is also given, which reduces for"
Print " each second used. After all players have played, a new tree is presented.": Print
Print " The game has 12 rounds, with players taking turns to play first each round.": Print
txt$ = "Record score is" + Str$(Record) + " by " + RecName$
Centre txt$, 24
yellow: Centre "Press a key to start", 26
dkred
Circle (570, 620), 22: Paint (570, 620)
Circle (520, 670), 15: Paint (520, 670)
Circle (470, 640), 18: Paint (470, 640)
Color _RGB(83, 150, 83)
PSet (504, 570)
Draw "ta240nr65ta277nr85ta320nr64ta120nr55u1nr55u1r55"
Draw "ta300r20ta0r15"
Circle (528, 540), 30, , , , .2: Paint (528, 540)
Sleep: Cls
End SubEdit: Just added a Best Score recorder, and changed to optional single player.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, Western Australia.) 
Please visit my Website at: http://oldendayskids.blogspot.com/
Please visit my Website at: http://oldendayskids.blogspot.com/