Rosetta Code - ABC Problem, GUI

NoMainWin
global DoneWithWord, BlocksUsed, LetterOK
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]
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)
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=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.Result w$; " = True"
'    #win.Solution "Done with word."
    wait
end if
if DoneWithWord 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 else exit for
    end if
next x
goto [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 NumericLetter
    for x=1 to 20
        if (block(x, 1)=NumericLetter or block(x, 2)=NumericLetter) _
                and block(x, 0)=0 then
            call UseBlock x, NumericLetter
            exit sub
        end if
    next x
    #win.Result w$; " = False."
    #win.Solution "No more "; chr$(NumericLetter+64); "s."
    DoneWithWord=1
end sub
 
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 sub
 
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
    #win.BlockSet "!cls"
    for x=1 to 20
        for y=1 to 2
            if y=1 then #win.BlockSet "("; block$(x,y);
            if y=2 then #win.BlockSet " "; block$(x,y); ")   ";
        next y
        if x mod 2=0 then #win.BlockSet ""
    next x
    #win.NewWord "!SetFocus"
end sub