sicp-4-3-3-implementing-the-amb-evaluator

#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)
|#