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

Task/Dinesmans-multiple-dwelling-problem/J/dinesmans-multiple-dwelling-problem-1.j

@@ -0,0 +1 @@
+possible=: ((i.!5) A. i.5) { 'BCFMS'

Task/Dinesmans-multiple-dwelling-problem/J/dinesmans-multiple-dwelling-problem-2.j

@@ -0,0 +1,9 @@
+possible=: (#~ 'B' ~: {:"1) possible         NB. Baker not on top floor
+possible=: (#~ 'C' ~: {."1) possible         NB. Cooper not on bottom floor
+possible=: (#~ 'F' ~: {:"1) possible         NB. Fletcher not on top floor
+possible=: (#~ 'F' ~: {."1) possible         NB. Fletcher not on bottom floor
+possible=: (#~ </@i."1&'CM') possible        NB. Miller on higher floor than Cooper
+possible=: (#~ 0 = +/@E."1~&'SF') possible   NB. Smith not immediately below Fletcher
+possible=: (#~ 0 = +/@E."1~&'FS') possible   NB. Fletcher not immediately below Smith
+possible=: (#~ 0 = +/@E."1~&'CF') possible   NB. Cooper not immediately below Fletcher
+possible=: (#~ 0 = +/@E."1~&'FC') possible   NB. Fletcher not immediately below Cooper

Task/Dinesmans-multiple-dwelling-problem/J/dinesmans-multiple-dwelling-problem-3.j

@@ -0,0 +1,2 @@
+   possible
+SCBFM

Task/Dinesmans-multiple-dwelling-problem/Mathematica/dinesmans-multiple-dwelling-problem.mathematica

@@ -0,0 +1,15 @@
+floor[x_,y_]:=Flatten[Position[y,x]][[1]]
+Select[Permutations[{"Baker","Cooper","Fletcher","Miller","Smith"}],
+  ( floor["Baker",#] < 5 )
+&&( Abs[floor["Fletcher",#] - floor["Cooper",#]] > 1 )
+&&( Abs[floor["Fletcher",#] - floor["Smith",#]] > 1 )
+&&( 1 < floor["Cooper",#] < floor["Miller",#] )
+&&( 1 < floor["Fletcher",#] < 5 )
+&]  [[1]] //Reverse //Column
+
+->
+Miller
+Fletcher
+Baker
+Cooper
+Smith