A-M baby

Task/Dinesmans-multiple-dwelling-problem/Icon/dinesmans-multiple-dwelling-problem.icon

@@ -0,0 +1,71 @@
+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