Pasted

#lang racket
 
;;;;;;;;;;
;; 4.50 ;;
;;;;;;;;;;
 
(require racket/random) ; for random-ref
 
;; You also need to change amb to ramb in the installed helper procedures.
 
(define (ramb? expr) (tagged-list? expr 'ramb))
(define (ramb-choices expr) (rest expr))
 
(define (analyze-ramb expr)
  (define cprocs (map analyze (ramb-choices expr)))
  (lambda (env succeed fail)
    (define (try-next choices)
      (cond [(empty? choices) (fail)]
            [else
              (define choice (random-ref choices))
              (define other-choices (remove choice choices))
              (choice env
                      succeed
                      (lambda ()
                        (try-next other-choices)))]))
    (try-next cprocs)))
 
;; test
 
;; (driver-loop)
;; ;;; Ramb-Eval input:
;; (let ([x (an-element-of (list 1 2 3))]) x)
;; ;;; Starting a new problem 
;; ;;; Ramb-Eval value:
;; 2
;; ;;; Ramb-Eval input:
;; try-again
;; ;;; Ramb-Eval value:
;; 3
;; ;;; Ramb-Eval input:
;; try-again
;; ;;; Ramb-Eval value:
;; 1
;; ;;; Ramb-Eval input:
;; try-again
;; ;;; There are no more values of
;; (let ((x (an-element-of (list 1 2 3)))) x)
 
;;;;;;;;;;
;; 4.51 ;;
;;;;;;;;;;
 
;; Permanent assignments have the form:  (permanent-set! <var> <value>)
(define (permanent-assignment? expr)
  (tagged-list? expr 'permanent-set!))
(define (permanent-assignment-variable expr) (second expr))
(define (permanent-assignment-value expr) (third expr))
 
; do not restore old value if branch later fails
(define (analyze-permanent-assignment expr) 
  (define var (permanent-assignment-variable expr))
  (define vproc (analyze (permanent-assignment-value expr)))
  (lambda (env succeed fail)
    (vproc env
           (lambda (val fail2)
             (set-variable-value! var val env)
             (succeed 'ok
                      (lambda ()
                        (fail2))))
           fail)))
 
;; USING PERMANENT-SET!
 
;; Notice how count skips 1, 5, and 9, when x = y.
 
;; (driver-loop)
;; ;;; Amb-Eval input:
;; (define count 0)
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; ok
;; ;;; Amb-Eval input:
;; (let ([x (an-element-of '(a b c))]
      ;; [y (an-element-of '(a b c))])
  ;; (permanent-set! count (+ count 1))
  ;; (my-require (not (eq? x y)))
  ;; (list x y count))
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; (a b 2)
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; (a c 3)
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; (b a 4)
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; (b c 6)
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; (c a 7)
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; (c b 8)
;; ;;; Amb-Eval input:
;; try-again
;; ;;; There are no more values of
;; (let ((x (an-element-of '(a b c)))
      ;; (y (an-element-of '(a b c))))
  ;; (permanent-set! count (+ count 1))
  ;; (my-require (not (eq? x y)))
  ;; (list x y count))
 
;; USING SET!
 
;; Using set!, count never increments.
 
#|
(driver-loop)
;;; Amb-Eval input:
(define count 0)
;;; Starting a new problem 
;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(let ([x (an-element-of '(a b c))]
      [y (an-element-of '(a b c))])
  (set! count (+ count 1))
  (my-require (not (eq? x y)))
  (list x y count))
 
;;; Starting a new problem 
;;; Amb-Eval value:
(a b 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(a c 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(b a 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(b c 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(c a 1)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(c b 1)
;;; Amb-Eval input:
try-again
;;; There are no more values of
(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (set! count (+ count 1))
  (my-require (not (eq? x y)))
  (list x y count))
|#
 
;;;;;;;;;;
;; 4.52 ;;
;;;;;;;;;;
 
;; if-fail expressions have the form:  (if-fail <success-clause> <failure-clause>)
(define (if-fail? expr) (tagged-list? expr 'if-fail))
(define (if-fail-success-clause expr) (second expr))
(define (if-fail-failure-clause expr) (third expr))
 
(define (analyze-if-fail expr)
  (define sproc (analyze (if-fail-success-clause expr)))
  (define fproc (analyze (if-fail-failure-clause expr)))
  (lambda (env succeed fail)
    (sproc env
           ; what you do when amb returns a value val
           (lambda (val fail2) 
             (succeed val fail2))
           ; what you do when amb fails to return a value
           (lambda () (fproc env succeed fail))))) 
 
;; Be sure to add even? to primitive procedures.
 
;; test
 
;; (driver-loop)
;; ;;; Amb-Eval input:
;; (if-fail (let ([x (an-element-of '(1 3 5))])
           ;; (my-require (even? x))
           ;; x)
         ;; 'all-odd)
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; all-odd
;; ;;; Amb-Eval input:
;; (if-fail (let ([x (an-element-of '(1 3 5 8))])
           ;; (my-require (even? x))
           ;; x)
         ;; 'all-odd)
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; 8
;; ;;; Amb-Eval input:
;; (if-fail (let ([x (an-element-of '(1 3))])
           ;; (my-require (odd? x))
           ;; x)
         ;; 'all-even)
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; 1
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; 3
;; ;;; Amb-Eval input:
;; try-again
;; ;;; Amb-Eval value:
;; all-even
 
;;;;;;;;;;
;; 4.53 ;;
;;;;;;;;;;
 
;; Be sure to add prime? from math/number-theory to primitive procedures.
 
(define (prime-sum-pair list1 list2)
  (let ([a (an-element-of list1)]
        [b (an-element-of list2)])
    (my-require (prime? (+ a b)))
    (list a b)))
 
(let ([pairs empty])
  (if-fail (let ([p (prime-sum-pair '(1 3 5 8) '(20 35 110))])
             (permanent-set! pairs (cons p pairs))
             (amb))
           pairs))
 
;; test
 
;; (driver-loop)
;; ;;; Amb-Eval input:
;; (define (prime-sum-pair list1 list2)
  ;; (let ([a (an-element-of list1)]
        ;; [b (an-element-of list2)])
    ;; (my-require (prime? (+ a b)))
    ;; (list a b)))
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; ok
;; ;;; Amb-Eval input:
;; (let ([pairs '()])
  ;; (if-fail (let ([p (prime-sum-pair '(1 3 5 8) '(20 35 110))])
             ;; (permanent-set! pairs (cons p pairs))
             ;; (amb))
           ;; pairs))
;; ;;; Starting a new problem 
;; ;;; Amb-Eval value:
;; ((8 35) (3 110) (3 20))
;; ;;; Amb-Eval input:
;; try-again
;; ;;; There are no more values of
;; (let ((pairs empty))
  ;; (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
             ;; (permanent-set! pairs (cons p pairs))
             ;; (amb)) pairs))
 
;;;;;;;;;;
;; 4.54 ;;
;;;;;;;;;;
 
(define (my-require? expr) (tagged-list? expr 'my-require))
(define (my-require-predicate expr) (second expr))
 
(define (analyze-my-require expr)
  (define pproc (analyze (my-require-predicate expr)))
  (lambda (env succeed fail)
    (pproc env
           (lambda (pred-value fail2)
             (if (not pred-value)
               ; fail if predicate false
               (fail) 
               ; continue if predicate true
               (succeed 'ok fail2))) 
           ; fail if search fails
           fail))) 
 
;; test
 
#|
(driver-loop)
;;; Amb-Eval input:
(define (multiple-dwelling)
   (let ([baker (an-element-of (list 1 2 3 4 5))])
     (my-require (not (= baker 5)))
     (let ([cooper (amb 1 2 3 4 5)])
       (my-require (not (= cooper 1)))
       (let ([fletcher (amb 1 2 3 4 5)])
         (my-require (not (= fletcher 5)))
         (my-require (not (= fletcher 1)))
         (my-require (not (= (abs (- fletcher cooper)) 1)))
         (let ([miller (amb 1 2 3 4 5)])
           (my-require (> miller cooper))
           (let ([smith (amb 1 2 3 4 5)])
             (my-require (distinct? (list baker cooper fletcher miller smith)))
             ;; (my-require (not (= (abs (- smith fletcher)) 1)))
             (list (list 'baker baker)
                   (list 'cooper cooper)
                   (list 'fletcher fletcher)
                   (list 'miller miller)
                   (list 'smith smith))))))))
;;; Starting a new problem 
;;; Amb-Eval value:
ok
;;; Amb-Eval input:
(multiple-dwelling)
;;; Starting a new problem 
;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
;;; Amb-Eval input:
try-again
;;; There are no more values of
(multiple-dwelling)
|#