Path: news.net.uni-c.dk!newsfeeds.net.uni-c.dk!newsfeed1.uni2.dk!news-spur1.maxwell.syr.edu!news.maxwell.syr.edu!feed2.news.rcn.net!rcn!netnews.com!newspeer.cwnet.com!sjc1.nntp.concentric.net!newsfeed.concentric.net!newsfeed1.thebiz.net!not-for-mail Message-ID: <3AAE8605.C6CF0374@albany.net> From: Leo Wong and Mary Murphy X-Mailer: Mozilla 4.04 [en] (Win95; I) MIME-Version: 1.0 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 References: Content-Type: text/plain; charset=us-ascii Content-Transfer-Encoding: 7bit Lines: 154 NNTP-Posting-Host: 8dp0sKqbZOcZW9V7Z+kZn2O5yKCg3M4XYHUr/ChjYIivUy/CBF4saB7ZJojOo9E= X-Trace: WiJ4ToH5EcN0XsHOgazICpZIiyAwDgbV5UbegDuO4VYHRL+8myErhWsaaW2OxJOBIbyzfK661g8N!o8o1AAI6Y4EqoBCSd4tEnuTaw/HQAV/sXMHjdLustpqobKHLVEwTfOyJu9tiK5aHvOVl2RgxWuCg!5ViflQLR+Gg2cZfJkBg= X-Complaints-To: news-abuse@thebiz.net X-Abuse-Info: Please be sure to forward a copy of ALL headers to X-Abuse-Info: news-abuse@thebiz.net, otherwise we will be unable X-Abuse-Info: to process your complaint properly. NNTP-Posting-Date: Tue, 13 Mar 2001 15:35:44 EST Organization: BiznessOnline.com, Inc. Date: Tue, 13 Mar 2001 20:36:06 GMT Xref: news.net.uni-c.dk comp.ai.neural-nets:67548 comp.lang.apl:29379 comp.lang.awk:17143 comp.lang.beta:12748 comp.lang.cobol:102590 comp.lang.dylan:24167 comp.lang.forth:78550 \ 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/