Data commit

Task/ABC-problem/Liberty-BASIC/abc-problem-1.basic

@@ -0,0 +1,42 @@
+print "Rosetta Code - ABC problem (recursive solution)"
+print
+blocks$="BO XK DQ CP NA GT RE TG QD FS JW HU VI AN OB ER FS LY PC ZM"
+data "A"
+data "BARK", "BOOK", "TREAT", "COMMON", "SQUAD", "CONFUSE"
+data "XYZZY"
+
+do
+    read text$
+    if text$="XYZZY" then exit do
+    print ">>> can_make_word("; chr$(34); text$; chr$(34); ")"
+    if canDo(text$,blocks$) then print "True" else print "False"
+loop while 1
+print "Program complete."
+end
+
+function canDo(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

Task/ABC-problem/Liberty-BASIC/abc-problem-2.basic

@@ -0,0 +1,133 @@
+print "Rosetta Code - ABC problem (procedural solution)"
+print
+w$(1)="A"
+w$(2)="BARK"
+w$(3)="BOOK"
+w$(4)="TREAT"
+w$(5)="COMMON"
+w$(6)="SQUAD"
+w$(7)="CONFUSE"
+
+for x=1 to 7
+    print ">>> can_make_word("; chr$(34); w$(x); chr$(34); ")"
+    if CanMakeWord(w$(x)) then print "True" else print "False"
+next x
+print "Program complete."
+end
+
+function CanMakeWord(x$)
+global DoneWithWord, BlocksUsed, LetterOK, Possibility
+dim block$(20,2), block(20,2)
+'numeric blocks, col 0 flags used block
+block(1,1)=asc("B")-64: block(1,2)=asc("O")-64
+block(2,1)=asc("X")-64: block(2,2)=asc("K")-64
+block(3,1)=asc("D")-64: block(3,2)=asc("Q")-64
+block(4,1)=asc("C")-64: block(4,2)=asc("P")-64
+block(5,1)=asc("N")-64: block(5,2)=asc("A")-64
+block(6,1)=asc("G")-64: block(6,2)=asc("T")-64
+block(7,1)=asc("R")-64: block(7,2)=asc("E")-64
+block(8,1)=asc("T")-64: block(8,2)=asc("G")-64
+block(9,1)=asc("Q")-64: block(9,2)=asc("D")-64
+block(10,1)=asc("F")-64: block(10,2)=asc("S")-64
+block(11,1)=asc("J")-64: block(11,2)=asc("W")-64
+block(12,1)=asc("H")-64: block(12,2)=asc("U")-64
+block(13,1)=asc("V")-64: block(13,2)=asc("I")-64
+block(14,1)=asc("A")-64: block(14,2)=asc("N")-64
+block(15,1)=asc("O")-64: block(15,2)=asc("B")-64
+block(16,1)=asc("E")-64: block(16,2)=asc("R")-64
+block(17,1)=asc("F")-64: block(17,2)=asc("S")-64
+block(18,1)=asc("L")-64: block(18,2)=asc("Y")-64
+block(19,1)=asc("P")-64: block(19,2)=asc("C")-64
+block(20,1)=asc("Z")-64: block(20,2)=asc("M")-64
+
+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
+if w$="" then exit function
+DoneWithWord=0: BlocksUsed=0
+l=len(w$)
+dim LetterOK(l)
+dim alphabet(26,1) 'clear letter-usage array
+for x=1 to 20 'load block letters into letter-usage array col 0
+    alphabet(block(x,1),0)+=1
+    alphabet(block(x,2),0)+=1
+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)+=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 exit function
+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 CanMakeWord=1: exit function
+if DoneWithWord then exit function
+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]
+end function
+
+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
+    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
+end sub
+
+sub UseBlock BlockNumber, NumericLetter
+    block(BlockNumber, 0)=1 'Mark block as used
+    BlocksUsed=BlocksUsed+1
+    LetterOK=1
+end sub