71 lines
1.9 KiB
Text
71 lines
1.9 KiB
Text
invocable all
|
|
global nameL, nameT, rules
|
|
|
|
procedure main() # Dinesman
|
|
|
|
nameT := table()
|
|
nameL := ["Baker", "Cooper", "Fletcher", "Miller", "Smith"]
|
|
rules := [ [ distinct ],
|
|
[ "~=", "Baker", top() ],
|
|
[ "~=", "Cooper", bottom() ],
|
|
[ "~=", "Fletcher", top() ],
|
|
[ "~=", "Fletcher", bottom() ],
|
|
[ ">", "Miller", "Cooper" ],
|
|
[ notadjacent, "Smith", "Fletcher" ],
|
|
[ notadjacent, "Fletcher", "Cooper" ],
|
|
[ showsolution ],
|
|
[ stop ] ]
|
|
|
|
if not solve(1) then
|
|
write("No solution found.")
|
|
end
|
|
|
|
procedure dontstop() # use if you want to search for all solutions
|
|
end
|
|
|
|
procedure showsolution() # show the soluton
|
|
write("The solution is:")
|
|
every write(" ",n := !nameL, " lives in ", nameT[n])
|
|
return
|
|
end
|
|
|
|
procedure eval(n) # evaluate a rule
|
|
r := copy(rules[n-top()])
|
|
every r[i := 2 to *r] := rv(r[i])
|
|
if get(r)!r then suspend
|
|
end
|
|
|
|
procedure rv(x) # return referenced value if it exists
|
|
return \nameT[x] | x
|
|
end
|
|
|
|
procedure solve(n) # recursive solver
|
|
if n > top() then { # apply rules
|
|
if n <= top() + *rules then
|
|
( eval(n) & solve(n+1) ) | fail
|
|
}
|
|
else # setup locations
|
|
(( nameT[nameL[n]] := bottom() to top() ) & solve(n + 1)) | fail
|
|
return
|
|
end
|
|
|
|
procedure distinct(a,b) # ensure each name is distinct
|
|
if nameT[n := !nameL] = nameT[n ~== key(nameT)] then fail
|
|
suspend
|
|
end
|
|
|
|
procedure notadjacent(n1,n2) # ensure n1,2 are not adjacent
|
|
if not adjacent(n1,n2) then suspend
|
|
end
|
|
|
|
procedure adjacent(n1,n2) # ensure n1,2 are adjacent
|
|
if abs(n1 - n2) = 1 then suspend
|
|
end
|
|
|
|
procedure bottom() # return bottom
|
|
return if *nameL > 0 then 1 else 0
|
|
end
|
|
|
|
procedure top() # return top
|
|
return *nameL
|
|
end
|