JackKelly6
Sep 28, 2016
[[code]] 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 waitx=canDo(w$,blocks$) #win.Result"" #win.Solution "!cls" DoneWithWord=0: BlocksUsed=0 l=len(w$): wl=0 dim LetterOK(l) if l>10 then #win.Solution "More than 10 letters in word." DoneWithWord=1 goto [DoneWithWord] end if dim alphabet(26,1) 'clear letter-usage array for 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)+1 alphabet(block(x,2),0)=alphabet(block(x,2),0)+1 block(x,0)=0 next x for x=1 to l 'load current word into letter-usage aray col 1 wl$=mid$(w$,x,1): w=asc(wl$)-64 alphabet(w,1)=alphabet(w,1)+1 next x for x=1 to 26 ' test for more of any letter in the word than in the blocks if alphabet(x,1)>alphabet(x,0) then #win.Solution "More "; chr$(x+64); "s in word than in the blocks." DoneWithWord=1 goto [DoneWithWord] wait end if next x [NextLetter] if wl<l then wl=wl+1 else goto [DoneWithWord] wl$=mid$(w$,wl,1): w=asc(wl$)-64 LetterOK=0 ' if there's only one of the letter in the blocks then you must use that block if alphabet(w,0)=1 then call OnlyBlock w LetterOK(wl)=1 if 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 w if LetterOK then LetterOK(wl)=1 goto [NextLetter] [DoneWithWord] if BlocksUsed=l then #win.Resultw$; "= True" ' #win.Solution "Done with word." wait end if"; ifDoneWithWordx then#win.Result w$; " = False" ' #win.Solution "Done with word." wait end if for x=1 to l if not(LetterOK(x)) then NumericLetter=asc(mid$(w$,x,1))-64 LetterOK=0 call OnlyBlock NumericLetter if LetterOK then LetterOK(x)=1#win.Result w$+" True" elseexit for end if next x goto [DoneWithWord]#win.Result w$+" False" wait [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 NumericLetter for x=1function canDo(text$,blocks$) 'print text$,blocks$ 'endcase if len(text$)=1 then canDo=(instr(blocks$,text$)<>0): exit function '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 to20make "newBlocks" - all but taken 'optimisation: take only fitting blocks wrd$="*" i=0 while wrd$<>"" i=i+1 wrd$=word$(blocks$, i) if(block(x, 1)=NumericLetter or block(x, 2)=NumericLetter) _ and block(x, 0)=0instr(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 thencall UseBlock x, NumericLetter exit subexit while end ifnext x #win.Result w$; " = False." #win.Solution "No more "; chr$(NumericLetter+64); "s." DoneWithWord=1wend endsub sub FindFreeBlock NumericLetter Possibility=0 for x=1 to 20 if block(x, 0)=0 then 'block not used if block(x,1)=NumericLetter then if alphabet(block(x,2),1)=0 then call UseBlock x, NumericLetter exit sub end if Possibility=Possibility+1 end if if block(x,2)=NumericLetter then if alphabet(block(x,1),1)=0 then call UseBlock x, NumericLetter exit sub end if Possibility=Possibility+1 end if end if next x ' #win.Solution "No free block - "; Possibility; " possible" end sub sub UseBlock BlockNumber, NumericLetter block(BlockNumber, 0)=1 'Mark block as used BlocksUsed=BlocksUsed+1 LetterOK=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 to20 for y=1 to 2 if y=1 then #win.BlockSet60 step 6 #win.BlockSet "(";block$(x,y); if y=2 then #win.BlockSetmid$(blocks$, x, 1); #win.BlockSet " ";block$(x,y);mid$(blocks$, x+1, 1); ") ";next y if x mod 2=0 then #win.BlockSet ""#win.BlockSet "("; mid$(blocks$, x+3, 1); #win.BlockSet " "; mid$(blocks$, x+4, 1); ") " next x #win.NewWord "!SetFocus" end sub [[code]]