Liberty BASIC Community Forum
« [RC] ABC Problem »

Welcome Guest. Please Login or Register.
Jan 22nd, 2018, 6:07pm


Rules|Home|Help|Search|Recent Posts|Notification


« Previous Topic | Next Topic »
Pages: 1  Notify Send Topic Print
 thread  Author  Topic: [RC] ABC Problem  (Read 634 times)
JackKelly
Guest
xx [RC] ABC Problem
« Thread started on: Sep 25th, 2016, 05:00am »

http://rosettacode.org/wiki/ABC_Problem

OK. Have a look at this one. I have a nagging suspicion that it may report 'false' under certain block/word combinations. Perhaps involving n blocks having letters on both sides that are needed in the word, and n+1 letters remaining to fit (or something like that). But I can't find a test case to make it fail.

Code:
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
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
 

I have a GUI version, but I don't think it will run on LB45. It uses string substitution assignment -- mid$(x$,2,1)="X".

Regards,
Jack
« Last Edit: Sep 26th, 2016, 08:59am by JackKelly » User IP Logged

tenochtitlanuk
Moderator
ImageImageImageImageImage


member is offline

Avatar




Homepage PM

Gender: Male
Posts: 1179
xx Re: [RC] ABC Problem
« Reply #1 on: Sep 25th, 2016, 12:42pm »

I'll have a look, but flying off for a few weeks in the States tomorrow so won't be on the Forum much.

Both your and the RC 'solutions' seem very long.
But alternative approaches are always(?) possible!

re mid$( as an assignment, it's easily accomodated within LB4.5 eg
Code:
    x$  ="RosettaCodeIsGreatFun"
    for i =1 to len( x$)
        print midSub$( x$, i, 1, "X")
    next i

    end

    function midSub$( in$, posn, numch, subs$)
        midSub$   =left$( left$( in$, posn -1) +subs$ +mid$( in$, posn +numch), len( in$))
    end function

 

which prints out
Code:
XosettaCodeIsGreatFun
RXsettaCodeIsGreatFun
RoXettaCodeIsGreatFun
RosXttaCodeIsGreatFun
RoseXtaCodeIsGreatFun
RosetXaCodeIsGreatFun
RosettXCodeIsGreatFun
RosettaXodeIsGreatFun
RosettaCXdeIsGreatFun
RosettaCoXeIsGreatFun
RosettaCodXIsGreatFun
RosettaCodeXsGreatFun
RosettaCodeIXGreatFun
RosettaCodeIsXreatFun
RosettaCodeIsGXeatFun
RosettaCodeIsGrXatFun
RosettaCodeIsGreXtFun
RosettaCodeIsGreaXFun
RosettaCodeIsGreatXun
RosettaCodeIsGreatFXn
RosettaCodeIsGreatFuX
 

EDIT Of course passing the length is redundant since it can be derived from length of the replacing string.
« Last Edit: Sep 25th, 2016, 1:55pm by tenochtitlanuk » User IP Logged

JackKelly
Guest
xx Re: [RC] ABC Problem
« Reply #2 on: Sep 26th, 2016, 08:56am »

Link deleted.
« Last Edit: Sep 28th, 2016, 1:51pm by JackKelly » User IP Logged

tsh73
Moderator
ImageImageImageImageImage


member is offline

Avatar

Anatoly (real name)


PM

Gender: Male
Posts: 1732
xx Re: [RC] ABC Problem
« Reply #3 on: Sep 28th, 2016, 06:25am »

Recursive approach.
Code:
'recursive ABC blocks task
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 text$, canDo(text$,blocks$)
loop while 1
end

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 
User IP Logged

damned Dog in the Manger
JackKelly
Guest
xx Re: [RC] ABC Problem
« Reply #4 on: Sep 28th, 2016, 08:17am »

Absolutely beautiful, Anatoly. You are a genius! This should be the version on Rosetta Code. I have deleted mine.

Also I have put your canDo function into my GUI version, if you (or anyone) want to use it for more testing.
User IP Logged

cundo
Guru
ImageImageImageImageImage


member is offline

Avatar




PM

Gender: Male
Posts: 630
xx Re: [RC] ABC Problem
« Reply #5 on: Sep 28th, 2016, 11:18am »

I can not make it to work, it halts on this line:
mid$(x$,z,1)=" "

But I don't understand the ABC Problem, I will re read it. tongue
User IP Logged

cundo
Alyce Watson
Administrator
ImageImageImageImageImage


member is offline

Avatar




Homepage PM

Gender: Female
Posts: 14918
xx Re: [RC] ABC Problem
« Reply #6 on: Sep 28th, 2016, 12:54pm »

on Sep 28th, 2016, 11:18am, cundo wrote:
I can not make it to work, it halts on this line:
mid$(x$,z,1)=" "

But I don't understand the ABC Problem, I will re read it. tongue


Mid$ is a function, not an assignment in Liberty BASIC. All code on the community wiki should work properly on Liberty BASIC 4.5. If it only runs on a different implementation (such as Run BASIC, etc.) or a similar language, then it should be moved to the appropriate wiki or removed. This is necessary to avoid confusion such as Cundo experienced. Thanks for understanding.
User IP Logged

Alyce
Liberty BASIC Workshop - a complete IDE for Liberty BASIC


Alyce's Restaurant
for Liberty BASIC code, tools and references
JackKelly
Guest
xx Re: [RC] ABC Problem
« Reply #7 on: Oct 5th, 2016, 06:38am »

Is anyone going to post Anatoly's excellent recursive solution on Rosetta Code? I have tested it and can find no problems.
User IP Logged

Alyce Watson
Administrator
ImageImageImageImageImage


member is offline

Avatar




Homepage PM

Gender: Female
Posts: 14918
xx Re: [RC] ABC Problem
« Reply #8 on: Oct 5th, 2016, 10:13am »

on Oct 5th, 2016, 06:38am, Jack Kelly wrote:
Is anyone going to post Anatoly's excellent recursive solution on Rosetta Code? I have tested it and can find no problems.


We like to have a chance to discuss these because it benefits all of us, so thanks for posting it for input. Feel free to post it to Rosetta Code. There are some staff members who post solutions that we've discussed, but they aren't always available to do so.

Thanks for all of your input, Jack. smiley
User IP Logged

Alyce
Liberty BASIC Workshop - a complete IDE for Liberty BASIC


Alyce's Restaurant
for Liberty BASIC code, tools and references
JackKelly
Guest
xx Re: [RC] ABC Problem
« Reply #9 on: Oct 6th, 2016, 03:29am »

Posted to Rosetta Code as approved.
User IP Logged

Pages: 1  Notify Send Topic Print
« Previous Topic | Next Topic »

Rules|Home|Help|Search|Recent Posts|Notification

Donate $6.99 for 50,000 Ad-Free Pageviews!

| |

This forum powered for FREE by Conforums ©
Sign up for your own Free Message Board today!
Terms of Service | Privacy Policy | Conforums Support | Parental Controls