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