11-01-2025, 02:14 AM
And finally, one more word-game.
This one started as a mini-Scrabble, then "morphed" into this.
It allows players to use any letter - not just dealt ones; to change letters placed earlier; and to create non-word groups of letters.
They can also choose whether bonus cells (triple word etc.) are used, and how they are used.
This one started as a mini-Scrabble, then "morphed" into this.
It allows players to use any letter - not just dealt ones; to change letters placed earlier; and to create non-word groups of letters.
They can also choose whether bonus cells (triple word etc.) are used, and how they are used.
Code: (Select All)
SW = 1040: SH = 750
Screen _NewImage(SW, SH, 32)
SetFont: F& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font F&
'80x36 text
Common Shared CPR, Ctr, Target, Wd$, WordOK, ModeNum
CPR = Int(SW / _PrintWidth("X")): Ctr = Int((CPR + 1) / 2) ' CPR is chars Per Row, Ctr is horiz centre in this screensize
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' move screen display to horiz centre
OK$ = "o4l32cde": Bad$ = "o3l32edc": Click$ = "o5l32c": Cell$ = "r65d60l65u60"
ModeNum = 0: Target = 200:
Dim Cell(81, 5), Value(26), Name$(4)
Randomize Timer
'VL ' show Variables list
Play OK$
Instructions
GetNames:
Do
NP = NP + 1
Txt$ = "Enter a name for player" + Str$(NP) + " (Space for default, Enter for no more)"
yellow: Centre Txt$, 15: white
Locate 17, 35: Input Nm$
If Nm$ = "" Then NP = NP - 1: Exit Do
If Nm$ = " " Then Nm$ = "PLAYER" + Str$(NP)
If Len(Nm$) > 6 Then Nm$ = Left$(Nm$, 8) ' limit name length to 8 chars
Name$(NP) = UCase$(Nm$) ' change to Upper Case
WIPE "1517"
Play OK$
Centre Name$(NP), 17: _Delay .5 ' display name briefly
WIPE "17"
Loop While NP < 4
If NP = 0 Then NP = 1: Name$(1) = "PLAYER 1" ' if no players entered, use 1 player with default name
Dim Score(NP) ' set up array for scores
Cls: Locate 12, 1
For a = 1 To NP: Print Tab(35); Name$(a): Next ' display all player names briefly
Sleep 1: Cls
SetCells:
For a = 1 To 81
Cell(a, 1) = Int((a - 1) / 9) + 1 ' row number
Cell(a, 2) = Int((a - 1) Mod 9) + 1 ' column number
Cell(a, 4) = 1 ' all cells category 1, no bonus
Next
ColourCells:
white
Line (210, 12)-(812, 568), _RGB(255, 255, 0), BF
Line (220, 20)-(802, 560), _RGB(255, 255, 255), BF ' all cells white
If ModeNum = 2 Then GoTo NoBonus
SetBonusCells:
Data 1,5,9,37,45,73,77,81: ' tw cells
Data 21,25,41,57,61: ' dw cells
Data 23,39,43,59: ' tl cells
Data 3,7,19,27,55,63,75,79: ' dl cells
For a = 1 To 8: Read cellnum: Cell(cellnum, 4) = 5: Next ' cat 5 is tw
For a = 1 To 5: Read cellnum: Cell(cellnum, 4) = 4: Next ' cat 4 is dw
For a = 1 To 4: Read cellnum: Cell(cellnum, 4) = 3: Next ' cat 3 is tl
For a = 1 To 8: Read cellnum: Cell(cellnum, 4) = 2: Next ' cat 2 is dl
TW: ' triple words red
Line (220, 20)-(284, 80), _RGB(220, 0, 0), BF
Line (480, 20)-(544, 80), _RGB(220, 0, 0), BF
Line (740, 20)-(804, 80), _RGB(220, 0, 0), BF
Line (220, 260)-(284, 320), _RGB(220, 0, 0), BF
Line (740, 260)-(804, 320), _RGB(220, 0, 0), BF
Line (220, 500)-(284, 560), _RGB(220, 0, 0), BF
Line (480, 500)-(544, 560), _RGB(220, 0, 0), BF
Line (740, 500)-(804, 560), _RGB(220, 0, 0), BF
DW: ' double words pink
Line (350, 140)-(414, 200), _RGB(255, 160, 160), BF
Line (610, 140)-(674, 200), _RGB(255, 160, 160), BF
Line (350, 380)-(414, 440), _RGB(255, 160, 160), BF
Line (610, 380)-(674, 440), _RGB(255, 160, 160), BF
Line (480, 260)-(544, 320), _RGB(255, 160, 160), BF ' middle cell
TL: ' triple letter dark blue
Line (480, 140)-(544, 200), _RGB(100, 100, 255), BF
Line (350, 260)-(414, 320), _RGB(100, 100, 255), BF
Line (610, 260)-(674, 320), _RGB(100, 100, 255), BF
Line (480, 380)-(544, 440), _RGB(100, 100, 255), BF
DL: ' double letter light blue
Line (350, 20)-(414, 80), _RGB(135, 185, 255), BF
Line (610, 20)-(674, 80), _RGB(135, 185, 255), BF
Line (220, 140)-(284, 200), _RGB(135, 185, 255), BF
Line (740, 140)-(804, 200), _RGB(135, 185, 255), BF
Line (220, 380)-(284, 440), _RGB(135, 185, 255), BF
Line (740, 380)-(804, 440), _RGB(135, 185, 255), BF
Line (350, 500)-(414, 560), _RGB(135, 185, 255), BF
Line (610, 500)-(674, 560), _RGB(135, 185, 255), BF
NoBonus:
ShowBonusCells:
yellow: Locate 9, 3: Print "Bonus Mode:"
Select Case ModeNum
Case 0
Print " Single Use"
Case 1
Print " Multiple use"
Case 2
Print " No bonuses"
End Select
If ModeNum <> 2 Then
yellow: Locate 12, 3: Print "Double Letter"
Line (2, 221)-(16, 235), _RGB(135, 185, 255), BF
yellow: Locate 14, 3: Print "Triple Letter"
Line (2, 261)-(16, 275), _RGB(100, 100, 255), BF
yellow: Locate 16, 3: Print "Double Word"
Line (2, 301)-(16, 315), _RGB(255, 160, 160), BF
yellow: Locate 18, 3: Print "Triple Word"
Line (2, 341)-(16, 355), _RGB(220, 0, 0), BF
End If
yellow: Locate 9, 66: Print "Target:"; Target
LetterValues: ' for A to Z
Restore LetterValues
Data 1,3,3,2,1,4,2,4,1,8,5,1,3,1,1,3,9,1,1,1,1,4,4,8,4,9
For a = 1 To 26: Read Value(a): Next ' A to Z and Blank
ShowCellEdges:
boardleft = 154: boardtop = 20
Color _RGB(0, 0, 0) ' show cell lines for white cells
For b = 1 To 9
For a = 1 To 9
PSet (boardleft + a * 65, boardtop)
Draw Cell$
Next
boardtop = boardtop + 60
Next
ShowLetterValues:
yellow
Centre "Letter Values", 33
Txt$ = " "
For a = 1 To 26: Txt$ = Txt$ + Chr$(a + 64) + " ": Next ' show letters
Centre Txt$, 35
Txt$ = " "
For a = 1 To 26: Txt$ = Txt$ + LTrim$(Str$(Value(a))) + " ": Next ' show letter-values
white: Centre Txt$, 36: yellow
Line (187, 675)-(863, 720), , B
PSet (187, 675): For a = 1 To 26: Draw "r26nd45": Next
RandomFfirstPlayer:
Plr = Int(Rnd * NP) + 1
GameLoop:
Do
NextPlayer:
Plr = Plr + 1: If Plr > NP Then Plr = 1
ShowScores:
For a = 1 To NP
yellow: Locate 12 + a, 66: Print Name$(a); ":"; Tab(75); Score(a)
Next
Play OK$
yellow
AnnouncePlayer:
Txt$ = Name$(Plr) + " playing"
Centre Txt$, 30
GetLetter:
yellow
WIPE "31": Centre "Choose a letter, then a Board location", 31
Do: i = _MouseInput: Loop Until Not _MouseButton(1) ' wait until mouse button released
Do: Do: i = _MouseInput: Loop Until _MouseButton(1) ' wait for left mouse button
Mx = _MouseX: My = _MouseY
If My > 674 And My < 721 Then ' if mouse is in letters list area
Letter$ = Chr$(Int((Mx - 187) / 26) + 65) ' use mouse horiz position to calculate Letter$
Play Click$: Exit Do ' got a letter, now find a Place for it
End If
Loop
GetPlace:
Do: i = _MouseInput: Loop Until Not _MouseButton(1)
Do: i = _MouseInput: Loop Until _MouseButton(1)
Mx = _MouseX: My = _MouseY
If My < 21 Or My > 561 Then GoTo GetPlace ' board area
CellV = Int((My - 21) / 60) + 1 ' screen row number
CellH = Int((Mx - 219) / 65) + 1 ' screen column number
tx = Mx - ((Mx - 220) Mod 65) + 1 ' get pixel inside lhs edge of cell
Place = (CellV - 1) * 9 + CellH
CheckIfSwapped: ' each letter can only be swapped once
If Cell(Place, 5) = 1 Then
Play Bad$: WIPE "31": Red: WIPE "31": Centre "A letter can only be swapped once!", 31: Sleep 2: GoTo GetLetter
End If
CheckIfSameLetter: ' Letter change must be to a different letter
If Cell(Place, 3) = Asc(Letter$) Then
Play Bad$: Red: WIPE "31": Centre "Replacement must be a different letter!", 31: Sleep 2: WIPE "31": GoTo GetLetter
End If
CheckIfCellVacant:
If Cell(Place, 3) > 64 Then Cell(Place, 5) = 1 ' if cell was already occupied, set flag to indicate swap is being made
bgc& = Point(tx, My) ' get cell background colour
Color _RGB(0, 0, 0), bgc& ' set colour to black with same background colour
Locate CellV * 3, CellH * 5 + 15: Print Letter$
Cell(Place, 3) = Asc(Letter$) ' put ascii of letter in Cell attribute 3
HorizWord: ' find horizontal word
WdVal = 0: Wd$ = ""
EndA = Place: EndB = Place ' both ends of word start as selected cell (Place)
While Cell(EndA, 2) > 1 ' while not in column 1
If Cell(EndA - 1, 3) < 65 Then Exit While ' if cell on left is vacant, left end has been passed, skip
EndA = EndA - 1 ' otherwise, move left 1 column (1 cell)
Wend
While Cell(EndB, 2) < 9 ' while column in column 9
If Cell(EndB + 1, 3) < 65 Then Exit While ' if cell on right is vacant, right end has been passed, skip
EndB = EndB + 1 ' otherwise, move right 1 cell
Wend
For a = EndA To EndB
Wd$ = Wd$ + Chr$(Cell(a, 3)) ' horiz word includes all cells from EndA to EndB
Next
CheckWord ' checkif word has at least 2 letters and is a genuine word
If WordOK = 1 Then ' if word is ok
HorizWordValue:
For a = EndA To EndB Step 1 ' for each letter from enda to endb
letr = Cell(a, 3) - 64 ' alphabet position of letter
LetrVal = Value(letr) ' value of letter at this alphabet position
If Cell(a, 4) < 4 Then
LetrVal = LetrVal * Cell(a, 4)
End If
WdVal = WdVal + LetrVal ' add this letter value to word value
Next
For a = EndA To EndB Step 1
If Cell(a, 4) = 4 Then WdVal = WdVal * 2
If Cell(a, 4) = 5 Then WdVal = WdVal * 3
Next
End If
WV1 = WdVal
VertWord: ' find vertical word
WdVal = 0: Wd$ = ""
EndA = Place: EndB = Place ' both ends of word start as selected cell (Place)
While Cell(EndA, 1) > 1 ' while not in column 1
If Cell(EndA - 9, 3) < 65 Then Exit While ' if cell on left is vacant, left end has been passed, skip
EndA = EndA - 9 ' otherwise, move left 1 column (1 cell)
Wend
While Cell(EndB, 1) < 9 ' while column in column 9
If Cell(EndB + 9, 3) < 65 Then Exit While ' if cell on right is vacant, right end has been passed, skip
EndB = EndB + 9 ' otherwise, move right 1 cell
Wend
For a = EndA To EndB Step 9
Wd$ = Wd$ + Chr$(Cell(a, 3)) ' horiz word includes all cells from EndA to EndB
Next
CheckWord ' checks word has at least 2 letters and is a genuine word
If WordOK = 1 Then ' if word is ok
VertWordValue:
For a = EndA To EndB Step 9 ' for each letter from enda to endb
letr = Cell(a, 3) - 64 ' alphabet position of letter
LetrVal = Value(letr) ' value of letter at this alphabet position
If Cell(a, 4) < 4 Then
LetrVal = LetrVal * Cell(a, 4)
End If
WdVal = WdVal + LetrVal ' add this letter value to word value
Next
For a = EndA To EndB Step 9
If Cell(a, 4) = 4 Then WdVal = WdVal * 2
If Cell(a, 4) = 5 Then WdVal = WdVal * 3
Next
End If
WV2 = WdVal
Txt$ = "horizontal:" + Str$(WV1) + " Vertical:" + Str$(WV2)
yellow: WIPE "31": Centre Txt$, 31: Sleep 1
Score(Plr) = Score(Plr) + WV1 + WV2
If ModeNum = 2 Then Cell(Place, 4) = 1 ' for mode 2, change bonus cat to 1 (no bonus)
CheckTargetScore:
If Score(Plr) >= Target Then
Cls: yellow: Centre "Finished", 12
white: Locate 14, 1
For a = 1 To NP
Print Tab(34); Name$(a); Tab(45); Score(a)
Next
yellow: Txt$ = "Congratulations, " + Name$(Plr)
Centre Txt$, 15 + NP
Sleep: System
End If
If ModeNum = 0 Then
RemoveBonus:
h = Cell(Place, 2) * 65 + 155: V = Cell(Place, 1) * 60 - 39
white: Line (h, V)-(h + 63, V + 58), , BF
Black: Locate Cell(Place, 1) * 3, Cell(Place, 2) * 5 + 15
Print Chr$(Cell(Place, 3))
Cell(Place, 4) = 1
End If
Loop
Sub CheckWord ' dictionary check is ok, wordok for Vert fails
WordOK = 0 ' initially, flag Wd$ is not a word
If Len(Wd$) < 2 Then Wd$ = "": GoTo Done
Open "R_ALL15" For Random As #1 Len = 19 ' open word list
FL = LOF(1) \ 19 + 1 ' get File Length of word-list
First = 0: Last = FL ' set range to search all words
While Abs(First - Last) > 1 ' while range is > 1
Srch = Int((First + Last) / 2) ' find word at mid-point of range
Get #1, Srch, a$ ' get that word (call it a$)
Select Case a$
Case Is = Wd$
WordOK = 1: Exit While ' if same as Wd$, Wd$ is good, stop searching
Case Is < Wd$
First = Srch ' if less than Wd$, reduce range to top half
Case Is > Wd$
Last = Srch ' if greater than Wd$, reduce range to bottom half
End Select
Wend ' repeat loop if range is > 1 and still not found
Done:
Close
End Sub
Sub yellow
Color _RGB(255, 255, 0), _RGB(0, 0, 0)
End Sub
Sub white
Color _RGB(255, 255, 255), _RGB(0, 0, 0)
End Sub
Sub Red
Color _RGB(200, 0, 0), _RGB(0, 0, 0)
End Sub
Sub Black
Color _RGB(0, 0, 0), _RGB(255, 255, 255)
End Sub
Sub WIPE (Rows$) ' erase rows of text
If Len(Rows$) = 1 Then Rows$ = "0" + Rows$ ' extend single digit row numbers to 2 digits
For A = 1 To Len(Rows$) - 1 Step 2
WipedLine = Val(Mid$(Rows$, A, 2))
Locate WipedLine, 1: Print Space$(CPR - 1); ' print row of spaces in selected row
Next
End Sub
Sub Centre (Txt$, RowNum) ' centre text on row
Ctr = Int(CPR / 2 - Len(Txt$) / 2) + 1 ' text centre column for this screen setting
Locate RowNum, Ctr
Print Txt$;
End Sub
Sub Instructions
Cls
yellow: Centre "Morpheus", 3
Centre "A word game for up to 4 players", 4: white: Print: Print
Print " Morpheus means "; Chr$(34); "Shaper"; Chr$(34); ", and is the name of the Greek god of dreams. In this"
Print " game players shape words at will, to create new words and score points.": Print
Print " It has some features similar to those in Scrabble, with some changes:"
Print " * Players have access to unlimited letters, not just dealt ones."
Print " * Choice of Bonus Cells:"
Print Tab(29); "Permanent bonus cells"
Print Tab(29); "Single-Use bonus cells"
Print Tab(29); "No bonus cells at all"
Print " * Letters that have been played can be changed to form new words later."
Print " * Groups of letters that are not words are allowed - but score no points.": Print
Print " At the start, the board and the values of each alphabet letter are displayed."
Print " A random first player is selected, and players then take turns to place one"
Print " letter of their choosing on any square, including occupied ones, but these"
Print " can only be changed once, and only to a different letter (this is optional).": Print
Print " The computer scans for any words created by the new letter, and points are"
Print " awarded for these. Each word must be complete, with no extra letters at their"
Print " ends. Two words may be formed with each turn, one vertical and one horizontal.": Print
Print " For scoring, the value of letters in the word is calculated, then any Multiple"
Print " Letter bonuses are included, and finally, any Multiple Word bonuses. Groups of"
Print " letters that don't constitute words are allowed, but are ignored."
Print " The game ends when one player reaches a selected target score."
Options:
yellow: Centre "Press Enter to start, or", 32: white
yellow: Print Tab(14); "B";: white: Print " to change action of Bonus Cells (default Single Use)"
yellow: Print Tab(14); "W";: white: Print " to change Winning Score target (default 200 points)"
K$ = UCase$(InKey$): If K$ = "" Then GoTo Options
If K$ = "B" Then Mode: GoTo Options
If K$ = "W" Then WinLevel: GoTo Options
Cls
End Sub
Sub Mode
Cls
yellow
Centre "Press 1 for Permanent bonus cells, 2 for No bonus cells", 12
Centre "Enter for default Single Use bonus cells", 13
GetMode:
k$ = InKey$: If k$ = "" Then GoTo GetMode
ModeNum = Val(k$)
Cls
Select Case ModeNum
Case 1
Centre "Permanent bonus cells selected", 14
Case 2
Centre "No bonus cells will be used", 14
Case Else
ModeNum = 0
Centre "Default Single Use bonus cells", 14
End Select
Centre txt$, 12: Sleep 1
WIPE "121314"
End Sub
Sub WinLevel
yellow
Cls
Centre "Target for winning score? (min 20, default 200)", 12
white
Locate 14, 39: Input Target$
Target = Val(Target$)
If Target < 20 Then Target = 200
Cls
yellow
txt$ = "Target score set at" + Str$(Target)
WIPE "14": Centre txt$, 14: Sleep 1
WIPE "1214"
End Sub
Sub VL
' Variables List
yellow: Centre "Morpheus Variables List", 2: white: Print
Print "SW, SH"; Tab(22); "screen width and height (pixels) at this screen setting"
Print "F&"; Tab(22); "font path and name (long int)"
Print " MX,MY"; Tab(22); "mouse Horiz and Vert position (pixels)"
Print "CPR"; Tab(22); "Chars Per Row for this screen setting (for centring text)"
Print "Ctr"; Tab(22); "centre text column of screen (for centring)"
Print "OK$,Bad$,Click$"; Tab(22); "sound-effect strings"
Print "Cell$"; Tab(22); "graphics string to draw cells "
Print "Cell(81,5)"; Tab(22); "cell data (1 col, 2 row, 3 char, 4 bonus, 5 swap flag)"
Print "Target"; Tab(22); "target for winning score"
Print "Value(26)"; Tab(22); "value of alphabet letters"
Print "NP"; Tab(22); "number of players"
Print "Plr"; Tab(22); "current player"
Print "Name$()"; Tab(22); "player names"
Print "Score()"; Tab(22); "player scores"
Print "Wd$"; Tab(22); "word being constructed (both horiz and vert)"
Print "EndA, EndB"; Tab(22); "beginning and end cell numbers of word"
Print "WV1,WV2"; Tab(22); "value of current horiz and vert words"
Print "WordOK"; Tab(22); "flag for length and real word check result "
Print "ModeNum"; Tab(22); "bonus mode number - 0 use once, 1 permanent, 2 no bonus"
Print "Txt$"; Tab(22); "string used for compiling text for centring"
Print "Nm$"; Tab(22); "names while being collected"
Print "CellNum"; Tab(22); "number of a cell, used for marking bonus cells"
Print "BoardLeft, BoardTop"; Tab(22); "left and top pixel numbers of board for frame"
Print "Letter$"; Tab(22); "ascii of letter (if any) at given position"
Print "Rows$"; Tab(22); "string of 2-digit row numbers for wiping (clearing)"
Print "WipedLine"; Tab(22); "2-digit identifier for line to be wiped"
Print "RowNum"; Tab(22); "row-number on which to place centred text"
Sleep 1
End Sub
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/