Rosetta Code - ABC Problem, GUI

Edit 1 3 …
Older Version Newer Version

JackKelly6 JackKelly6 Sep 28, 2016

Review Changes
NoMainWin global blocks$ dim 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] '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] x=canDo(w$,blocks$) #win.Result w$; " "; if x then #win.Result w$+" True" else #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 - - - - - - - function 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 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 wend end function 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 to 60 step 6 #win.BlockSet "("; mid$(blocks$, x, 1); #win.BlockSet " "; mid$(blocks$, x+1, 1); ") "; #win.BlockSet "("; mid$(blocks$, x+3, 1); #win.BlockSet " "; mid$(blocks$, x+4, 1); ") " next x #win.NewWord "!SetFocus" end sub