Implement till 4.38

ex-4_35-xx.scm

@@ -1,4 +1,5 @@
 (load "util.scm")
+(load "misc/amb.scm")
 
 (define (require p)
   (if (not p) (amb)))
@@ -38,13 +39,116 @@
         (require (= (+ (* i i) (* j j)) (* k k)))
         (list i j k)))))
 
-; Write a procedure that actually will accomplish this. (That is, write a
-; procedure for which repeatedly typing try-again would in principle eventually
-; generate all Pythagorean triples.) 
+(define (all-pythagorean-triples)
+  (let ((k (an-integer-starting-from 1)))
+    (let ((i (an-integer-between 1 k)))
+      (let ((j (an-integer-between i k)))
+        (require (= (+ (* i i) (* j j)) (* k k)))
+        (list i j k)))))
 
-; (display "[done]\n")
+; Note: It would be more efficient to choose to integers and then calculate if
+; (+ (* i i) (* j j)) is a perfect square.
 
-(display "\nex-4.37\n")
+(display "[done]\n")
 
-;(display "\nex-4.38\n")
+(display "\nex-4.37 - more-efficient-pythagorean-triples\n")
+
+(define (a-pythagorean-triple-between low high)
+  (let ((i (an-integer-between low high))
+        (hsq (* high high)))
+    (let ((j (an-integer-between i high)))
+      (let ((ksq (+ (* i i) (* j j))))
+        (require (>= hsq ksq))
+        (let ((k (sqrt ksq)))
+          (require (integer? k))
+          (list i j k))))))
+
+; This implementation uses my note from the previous exercises. Computing sqrt
+; and checking for integer is faster ultimately, because the majority of
+; combinations are not solutions.
+
+(display "[answered]\n")
+
+(display "\nex-4.38 - multiple-dwelling\n")
+
+(define (distinct? items)
+  (cond ((null? items) true)
+        ((null? (cdr items)) true)
+        ((member (car items) (cdr items)) false)
+        (else (distinct? (cdr items)))))
+
+(define (multiple-dwelling)
+  (let ((baker (amb 1 2 3 4 5))
+        (cooper (amb 1 2 3 4 5))
+        (fletcher (amb 1 2 3 4 5))
+        (miller (amb 1 2 3 4 5))
+        (smith (amb 1 2 3 4 5)))
+    (require
+     (distinct? (list baker cooper fletcher miller smith)))
+    (require (not (= baker 5)))
+    (require (not (= cooper 1)))
+    (require (not (= fletcher 5)))
+    (require (not (= fletcher 1)))
+    (require (> miller cooper))
+    (require (not (= (abs (- smith fletcher)) 1))) ; adjacent floors constraint
+    (require (not (= (abs (- fletcher cooper)) 1)))
+    (list (list 'baker baker)
+          (list 'cooper cooper)
+          (list 'fletcher fletcher)
+          (list 'miller miller)
+          (list 'smith smith))))
+
+(my-assert (multiple-dwelling)
+           '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
+
+
+(display "\nex-4.39 - multiple-dwelling-ordering\n")
+
+(define (repeat proc n)
+  (if (= n 0)
+    't
+    (begin
+      (proc)
+      (repeat proc (- n 1)))))
+
+(let ((start-time (runtime)))
+  (repeat multiple-dwelling 10)
+  (display "Default ordering: ")
+  (display (- (runtime) start-time))
+  (newline))
+
+(define (multiple-dwelling)
+  (let ((baker (amb 1 2 3 4 5))
+        (cooper (amb 1 2 3 4 5))
+        (fletcher (amb 1 2 3 4 5))
+        (miller (amb 1 2 3 4 5))
+        (smith (amb 1 2 3 4 5)))
+    (require
+     (distinct? (list baker cooper fletcher miller smith)))
+    (require (not (= baker 5)))
+    (require (not (= cooper 1)))
+    (require (not (= fletcher 5)))
+    (require (not (= fletcher 1)))
+    (require (> miller cooper))
+    (require (not (= (abs (- smith fletcher)) 1))) ; adjacent floors constraint
+    (require (not (= (abs (- fletcher cooper)) 1)))
+    (list (list 'baker baker)
+          (list 'cooper cooper)
+          (list 'fletcher fletcher)
+          (list 'miller miller)
+          (list 'smith smith))))
+
+(let ((start-time (runtime)))
+  (repeat multiple-dwelling 10)
+  (display "Improved ordering: ")
+  (display (- (runtime) start-time))
+  (newline))
+
+; The ordering should matter because the earlier we recognize that the current
+; branch does not have any solutions the faster we can backtrack and the more
+; we prune the search space.
+
+(display "\nex-4.40\n")
+
+(display "\nex-4.41\n")
 

misc/amb.scm

@@ -0,0 +1,182 @@
+;;; from http://www.shido.info/lisp/scheme_amb_e.html
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;;      Nondeterminsm using macro amb
+;;;      T.Shido
+;;;      November 15, 2005
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; abbreviation for call-with-current-continuation
+(define call/cc call-with-current-continuation)
+
+;;; This function is re-assigned in `choose' and `fail' itself.
+(define fail #f)
+
+
+;;; nondeterminsm macro operator
+(define-syntax amb
+  (syntax-rules ()
+    ((_) (fail))
+    ((_ a) a)
+    ((_ a b ...)
+     (let ((fail0 fail))
+       (call/cc
+    (lambda (cc)
+      (set! fail
+        (lambda ()
+          (set! fail fail0)
+          (cc (amb b ...))))
+      (cc a)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; for MIT-Scheme only
+; use it if you don't like warning during compilation
+; (define-syntax amb
+;   (sc-macro-transformer
+;    (lambda (exp env)
+;      (if (null? (cdr exp))
+;          `(fail)
+;        `(let ((fail0 fail))
+;           (call/cc
+;            (lambda (cc)
+;              (set! fail
+;                    (lambda ()
+;                      (set! fail fail0)
+;                      (cc (amb ,@(map (lambda (x)
+;                                        (make-syntactic-closure env '() x))
+;                                      (cddr exp))))))
+;              (cc ,(make-syntactic-closure env '() (second exp))))))))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; function for nondeterminsm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; (define (choose . ls)
+;   (if (null? ls)
+;       (fail)
+;     (let ((fail0 fail))
+;       (call/cc
+;        (lambda (cc)
+;          (begin
+;           (set! fail
+;                 (lambda ()
+;                   (set! fail fail0)
+;                   (cc (apply choose (cdr ls)))))
+;           (cc (car ls))))))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; returning all possibilities
+(define-syntax set-of
+  (syntax-rules ()
+    ((_ s)
+      (let ((acc '()))
+        (amb (let ((v s))
+               (set! acc (cons v acc))
+               (fail))
+             (reverse! acc))))))
+
+;;; if not pred backtrack
+(define (assert pred)
+  (or pred (amb)))
+
+;;; returns arbitrary number larger or equal to n
+(define (an-integer-starting-from n)
+  (amb n (an-integer-starting-from (1+ n))))
+
+;;; returns arbitrary number between a and b
+(define (number-between a b)
+  (let loop ((i a))
+    (if (> i b)
+        (amb)
+      (amb i (loop (1+ i))))))
+
+
+;;;;;;;;;;;; misc
+(define (gen-prime n)
+  (let ((i (number-between  2 n)))
+    (assert (prime? i))
+    i))
+
+(define (prime? n)
+  (let ((m (sqrt n)))
+    (let loop ((i 2))
+      (or (< m i)
+          (and (not (zero? (modulo n i)))
+               (loop (+ i (if (= i 2) 1 2))))))))
+
+(define (sum-prime n)
+  (let* ((i (number-between 1 n))
+         (j (number-between i n)))
+    (assert (prime? (+ i j)))
+    (list i j)))
+
+
+(define (sq x) (* x x))
+
+(define (pythag i j k)
+  (assert (= (sq k) (+ (sq i) (sq j))))
+  (list i j k))
+
+;;; small functions for SICP Exercise 4.42
+(define (xor a b)
+  (if a (not b) b))
+
+(define (all-different? . ls)
+  (let loop ((obj (car ls)) (ls (cdr ls)))
+    (or (null? ls)
+        (and (not (memv obj ls))
+             (loop (car ls) (cdr ls))))))
+
+;;; SICP Exercise 4.42
+(define (girls-exam)
+  (let ((kitty (number-between 1 5))
+        (betty (number-between 1 5)))
+    (assert (xor (= kitty 2) (= betty 3)))
+    (let ((mary (number-between 1 5)))
+      (assert (xor (= kitty 2) (= mary 4)))
+      (assert (xor (= mary 4) (= betty 1)))
+      (let ((ethel (number-between 1 5))
+            (joan (number-between 1 5)))
+        (assert (xor (= ethel 1) (= joan 2)))
+        (assert (xor (= joan 3) (= ethel 5)))
+        (assert (all-different? kitty betty ethel joan mary))
+        (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))))
+
+;;; Bad answer for ex 4.42
+(define (girls-exam-x)
+  (let ((kitty (number-between 1 5))
+        (betty (number-between 1 5))
+        (mary (number-between 1 5))
+        (ethel (number-between 1 5))
+        (joan (number-between 1 5)))
+    (assert (xor (= kitty 2) (= betty 3)))
+    (assert (xor (= kitty 2) (= mary 4)))
+    (assert (xor (= mary 4) (= betty 1)))
+    (assert (xor (= ethel 1) (= joan 2)))
+    (assert (xor (= joan 3) (= ethel 5)))
+    (assert (all-different? kitty betty ethel joan mary))
+    (map list '(kitty betty ethel joan mary) (list kitty betty ethel joan mary))))
+
+
+;;; to show cpu time
+(define-syntax cpu-time/sec
+  (syntax-rules ()
+    ((_ s)
+     (with-timings
+     (lambda () s)
+       (lambda (run-time gc-time real-time)
+     (write (internal-time/ticks->seconds run-time))
+     (write-char #\space)
+     (write (internal-time/ticks->seconds gc-time))
+     (write-char #\space)
+     (write (internal-time/ticks->seconds real-time))
+     (newline))))))
+
+
+;;; initializing fail
+(call/cc
+ (lambda (cc)
+   (set! fail
+         (lambda ()
+           (cc 'no-choise)))))

util.scm

@@ -7,6 +7,17 @@
       (display b)))
   (newline))
 
+; I have this here to avoid name-conflicts with the amb implementation in
+; amb.scm.
+(define (my-assert a b)
+  (cond ((equal? a b) (display "[ok]"))
+    (else
+      (display "[error] ")
+      (display a)
+      (display " != ")
+      (display b)))
+  (newline))
+
 (define (gcd a b)
   (if (= b 0) (abs a) (gcd b (remainder a b))))