diff --git a/ex-4_35-xx.scm b/ex-4_35-xx.scm index 39a914e..dc3b2a5 100644 --- a/ex-4_35-xx.scm +++ b/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") diff --git a/misc/amb.scm b/misc/amb.scm new file mode 100644 index 0000000..12051bd --- /dev/null +++ b/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))))) diff --git a/util.scm b/util.scm index fde5c12..fbbd6f1 100644 --- a/util.scm +++ b/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))))