\ er.f "Einstein's Riddle" - Leo Wong 12-23 March 2001 +
\ Solves who owns the fish
\ macro by Neil Bawd
: macro ( "name <char> ccc<char>" -- )
: char parse postpone sliteral postpone evaluate postpone ;
immediate ;
: n! ( n -- n! ) dup 2 < if drop 1 exit then dup 1- recurse * ;
\ Permutations after Er Hersom, Forthwrite, Issue 109, November 2000
0 value #items
: ,perm ( -- ) #items 0 ?do i pick c, loop ;
: perm ( <items> #items -- <items> #items )
dup 1 = if >r ,perm r>
else dup 0 do >r r@ 1- recurse roll r> loop then ;
: drops ( n -- ) 0 ?do drop loop ;
: permutations
create ( <items> #items -- )
dup n! , dup c, dup to #items perm #items 1+ drops
does> ( n -- n a #perms ) dup @ >r cell+ count chars swap r> ;
0 1 2 3 4 5 permutations perms
: 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 ;
: category ( 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 category colors
\ nationalities
s" Brit" spells brit
s" Dane" spells dane
s" Norwegian" spells norwegian
s" German" spells german
s" Swede" spells swede category nationalities
\ drinks
s" beer" spells beer
s" milk" spells milk
s" tea" spells tea
s" coffee" spells coffee
s" water" spells water category drinks
\ smokes
s" Blaumeister" spells blaumeister
s" blends" spells blends
s" Dunhill" spells dunhill
s" Prince" spells prince
s" Pall Mall" spells pallmall category smokes
\ pets
s" birds" spells birds
s" cats" spells cats
s" dogs" spells dogs
s" fish" spells fish
s" horse" spells horse category pets
2 milk c! \ hint 8
0 norwegian c! \ hint 9
norwegian c@ 1+ blue c! \ hint 14
: colors! ( permutation -- colors )
count red c! count yellow c! c@ dup green c!
1+ white c! \ hint 4
colors ;
: nationalities! ( permutation -- nationalities )
count dane c! count german c! c@ swede c!
red c@ brit c! \ hint 1
nationalities ;
: drinks! ( permutation -- drinks )
count beer c! c@ water c!
dane c@ tea c! \ hint 3
green c@ coffee c! \ hint 5
drinks ;
: smokes! ( permutation -- smokes )
count blends c! c@ pallmall c!
yellow c@ dunhill c! \ hint 7
beer c@ blaumeister c! \ hint 12
german c@ prince c! \ hint 13
smokes ;
: pets! ( permutation -- pets )
count cats c! count fish c! c@ horse c!
swede c@ dogs c! \ hint 2
pallmall c@ birds c! \ hint 6
pets ;
create board 6 chars allot
: c++ ( a -- ) dup c@ 1+ swap c! ;
: scan ( ca1 u1 c -- ca2 u2 )
>r
begin dup while over c@ r@ <> while 1 /string repeat then
r> drop ;
: placed ( category -- ? )
board 5 0 fill
5 0 do dup @ c@ chars board + c++ cell+ loop drop
board 5 0 scan nip 0= ;
macro ?no " ( a1 a2 -- ) - if false exit then"
: 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
true ;
: .spell ( a -- ) count type space ;
: .nth ( n category -- )
5 0 do
2dup @ count rot = if .spell leave else drop then cell+
loop 2drop ;
: .solution ( -- )
CR ." The " fish c@ nationalities .nth ." owns the fish."
macro perms{ " ( -- n a a ) perms 0 do dup"
macro }perms " ( n a -- ) over + loop 2drop"
macro unloops " ( n -- ) begin ?dup while unloop 1- repeat"
: er ( -- ) \ Einstein's riddle
perms{ colors! placed if
perms{ nationalities! placed if
perms{ drinks! placed if
perms{ smokes! placed if
perms{ pets! placed if
constraints if
.solution 10 drops 5 unloops exit
then
then
}perms then
}perms then
}perms then
}perms then
}perms ;
er
Leo Wong hello@albany.net