02-09-2025, 01:35 AM
Here's another word-game, Cobble:
Code: (Select All)
' Cobble
SW = 1020: sh = 780
Screen _NewImage(SW, sh, 32)
Common Shared CPL
SetFont: f& = _LoadFont("C:\WINDOWS\fonts\courbd.ttf", 20, "monospace"): _Font f& ' choose monospace font
SMode = 32
CPL = SW / _PrintWidth("X") ' find chars per line for this window width
lhs = (_DesktopWidth - CPL) / 2 ' find position for LHS of window
_ScreenMove (_DesktopWidth - SW) / 2, 90 ' place window there
Randomize Timer
Common Shared Tiles$(), Values(), Racks$(), RacksCopy$(), Shares$(), SharesCopy$(), Names$(), Scores(), Swop
Common Shared NP, Plr, Plr$, NextTile, Points, Passes, ThisWord$, L$, L, k, NWords(), Words$(), Tiles$(), LetrValue
Common Shared OK$, Bad$, TimeSpent
'tiles - a "mix" to ensure more usable letters are prominent
Data "A","A","A","A","A","A","B","B","B","C","C","C","C","D","D","D","D","E","E","E","E","E","E","E","F"
Data "F","F","F","G","G","G","H","H","H","H","I","I","I","I","I","J","J","K","K","L","L","L","L","M","M"
Data "M","M","N","N","N","N","N","O","O","O","O","O","P","P","P","Q","Q","R","R","R","R","R","S","S","S"
Data "S","S","T","T","T","T","T","T","U","U","U","U","V","V","V","W","W","W","X","X","Y","Y","Y","Z","Z"
' letter values
Data 1,4,3,2,1,3,4,2,1,9,7,3,3,1,1,5,9,1,1,1,3,5,5,7,4,9
OK$ = "o3l32cg": Bad$ = "o2l16gc"
If Not _FileExists("R_ALL15") Then
Play Bad$
yellow: Centre "Random access dictionary file R_ALL15 must be in the same folder as Cobbler.exe", 12
Centre "Press a key", 14
Sleep: System
End If
Play "o3l16cego4c"
Instructions
While InKey$ <> "": Wend
DimsAndPresets:
Dim Tiles$(100), Values(26), Shares$(7), SharesCopy$(7), Names$(4) ' we'll dim scores(np) and racks$(np,7) after np set
For a = 1 To 100: Read Tiles$(a): Next
ShuffleTiles:
For a = 1 To 100
Swop = Int(Rnd * 100) + 1
Swap Tiles$(a), Tiles$(Swop)
Next
GetNames:
Do
WIPE "14"
Plr$ = ""
Play OK$
Locate 14, 14: yellow
Print "Name for player"; NP + 1; "(or just <ENTER> to finish) ";: Input Plr$
If Len(Plr$) < 1 Then
If NP = 0 Then NP = 1: Names$(1) = "SOLO"
Cls: Exit Do
End If
NP = NP + 1
Names$(NP) = UCase$(Plr$)
Locate 16, 40 - Len(Plr$) / 2
Centre Names$(NP), 16: _Delay .3: WIPE "16"
Loop Until NP = 4
GetTiles:
WIPE "14"
NextTile = 1
Dim Racks$(NP, 7), RacksCopy$(NP, 7), Scores(NP), NWords(NP), Words$(NP, 15)
For a = 1 To NP
For b = 1 To 7
Racks$(a, b) = Tiles$(NextTile)
Tiles$(NextTile) = " "
NextTile = NextTile + 1
Next
numtiles = 7
Next
For a = 1 To 7
Shares$(a) = Tiles$(NextTile)
Tiles$(NextTile) = " "
NextTile = NextTile + 1
Next
GetValues:
yellow: Locate 28, 35: Print "LETTER VALUES"
Locate 29, 15
Print " ";: For a = 1 To 26: Print Chr$(a + 64); " ";: Next: Print
Locate 30, 15
white: For a = 1 To 26: Read Values(a): Print Using "##"; Values(a);: Next
yellow
PSet (186, 557): Draw "r682d45l682u45"
SetUpRacks:
Play OK$
Locate 2, 35: Print "Share BOX"
white
Locate 3, 36
For a = 1 To 7
Print Shares$(a);
Next
yellow: PSet (440, 38): Draw "r116d22l116u22"
Locate 6, 35: Print "YOUR RACK"
PSet (440, 118): Draw "r116d22l116u22"
white
Locate 7, 36
For a = 1 To 7
Print Racks$(Plr, a);
Next
Locate 10, 35: yellow: Print "YOUR WORD"
PSet (393, 198): Draw "r213d22l213u22"
white: Locate 11, 32: Print Space$(15)
StartPlayer:
If Passes >= NP Then finish
WIPE "3233"
yellow: Locate 33, 37: Print "Passes:"; Passes
numinrack = 7
For a = 1 To 7 ' count blanks of prev player to see if any tiles left
If Racks$(Plr, a) = " " Then numinrack = numinrack - 1
Next
For a = 1 To 7 ' fill used Hand tiles, and delete from bag
If Racks$(Plr, a) = " " Then
Racks$(Plr, a) = Tiles$(NextTile)
Tiles$(NextTile) = " "
If NextTile < 100 Then NextTile = NextTile + 1
End If
Next
For a = 1 To 7 ' fill used Shares rack, if tiles available
If Shares$(a) = " " Then
Shares$(a) = Tiles$(NextTile)
Tiles$(NextTile) = " "
If NextTile < 100 Then NextTile = NextTile + 1
End If
Next
txt$ = "UNUSED:" + Str$(100 - NextTile)
Centre Space$(10), 19
Centre txt$, 19
PSet (435, 357): Draw "r160d22l160u22"
Locate 2, 5: Print "SCORES": white
Locate 3, 1: Print " "
For a = 1 To NP
Locate 2 + a, 2: Print Names$(a); Tab(12); Scores(a)
Next
Plr = Plr + 1: If Plr > NP Then Plr = 1 ' inc player
For a = 1 To 7
RacksCopy$(Plr, a) = Racks$(Plr, a)
SharesCopy$(a) = Shares$(a)
Next
ThisWord$ = "": Points = 0: LetrValue = 0: Locate 11, 32: Print Space$(14): Locate 11, 45: Print " "
Plr$ = Names$(Plr)
WIPE "14": txt$ = Names$(Plr) + " playing": yellow: Centre txt$, 14
WIPE "16": Centre "Pick a letter. To restart your word press <Space> ", 15
Centre "Enter to pass", 16: white
Locate 3, 36: For a = 1 To 7: Print Shares$(a);: Next
Locate 7, 36: For a = 1 To 7: Print Racks$(Plr, a);: Next
PlayerAction:
T1 = Timer ' time is zero
yellow: PSet (393, 198): Draw "r213d22l213u22"
GetAKey:
k$ = InKey$
If k$ = "" Or Len(k$) > 1 Then GoTo GetAKey
L$ = UCase$(k$)
L = Asc(L$)
Select Case L
Case 13 ' enter to finish this try
T2 = Timer: TimeSpent = Int(T2 - T1) ' get time spent
WIPE "1516"
Play "o3l16g"
If Len(ThisWord$) < 2 Then
Passes = Passes + 1
Scores(Plr) = Scores(Plr) - TimeSpent
txt$ = txt$ + " Time-Adjust:" + Str$(TimeSpent) + " Points: -" + Str$(TimeSpent): Centre txt$, 24
Sleep 2: WIPE "24"
GoTo StartPlayer
End If
WordCheck ' has submitted word, now check it
GoTo StartPlayer ' after checking, get next player
Case 32 ' pressed Space to restart word
Play "o4l16ec"
Locate 11, 50: Print " "
Locate 11, 32: Print Space$(14)
ThisWord$ = "": LetrValue = 0 ' reset letrvalue to zero
Locate 3, 36
For a = 1 To 7
Shares$(a) = SharesCopy$(a)
Print Shares$(a);
Next
Locate 7, 36
For a = 1 To 7
Racks$(Plr, a) = RacksCopy$(Plr, a)
Print Racks$(Plr, a);
Next
GoTo GetAKey
Case 65 To 96 ' letter
'check rack
found = 0
For a = 1 To 7
If L$ = Racks$(Plr, a) Then ' search for this letter in player rack
found = 1: Play OK$
Racks$(Plr, a) = " " ' if found, clear it from rack$, re-display player rack,
Locate 7, 36
For b = 1 To 7
Print Racks$(Plr, b);
Next
ThisWord$ = ThisWord$ + L$ ' add it to ThisWord$,
Locate 11, 39 - Len(ThisWord$) / 2: Print ThisWord$;
yellow: PSet (393, 198): Draw "r213d22l213u22": white
LV = Values(L - 64) ' findits value,
LetrValue = LetrValue + LV ' add its value to LetrValue running total,
Locate 11, 50: Print LetrValue
Exit For ' and leave search and go back for another letter
End If
Next
If found = 1 Then GoTo GetAKey ' if it was found in player rack, go back for another letter
'check Shares
For a = 1 To 7
If L$ = Shares$(a) Then ' if not in player's rack, search in Shares rack
found = 1
Play OK$
Shares$(a) = " " ' if found, clear it from Shares$, re-display Shares$ rack,
Locate 3, 36
For b = 1 To 7
Print Shares$(b);
Next
ThisWord$ = ThisWord$ + L$ ' and add it to thisword$,
Locate 11, 39 - Len(ThisWord$) / 2: Print ThisWord$
LV = Values(L - 64) ' find its value,
LetrValue = LetrValue + LV ' add its value to LetrValue running total,
Locate 11, 50: Print LetrValue
Exit For ' and go back for another letter
End If
Next
If found = 0 Then Play Bad$ ' if no found in either rack,signal bad letter
GoTo GetAKey ' and go back for another letter
End Select
'------------------------------------------------------------------- subs -----------------------------------------------------
Sub WordCheck ' we have the submitted word, with its letter value total
If Len(ThisWord$) < 2 And TimeSpent <= 5 Then Exit Sub
LenBonus = 0
For a = 1 To Len(ThisWord$): LenBonus = LenBonus + a: Next ' calculate word-length adjustment
ref$ = "R_ALL15"
Open ref$ For Random As #1 Len = 19
getaword:
wdnum = 0: found = 0
While Not EOF(1)
wdnum = wdnum + 1
Get #1, wdnum, dictword$
If ThisWord$ = dictword$ Then found = 1: Play OK$: Exit While ' word was found in dictionary
Wend
Close
Score:
If found = 0 Then
Play Bad$
red
If Len(ThisWord$) > 1 Then
Centre "The word is not in the Dictionary", 23
End If
TimeAdjust = TimeSpent
Points = LetrValue + LenBonus + TimeSpent
txt$ = "Letters:-" + LTrim$(Str$(LetrValue)) + " Length:-" + LTrim$(Str$(LenBonus)) + " Time:" + LTrim$(Str$(TimeSpent))
txt$ = txt$ + " Time-Adjust:" + LTrim$(Str$(TimeAdjust)) + " Points:-" + LTrim$(Str$(Points)): Centre txt$, 24
Scores(Plr) = Scores(Plr) - Points
Else
Play OK$
yellow: Centre "The word is accepted", 23
TimeAdjust = 15 - TimeSpent
Points = LetrValue + LenBonus + TimeAdjust
txt$ = "Letter Values:" + LTrim$(Str$(LetrValue)) + " Length:" + LTrim$(Str$(LenBonus))
txt$ = txt$ + " Time-Adjust:" + Str$(TimeAdjust) + " Points:" + Str$(Points): Centre txt$, 24
Scores(Plr) = Scores(Plr) + Points
NWords(Plr) = NWords(Plr) + 1
Words$(Plr, NWords(Plr)) = ThisWord$
Passes = 0
End If
Sleep 4: WIPE "2324": white
End Sub
Sub finish
Cls
Play "o3l16cego4c"
yellow: Centre "Final Scores", 2
top = 5: topscore = 0
For a = 1 To NP
yellow
Locate top + 1, 30
Print Names$(a); Tab(45); "Score: "; Scores(a)
If Scores(a) > topscore Then topscore = Scores(a): winner = a
white: Locate top + 2, 2
For b = 1 To 15
Print Words$(a, b);: Print " ";
Next
top = top + 5
Next
If topscore = 0 Then Names$(winner) = "ME !!!"
txt$ = "And the winner is " + Names$(winner)
yellow: Centre txt$, top + 4
Sleep: System
End Sub
Sub Instructions
yellow: Centre "COBBLE", 3
Centre "A word-building game for up to 4 players", 4
white: Print
Print " A bag of tiles is presented, each tile holding a letter worth from 1 to 9"
Print " points, and players take turns to ";: yellow: Print "Cobble";: white: Print " words from these."
Print
Print " Players are each dealt 7 tiles, and another 7 tiles are placed in the";: yellow: Print " Share": white
Print " box to be shared by all players. Points are scored based on:": Print
yellow: Print Tab(15); "Tile values";: white: Print " as shown on the game screen during play"
yellow: Print Tab(15); "Word length";: white: Print " 1 point for first letter, 2 for next etc."
yellow: Print Tab(15); "Time taken";: white: Print " 15 free points, reduced by 1 point per second"
Print
Print " For their turn, a player picks tiles from their rack and/or the Spares box,"
Print " to create a word and score points, or they can ";: yellow: Print "Pass";: white: Print ". If they pass, the"
Print " penalty of 1 point per second taken for their turn still applies."
Print
Print " Players may also ";: yellow: Print "Restart";: white: Print " their selection of letters as often as they like by"
Print " pressing ";: yellow: Print "Space";: white: Print " - but the timer continues counting."
Print
Print " When a word is entered, used tiles are replaced with fresh ones until there"
Print " are no more remaining in the box. Each word is checked by the computer, and"
Print " only valid words score. Play ends when all players pass consecutively."
yellow: Centre "Press a key to continue", 28
Sleep: Play OK$: Cls
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 yellow
Color _RGB(255, 255, 0)
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/