JackKelly6
Sep 28, 2016
NoMainWin
globalDoneWithWord, BlocksUsed, LetterOKblocks$
dimblock$(20,2), block(20,2)block(20,2), block$(20,2)
'numeric blocks, col 0 flags used block
'default blocks
block(1,1)=asc("B")-64: block(1,2)=asc("O")-64 ' (B O)
block(2,1)=asc("X")-64: block(2,2)=asc("K")-64 ' (X K)
block(3,1)=asc("D")-64: block(3,2)=asc("Q")-64 ' (D Q)
block(4,1)=asc("C")-64: block(4,2)=asc("P")-64 ' (C P)
block(5,1)=asc("N")-64: block(5,2)=asc("A")-64 ' (N A)
block(6,1)=asc("G")-64: block(6,2)=asc("T")-64 ' (G T)
block(7,1)=asc("R")-64: block(7,2)=asc("E")-64 ' (R E)
block(8,1)=asc("T")-64: block(8,2)=asc("G")-64 ' (T G)
block(9,1)=asc("Q")-64: block(9,2)=asc("D")-64 ' (Q D)
block(10,1)=asc("F")-64: block(10,2)=asc("S")-64 ' (F S)
block(11,1)=asc("J")-64: block(11,2)=asc("W")-64 ' (J W)
block(12,1)=asc("H")-64: block(12,2)=asc("U")-64 ' (H U)
block(13,1)=asc("V")-64: block(13,2)=asc("I")-64 ' (V I)
block(14,1)=asc("A")-64: block(14,2)=asc("N")-64 ' (A N)
block(15,1)=asc("O")-64: block(15,2)=asc("B")-64 ' (O B)
block(16,1)=asc("E")-64: block(16,2)=asc("R")-64 ' (E R)
block(17,1)=asc("F")-64: block(17,2)=asc("S")-64 ' (F S)
block(18,1)=asc("L")-64: block(18,2)=asc("Y")-64 ' (L Y)
block(19,1)=asc("P")-64: block(19,2)=asc("C")-64 ' (P C)
block(20,1)=asc("Z")-64: block(20,2)=asc("M")-64 ' (Z M)
[FillAlphaBlocks]
block$(1,1)=chr$(block(1,1)+64): block$(1,2)=chr$(block(1,2)+64)block$(2,1)=chr$(block(2,1)+64): block$(2,2)=chr$(block(2,2)+64)block$(3,1)=chr$(block(3,1)+64): block$(3,2)=chr$(block(3,2)+64)block$(4,1)=chr$(block(4,1)+64): block$(4,2)=chr$(block(4,2)+64)block$(5,1)=chr$(block(5,1)+64): block$(5,2)=chr$(block(5,2)+64)block$(6,1)=chr$(block(6,1)+64): block$(6,2)=chr$(block(6,2)+64)block$(7,1)=chr$(block(7,1)+64): block$(7,2)=chr$(block(7,2)+64)block$(8,1)=chr$(block(8,1)+64): block$(8,2)=chr$(block(8,2)+64)block$(9,1)=chr$(block(9,1)+64): block$(9,2)=chr$(block(9,2)+64)block$(10,1)=chr$(block(10,1)+64): block$(10,2)=chr$(block(10,2)+64)block$(11,1)=chr$(block(11,1)+64): block$(11,2)=chr$(block(11,2)+64)block$(12,1)=chr$(block(12,1)+64): block$(12,2)=chr$(block(12,2)+64)block$(13,1)=chr$(block(13,1)+64): block$(13,2)=chr$(block(13,2)+64)block$(14,1)=chr$(block(14,1)+64): block$(14,2)=chr$(block(14,2)+64)block$(15,1)=chr$(block(15,1)+64): block$(15,2)=chr$(block(15,2)+64)block$(16,1)=chr$(block(16,1)+64): block$(16,2)=chr$(block(16,2)+64)block$(17,1)=chr$(block(17,1)+64): block$(17,2)=chr$(block(17,2)+64)block$(18,1)=chr$(block(18,1)+64): block$(18,2)=chr$(block(18,2)+64)block$(19,1)=chr$(block(19,1)+64): block$(19,2)=chr$(block(19,2)+64)block$(20,1)=chr$(block(20,1)+64): block$(20,2)=chr$(block(20,2)+64)'blocks$="BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
blocks$=""
for x=1 to 20
for y=1 to 2
blocks$=blocks$+chr$(block(x,y)+64)
next y
if x<20 then blocks$=blocks$+" "
next x
if NewBlocks then call DisplayBlocks: wait
'set up the word list
dim w$(25)
w$(1)="A"
w$(2)="BARK"
w$(3)="BOOK"
w$(4)="TREAT"
w$(5)="COMMON"
w$(6)="SQUAD"
w$(7)="CONFUSE"
WindowWidth = 800 : WindowHeight = 600
BackgroundColor$="191 191 255"
'statictext #win.debug, "Debug Line", 0, 0, 785, 17
statictext #win.Title, "Rosetta Code - ABC Problem", 55, 35, 277, 45
stylebits #win.BlockSet, _ES_READONLY, _WS_HSCROLL or _WS_VSCROLL or _WS_DLGFRAME, 0, 0
texteditor #win.BlockSet, 55, 100, 160, 240
statictext #win.Caption1, "Block Set", 100, 350, 100, 25
button #win.NewBlocks, "New Blocks", [NewBlocksClick], ul, 230, 100, 130, 40
textbox #win.NewWord, 380, 110, 157, 25
combobox #win.WordList, w$(), [ListClick], 380, 160, 174, 21
button #win.Enter, "Enter New Word", [EnterClick], ul, 590, 100, 120, 40
button #win.Quit, "Quit", QuitClick, ul, 590, 160, 120, 40
statictext #win.Result, "", 240, 240, 315, 30
stylebits #win.Solution, _ES_READONLY, _WS_HSCROLL or _WS_DLGFRAME, 0, 0
texteditor #win.Solution, 235, 285, 475, 220
open "Rosetta Code - ABC Problem" for dialog_nf as #win
#win "TrapClose QuitClick"
#win "Font Ariel 10"
#win.BlockSet "!Font Courier_New 12"
#win.Title "!Font Ariel 14 Bold"
#win.NewWord "!Font Courier_New 12"
#win.WordList "!Reload"
#win.WordList "!Word List"
#win.Result "!Font Ariel 12 Bold"
#win.Solution "!Font Courier_New 12"
call DisplayBlocks
wait
[EnterClick]
#win.NewWord "!SelectAll"
#win.NewWord "!Contents? x$"
w$=""
x$=upper$(x$)
for x=1 to len(x$)
y$=mid$(x$,x,1)
if y$>="A" and y$<="Z" then w$=w$+y$
next x
goto [StartWord]
[ListClick]
#win.WordList "Selection? w$"
[StartWord]
if w$="" then wait#win.Result ""#win.Solution "!cls"DoneWithWord=0: BlocksUsed=0l=len(w$): wl=0dim LetterOK(l)if l>10 then#win.Solution "More than 10 letters in word."DoneWithWord=1goto [DoneWithWord]end ifdim alphabet(26,1) 'clear letter-usage arrayfor x=1 to 20 'load block letters into letter-usage array col 0'and clear block 0 cells (used flag)alphabet(block(x,1),0)=alphabet(block(x,1),0)+1alphabet(block(x,2),0)=alphabet(block(x,2),0)+1block(x,0)=0next xfor x=1 to l 'load current word into letter-usage aray col 1wl$=mid$(w$,x,1): w=asc(wl$)-64alphabet(w,1)=alphabet(w,1)+1next xfor x=1 to 26 ' test for more of any letter in the word than in the blocksif alphabet(x,1)>alphabet(x,0) then#win.Solution "More "; chr$(x+64); "s in word than in the blocks."DoneWithWord=1goto [DoneWithWord]waitend ifnext x[NextLetter]if wl<l then wl=wl+1 else goto [DoneWithWord]wl$=mid$(w$,wl,1): w=asc(wl$)-64LetterOK=0' if there's only one of the letter in the blocks then you must use that blockif alphabet(w,0)=1 thencall OnlyBlock wLetterOK(wl)=1if DoneWithWord then goto [DoneWithWord] else goto [NextLetter]end if' if more than one of the letter in the blocks, then try to use one that has' an unused letter on other side (a "Free Block")call FindFreeBlock wif LetterOK then LetterOK(wl)=1goto [NextLetter][DoneWithWord]if BlocksUsed=l thenx=canDo(w$,blocks$)
#win.Result w$; "=";
if x then #win.Result w$+" True"' #win.Solution "Done with word."else #win.Result w$+" False"
waitend ifif DoneWithWord then#win.Result w$; " = False"' #win.Solution "Done with word."waitend iffor x=1 to lif not(LetterOK(x)) thenNumericLetter=asc(mid$(w$,x,1))-64LetterOK=0call OnlyBlock NumericLetterif LetterOK then LetterOK(x)=1 else exit forend ifnext xgoto [DoneWithWord]
[NewBlocksClick]
dim block(20,2)
for x=1 to 20 'A to T go on side 1 of all blocks
block(x,1)=x
next x
for x=21 to 26 'U to Z go on side 2 of random blocks
[a]
y=RandomBlock()
if block(y,2)=0 then block(y,2)=x else goto [a]
next x
for x=1 to 25 'Vowels go on side 2 of random blocks
[b]
y=RandomBlock()
select case x
case 1, 5, 9, 15, 21, 25 'A E I O U and Y
if block(y,2)=0 and block(y,1)<>x then
block(y,2)=x
else
goto [b]
end if
end select
next x
x$="BCDFGHJKLMNPQRST"
for x=1 to 8 'random consonants go on side 2 of remaining blocks
[c]
z=RandomNumber(1,16)
if mid$(x$,z,1)=" " then goto [c]
w=asc(mid$(x$,z,1))-64
mid$(x$,z,1)=" "
[d]
y=RandomBlock()
if block(y,2)=0 and block(y,1)<>w then
block(y,2)=w
else
goto [d]
end if
next x
x$="ABCDEFGHIJKLMNOPQRST"
for x=1 to 20 'shuffle the new blocks
[e]
z=RandomNumber(1,20)
if mid$(x$,z,1)=" " then goto [e]
w=asc(mid$(x$,z,1))-64
mid$(x$,z,1)=" "
block(x,0)=w
next x
sort block(), 1, 20, 0
for x=1 to 20
block(x,0)=0
next x
#win.WordList "SelectIndex 0"
#win.WordList "!Word List"
#win.Result ""
#win.Solution "!cls"
NewBlocks=1
goto [FillAlphaBlocks]
'- - - - - - - - - S U B R O U T I N E S & F U N C T I O N S - - - - - - -
sub OnlyBlock NumericLetterfor x=1 to 20if (block(x, 1)=NumericLetter or block(x, 2)=NumericLetter) _and block(x, 0)=0 thencall UseBlock x, NumericLetterfunction canDo(text$,blocks$)
'print text$,blocks$
'endcase
if len(text$)=1 then canDo=(instr(blocks$,text$)<>0): exitsubfunction
'get next letter
ltr$=left$(text$,1)
'cut
if instr(blocks$,ltr$)=0 then canDo=0: exit function
'recursion
text$=mid$(text$,2) 'rest
'loop by all word in blocks. Need to make "newBlocks" - all but taken
'optimisation: take only fitting blocks
wrd$="*"
i=0
while wrd$<>""
i=i+1
wrd$=word$(blocks$, i)
if instr(wrd$, ltr$) then
'newblocks without wrd$
pos=instr(blocks$,wrd$)
newblocks$=left$(blocks$, pos-1)+mid$(blocks$, pos+3)
canDo=canDo(text$,newblocks$)
'first found cuts
if canDo then exit while
end if
next x#win.Result w$; " = False."#win.Solution "No more "; chr$(NumericLetter+64); "s."DoneWithWord=1wend
endsubsub FindFreeBlock NumericLetterPossibility=0for x=1 to 20if block(x, 0)=0 then 'block not usedif block(x,1)=NumericLetter thenif alphabet(block(x,2),1)=0 thencall UseBlock x, NumericLetterexit subend ifPossibility=Possibility+1end ifif block(x,2)=NumericLetter thenif alphabet(block(x,1),1)=0 thencall UseBlock x, NumericLetterexit subend ifPossibility=Possibility+1end ifend ifnext x' #win.Solution "No free block - "; Possibility; " possible"end subsub UseBlock BlockNumber, NumericLetterblock(BlockNumber, 0)=1 'Mark block as usedBlocksUsed=BlocksUsed+1LetterOK=1#win.Solution chr$(NumericLetter+64); " from "; block$(BlockNumber, 1); block$(BlockNumber, 2)end subfunction
sub QuitClick CallingHandle$
close #win
end
end sub
function RandomBlock()
RandomBlock=RandomNumber(1,20)
end function
function RandomNumber(min, max)
RandomNumber = (int(rnd(1)*(max-min+1))+1)+min-1
end function
sub DisplayBlocks
'blocks$="BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
#win.BlockSet "!cls"
for x=1 to20for y=1 to 2if y=1 then60 step 6
#win.BlockSet "(";block$(x,y);if y=2 thenmid$(blocks$, x, 1);
#win.BlockSet " ";block$(x,y);mid$(blocks$, x+1, 1); ") ";
next yif x mod 2=0 then#win.BlockSet"""("; mid$(blocks$, x+3, 1);
#win.BlockSet " "; mid$(blocks$, x+4, 1); ") "
next x
#win.NewWord "!SetFocus"
end sub