update

Task/Dinesmans-multiple-dwelling-problem/Bracmat/dinesmans-multiple-dwelling-problem.bracmat

@@ -1,26 +1,27 @@
-( Baker Cooper Fletcher Miller Smith:?people
-& ( constraints
-  =
-    .   !arg
-      : ~(? Baker)
-      : ~(Cooper ?)
-      : ~(Fletcher ?|? Fletcher)
-      : ? Cooper ? Miller ?
-      : ~(? Smith Fletcher ?|? Fletcher Smith ?)
-      : ~(? Cooper Fletcher ?|? Fletcher Cooper ?)
-  )
-& ( solution
-  =   floors persons A Z person
-    .   !arg:(?floors.?persons)
-      & (   !persons:
-          & constraints$!floors
-          & out$("Inhabitants, from bottom to top:" !floors)
-        |   !persons
-          :   ?A
-              %?`person
-              (?Z&solution$(!floors !person.!A !Z))
-        )
-  )
-& solution$(.!people)
-&
+(   Baker Cooper Fletcher Miller Smith:?people
+  & ( constraints
+    =
+      .   !arg
+        : ~(? Baker)
+        : ~(Cooper ?)
+        : ~(Fletcher ?|? Fletcher)
+        : ? Cooper ? Miller ?
+        : ~(? Smith Fletcher ?|? Fletcher Smith ?)
+        : ~(? Cooper Fletcher ?|? Fletcher Cooper ?)
+    )
+  & ( solution
+    =   floors persons A Z person
+      .   !arg:(?floors.?persons)
+        & (   !persons:
+            & constraints$!floors
+            & out$("Inhabitants, from bottom to top:" !floors)
+            & ~     { The ~ always fails on evaluation. Here, failure forces Bracmat to backtrack and find all solutions, not just the first one. }
+          |   !persons
+            :   ?A
+                %?`person
+                (?Z&solution$(!floors !person.!A !Z))
+          )
+    )
+  & solution$(.!people)
+|                   { After outputting all solutions, the lhs of the | operator fails. The rhs of the | operator, here an empty string, is the final result. }
 );

Task/Dinesmans-multiple-dwelling-problem/Factor/dinesmans-multiple-dwelling-problem.factor

@@ -0,0 +1,28 @@
+USING: kernel
+    combinators.short-circuit
+    math math.combinatorics math.ranges
+    sequences
+    qw prettyprint ;
+IN: rosetta.dinesman
+
+: /= ( x y -- ? ) = not ;
+: fifth ( seq -- elt ) 4 swap nth ;
+
+: meets-constraints? ( seq -- ? )
+    {
+        [ first 5 /= ]                          ! Baker does not live on the top floor.
+        [ second 1 /= ]                         ! Cooper does not live on the bottom floor.
+        [ third { 1 5 } member? not ]           ! Fletcher does not live on either the top or bottom floor.
+        [ [ fourth ] [ second ] bi > ]          ! Miller lives on a higher floor than does Cooper.
+        [ [ fifth ] [ third ] bi - abs 1 /= ]   ! Smith does not live on a floor adjacent to Fletcher's.
+        [ [ third ] [ second ] bi - abs 1 /= ]  ! Fletcher does not live on a floor adjacent to Cooper's.
+    } 1&& ;
+
+: solutions ( -- seq )
+    5 [1,b] all-permutations [ meets-constraints? ] filter ;
+
+: >names ( seq -- seq )
+    [ 1 - qw{ baker cooper fletcher miller smith } nth ] map ;
+
+: dinesman ( -- )
+    solutions [ >names . ] each ;

Task/Dinesmans-multiple-dwelling-problem/Racket/dinesmans-multiple-dwelling-problem.rkt

@@ -0,0 +1,43 @@
+#lang racket
+
+;; A quick `amb' implementation
+(define fails '())
+(define (fail) (if (pair? fails) ((car fails)) (error "no more choices!")))
+(define (amb xs)
+  (let/cc k (set! fails (cons k fails)))
+  (if (pair? xs) (begin0 (car xs) (set! xs (cdr xs)))
+      (begin (set! fails (cdr fails)) (fail))))
+(define (assert . conditions) (when (memq #f conditions) (fail)))
+
+;; Convenient macro for definining problem items
+(define-syntax-rule (with: all (name ...) #:in choices body ...)
+  (let* ([cs choices] [name (amb cs)] ... [all `([,name name] ...)]) body ...))
+
+;; ===== problem translation starts here =====
+
+;; Baker, Cooper, Fletcher, Miller, and Smith live on different floors
+;; of an apartment house that contains only five floors.
+(with: residents [Baker Cooper Fletcher Miller Smith] #:in (range 1 6)
+  ;; Some helpers
+  (define (on-top    x) (for/and ([y residents]) (x . >= . (car y))))
+  (define (on-bottom x) (for/and ([y residents]) (x . <= . (car y))))
+  (define (adjacent x y) (= 1 (abs (- x y))))
+  (assert
+   ;; ... live on different floors ...
+   (assert (= 5 (length (remove-duplicates (map car residents)))))
+   ;; Baker does not live on the top floor.
+   (not (on-top Baker))
+   ;; Cooper does not live on the bottom floor.
+   (not (on-bottom Cooper))
+   ;; Fletcher does not live on either the top or the bottom floor.
+   (not (on-top Fletcher))
+   (not (on-bottom Fletcher))
+   ;; Miller lives on a higher floor than does Cooper.
+   (> Miller Cooper)
+   ;; Smith does not live on a floor adjacent to Fletcher's.
+   (not (adjacent Smith Fletcher))
+   ;; Fletcher does not live on a floor adjacent to Cooper's.
+   (assert (not (adjacent Fletcher Cooper))))
+  ;; Where does everyone live?
+  (printf "Solution:\n")
+  (for ([x (sort residents > #:key car)]) (apply printf "  ~a. ~a\n" x)))