Implement 4.41

ex-4_35-xx.scm

@@ -100,6 +100,8 @@
 (my-assert (multiple-dwelling)
            '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
 
+; There are five solutions when the adjacent floor constraint for smith and
+; fletcher is removed.
 
 (display "\nex-4.39 - multiple-dwelling-ordering\n")
 
@@ -162,9 +164,59 @@
 
 (display "\nex-4.41 - multiple-dwelling-ordinary\n")
 
+; Appand all ys to xs.
+(define (append-all xs ys)
+  (map (lambda (y) (append xs (list y))) ys))
+
+(define (available-floors dwelling)
+  (filter (lambda (x) (not (memq x dwelling))) '(1 2 3 4 5)))
+
+(define (flatten xss)
+  (if (null? xss)
+    xss
+    (if (pair? (car (car xss)))
+      (reduce append '() xss)
+      xss)))
+
+(define (multiple-dwelling-ordinary)
+  (define baker first)
+  (define cooper second)
+  (define fletcher third)
+  (define miller fourth)
+  (define smith fifth)
+
+  (define (dwellings dwelling constraints)
+    (if (null? constraints)
+      dwelling
+      (let ((new-dwellings (filter (car constraints)
+                         (append-all dwelling (available-floors dwelling)))))
+        (flatten (filter
+          (lambda (x) (not (null? x)))
+          (map (lambda (dwelling) (dwellings dwelling (cdr constraints))) new-dwellings))))))
+
+  (define constraints
+    (list
+      (lambda (dwelling) (not (= (baker dwelling) 5)))
+      (lambda (dwelling) (not (= (cooper dwelling) 1)))
+      (lambda (dwelling) (and (not (= (fletcher dwelling) 5))
+                              (not (= (fletcher dwelling) 1))))
+      (lambda (dwelling) (and (> (miller dwelling) (cooper dwelling))
+                              (not (= (abs (- (fletcher dwelling) (cooper dwelling))) 1))))
+      (lambda (dwelling) (not (= (abs (- (smith dwelling) (fletcher dwelling))) 1)))
+      ;(lambda (dwelling) #t) ; no adjacent floor constraint for smith and fletcher
+      ))
+  (define (tag-result xs)
+    (map (lambda (name number) (list name number))
+         '(baker cooper fletcher miller smith)
+         xs))
+  (map tag-result (dwellings '() constraints)))
+
+(my-assert (multiple-dwelling)
+           (car (multiple-dwelling-ordinary)))
 
 (display "\nex-4.42\n")
 
-; (display "\nex-4.43\n")
+(display "\nex-4.43\n")
+
 ; (display "\nex-4.44 - eight-queens\n")