Path: news.net.uni-c.dk!newsfeeds.net.uni-c.dk!newsfeed1.uni2.dk!news.algonet.se!algonet!news.maxwell.syr.edu!news-hog.berkeley.edu!ucberkeley!news.colorado.edu!not-for-mail From: Howard Brazee Newsgroups: comp.ai.neural-nets,comp.lang.apl,comp.lang.awk,comp.lang.basic,comp.lang.beta,comp.lang.cobol,comp.lang.dylan,comp.lang.forth Subject: Re: Einstein's Riddle Date: Tue, 13 Mar 2001 14:36:18 -0700 Organization: UCB Lines: 159 Message-ID: <3AAE92D1.AD9FFD06@brazee.net> References: <3AAE8605.C6CF0374@albany.net> NNTP-Posting-Host: brazee.cusys.edu Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii Content-Transfer-Encoding: 7bit X-Trace: peabody.colorado.edu 984519379 14796 204.228.68.77 (13 Mar 2001 21:36:19 GMT) X-Complaints-To: abuse@colorado.edu NNTP-Posting-Date: 13 Mar 2001 21:36:19 GMT X-Mailer: Mozilla 4.7 [en]C-CCK-MCD NSCPCD47 (Win95; I) X-Accept-Language: en Xref: news.net.uni-c.dk comp.ai.neural-nets:67550 comp.lang.apl:29381 comp.lang.awk:17145 comp.lang.beta:12750 comp.lang.cobol:102596 comp.lang.dylan:24169 comp.lang.forth:78552 This is cross-posted. What language are you using? Leo Wong and Mary Murphy wrote: > \ er.f "Einstein's Riddle" - Leo Wong 12 March 2001 + > > : pair ( a n1 n2 -- a1 a2 ) chars >r over chars + swap r> + ; > : trade ( a1 a2 -- ) 2dup 2>r c@ swap c@ r> c! r> c! ; > 0 value temp > : ,columns ( a -- ) temp 0 ?do count [char] 0 - c, loop drop ; > : permute ( a n -- ) > 1- ?dup if > 2dup recurse > dup 0 do > 2dup i pair trade > 2dup recurse > 2dup i pair trade > loop 2drop > else ,columns then ; > : parray > create ( a n -- ) dup c, dup to temp permute > does> ( n -- a ) count rot * chars + ; > > s" 01234" parray perm > s" 023" parray cperm \ colors > s" 1234" parray nperm \ nationalities > s" 0134" parray dperm \ drinks > > : string, ( a u -- ) dup c, 0 do count c, loop drop ; > : spells ( a u -- a' ) create here >r 0 c, string, r> ; > : ,s ( x1 ... xn n -- ) begin ?dup while dup roll , 1- repeat ; > : collect ( x1 x2 x3 x4 x5 -- ) create 5 ,s ; > > \ colors > s" yellow" spells yellow > s" blue" spells blue > s" red" spells red > s" green" spells green > s" white" spells white collect colors > > \ nationalities > s" Brit" spells brit > s" Dane" spells dane > s" Norwegian" spells norwegian > s" German" spells german > s" Swede" spells swede collect nationalities > > \ drinks > s" beer" spells beer > s" milk" spells milk > s" tea" spells tea > s" coffee" spells coffee > s" water" spells water collect drinks > > \ smokes > s" Blaumeister" spells blaumeister > s" blends" spells blends > s" Dunhill" spells dunhill > s" Prince" spells prince > s" Pall Mall" spells pallmall collect smokes > > \ pets > s" birds" spells birds > s" cats" spells cats > s" dogs" spells dogs > s" fish" spells fish > s" horse" spells horse collect pets > > 0 norwegian c! \ hint 9 > norwegian c@ 1+ blue c! \ hint 14 > 2 milk c! \ hint 8 > > \ The following is ordered for the impatient > : colors! ( a -- ) > count red c! count yellow c! c@ dup green c! > 1+ white c! \ hint 4 > ; > > : nationalities! ( a -- ) > count dane c! count german c! c@ swede c! > red c@ brit c! \ hint 1 > ; > > : drinks! ( a -- ) > count beer c! c@ water c! > dane c@ tea c! \ hint 3 > green c@ coffee c! \ hint 4 > ; > > : smokes! ( a -- ) > count blends c! c@ pallmall c! > yellow c@ dunhill c! \ hint 7 > beer c@ blaumeister c! \ hint 12 > german c@ prince c! \ hint 13 > ; > > : pets! ( a -- ) > count cats c! count fish c! c@ horse c! > swede c@ dogs c! \ hint 2 > pallmall c@ birds c! \ hint 6 > ; > > create board 5 chars allot > : cut ( c ca u -- n ) rot scan nip ; \ n=remaining chars including c > : missing ( row -- n ) > board 5 0 fill > 5 0 do 1 over i cells + @ c@ chars board + +! loop drop > 0 board 5 cut ; > > : ?no ( a1 a2 -- ) s" - if false exit then" evaluate ; immediate > : constraints ( -- ? ) > \ ( 1 ) brit c@ red c@ ?no > \ ( 2 ) swede c@ dogs c@ ?no > \ ( 3 ) dane c@ tea c@ ?no > \ ( 4 ) green c@ white c@ 1- ?no > \ ( 5 ) green c@ coffee c@ ?no > \ ( 6 ) pallmall c@ birds c@ ?no > \ ( 7 ) yellow c@ dunhill c@ ?no > \ ( 8 ) milk c@ 2 ?no > \ ( 9 ) norwegian c@ 0 ?no > ( 10 ) blends c@ cats c@ - abs 1 ?no > ( 11 ) horse c@ dunhill c@ - abs 1 ?no > \ ( 12 ) blaumeister c@ beer c@ ?no > \ ( 13 ) german c@ prince c@ ?no > \ ( 14 ) norwegian c@ blue c@ - abs 1 ?no > ( 15 ) blends c@ water c@ - abs 1 ?no > 0 pets missing ?no > true ; > > : .spell ( a -- ) count type space ; > : .nth ( n collection -- a ) > 5 0 do > 2dup i cells + @ count rot = if .spell leave else drop then > loop 2drop ; > : .solution ( -- ) > CR ." The " fish c@ nationalities .nth ." owns the fish." ; > > variable ntries > : er ( -- ) \ Einstein's riddle > 0 ntries ! > 6 0 do i cperm colors! colors missing 0= if > 24 0 do i nperm nationalities! nationalities missing 0= if > 24 0 do i dperm drinks! drinks missing 0= if > 120 0 do i perm smokes! smokes missing 0= if > 120 0 do i perm pets! 1 ntries +! > constraints if .solution cr ." ntries=" ntries ? > unloop unloop unloop unloop unloop exit then > loop then > loop then > loop then > loop then > loop ; > > er > > -- > hello@albany.net > http://www.albany.net/~hello/