SICP/ex-4_45-54.scm

(load "util.scm")
(load "misc/sicp-ambeval.scm")

(define the-global-environment (setup-environment))
(define result '())

(define (amball exp)
  (set! result '()) ; reset result
  (ambeval exp
           the-global-environment
           (lambda (value next)
             (set! result (cons value result))
             (next))
           (lambda () result))
  (set! result (reverse result))
  result)

(define (amb5 exp)
  ;; puts the first five amb results into result
  (set! count 0)
  (set! result '())
  (ambeval exp
           the-global-environment
           (lambda (value next)
             (set! result (cons value result))
             (set! count (+ count 1))
             (if (< count 5)
               (next)
               result))
           (lambda () result))
  (set! result (reverse result))
  result)

(amball '(begin

(define (require p)
  (if (not p) (amb)))

(define nouns '(noun student professor cat class))
(define verbs '(verb studies lectures eats sleeps))
(define articles '(article the a))
(define prepositions '(prep for to in by with))
(define adjectives '(adjective pretty kind mean bad))

(define (parse-word word-list)
  (require (not (null? *unparsed*)))
  (require (memq (car *unparsed*) (cdr word-list)))
  (let ((found-word (car *unparsed*)))
    (set! *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

(define (parse-prepositional-phrase)
  (list 'prep-phrase
        (parse-word prepositions)
        (parse-noun-phrase)))

(define (parse-sentence)
  (list 'sentence
         (parse-noun-phrase)
         (parse-verb-phrase)))

(define (parse-noun-phrase)
  (define (maybe-extend noun-phrase)
    (amb noun-phrase
         (maybe-extend (list 'noun-phrase
                             noun-phrase
                             (parse-prepositional-phrase)))))
  (maybe-extend (parse-simple-noun-phrase)))

(define (parse-verb-phrase)
  (define (maybe-extend verb-phrase)
    (amb verb-phrase
         (maybe-extend (list 'verb-phrase
                             verb-phrase
                             (parse-prepositional-phrase)))))
  (maybe-extend (parse-word verbs)))

(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(define *unparsed* '())
(define (parse input)
  (set! *unparsed* input)
  (let ((sent (parse-sentence)))
    (require (null? *unparsed*))
    sent))

(parse '(the professor lectures to the student with the cat))
))

;'The professor lectures to the student in the class with the cat.'
(assert
  (first result)
  '(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
    (verb-phrase
     (verb lectures)
     (prep-phrase (prep to)
                  (simple-noun-phrase
                   (article the) (noun student))))
    (prep-phrase (prep with)
                 (simple-noun-phrase
                  (article the) (noun cat))))))
(assert
  (second result)
  '(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
    (verb lectures)
    (prep-phrase (prep to)
                 (noun-phrase
                  (simple-noun-phrase
                   (article the) (noun student))
                  (prep-phrase (prep with)
                               (simple-noun-phrase
                                (article the) (noun cat))))))))

(display "\nex-4.45 - sentence-meanings\n")

(amball '(parse '(The professor lectures to the student in the class with the cat)))
(assert (length result) 5)

'(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
     (verb-phrase
       (verb-phrase
         (verb lectures)
         (prep-phrase
           (prep to) (simple-noun-phrase (article the) (noun student))))
       (prep-phrase
         (prep in) (simple-noun-phrase (article the) (noun class))))
     (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))

; (The professor lectures (to the student) in the class with the cat).

'(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
     (verb-phrase
       (verb lectures)
       (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student))))
     (prep-phrase
       (prep in)
       (noun-phrase
         (simple-noun-phrase (article the) (noun class))
         (prep-phrase (prep with)
                      (simple-noun-phrase (article the) (noun cat)))))))

; (The professor lectures to the student (in the class with the cat)).

'(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
     (verb-phrase
       (verb lectures)
       (prep-phrase
         (prep to)
         (noun-phrase
           (simple-noun-phrase (article the) (noun student))
           (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class))))))
     (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))

; The professor lectures (to the student in the class) with the cat.

'(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
     (verb lectures)
     (prep-phrase
       (prep to)
       (noun-phrase
         (noun-phrase
           (simple-noun-phrase (article the) (noun student))
           (prep-phrase (prep in)
                        (simple-noun-phrase (article the) (noun class))))
         (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))

; The professor lectures ((to the student in the class) with the cat).

'(sentence
   (simple-noun-phrase (article the) (noun professor))
   (verb-phrase
     (verb lectures)
     (prep-phrase
       (prep to)
       (noun-phrase
         (simple-noun-phrase (article the) (noun student))
         (prep-phrase
           (prep in)
           (noun-phrase
             (simple-noun-phrase (article the) (noun class))
             (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat)))))))))

; The professor lectures (to the student (in the class with the cat)).

(display "[answered]\n")

(display "\nex-4.46 - evaluation-order\n")

; Consider the definition of parse sentence. Grammar defines that the
; noun-phrase comes before the verb-phrase and that is how we ordered the
; sub-calls to the parser. If the evaluator would read the arguments from right
; to left it would attempt to parse a verb-phrase first and fail for most
; sentences (maybe it would work for questions). We could force the correct
; order by using nested let-expressions to make the code
; interpreter-independent.

; (define (parse-sentence)
;   (list 'sentence
;          (parse-noun-phrase)
;          (parse-word verbs)))

(display "[answered]\n")

(display "\nex-4.47 - alternative-parse-verb-phrase\n")

; Louis's code results in an endless-loop. The reason is that amb evaluates its
; arguments in applicative order. That means (parse-verb-phrase) executes
; recursively.  By parsing the verb-phrase first we avoid this issue. Changing
; the order of the arguments does not resolve this issue.

; (amball '(begin
; (define (parse-verb-phrase)
;   (display *unparsed*) (display "\n")
;   (amb (parse-word verbs)
;        (list 'verb-phrase
;              (parse-verb-phrase)
;              (parse-prepositional-phrase))))
; (parse '(the cat eats) ; endless-loop
; )))

(display "[answered]\n")

(display "\nex-4.48 - parse-other-phrases\n")

 ; Exercise 4.48.  Extend the grammar given above to handle more complex
 ; sentences. For example, you could extend noun phrases and verb phrases to
 ; include adjectives and adverbs, or you could handle compound sentences.53

(amball '(begin

(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))

(define (parse-adjective-noun-phrase adjective)
  (amb (list 'adjective-phrase  adjective (parse-word nouns))
       (list
         'adjective-phrase
         adjective
         (parse-adjective-noun-phrase (parse-word adjectives)))))

(define (parse-simple-noun-phrase)
  (let ((article (parse-word articles)))
    (amb (list 'simple-noun-phrase article (parse-word nouns))
         (list 'adjective-noun-phrase article
               (parse-adjective-noun-phrase (parse-word adjectives))))))

(parse '(the bad cat eats))))

(assert  (first result)
         '(sentence (adjective-noun-phrase (article the) (adjective-phrase (adjective bad) (noun cat))) (verb eats)))

(display "\nex-4.49 - generate-sentence\n")

(amb5 '(begin
(define (list-amb word-list)
  (if (null? word-list)
    (amb)
    (amb (car word-list) (list-amb (cdr word-list)))))
(define (parse-word word-list)
  (require (not (null? *unparsed*)))
  (require (memq (car *unparsed*) (cdr word-list)))
  (let ((found-word (list-amb (cdr word-list))))
    (set! *unparsed* (cdr *unparsed*))
    (list (car word-list) found-word)))

(parse '(the cat eats))
))

(map (lambda (r) (display r) (newline)) result)
(display "[ok]\n")

(display "\nex-4.50 - ramb\n")

(define (random-element xs)
  (define (create i n xs current others)
    (if (null? xs)
      (list current others)
      (if (= i n)
        (create (+ i 1) n (cdr xs) (car xs) others)
        (create (+ i 1) n (cdr xs) current (cons (car xs) others)))))
  (create 0 (random (length xs)) xs #f '()))

(define (analyze-ramb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-next choices)
        (if (null? choices)
            (fail)
            (let* ((pair (random-element choices))
                   (current (car pair))
                   (others (cadr pair)))
            (current env
                     succeed
                     (lambda () (try-next others))))))
      (try-next cprocs))))

(amball '(ramb 1 2 3 4 5))
(display result) (newline)
(display "[ok]\n")

; This implementation of ramb cannot directly help us with Alyssa's problem
; because we used list-amb to get amb behavior. We would need list-ramb which would
; require shuffling the items inside the evalutor or use something like apply.

(display "\nex-4.51 - permanent-set!\n")

(amball '(begin
(define count 0)
(let ((x (amb 'a 'b 'c))
      (y (amb 'a 'b 'c)))
  (permanent-set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))
))

; With set! all counts would be 1. With permanent-set! every tried combination
; increments the counts. Hence, all counts are unique and count increments up
; to 9. (c c) would be nine and (b c) is eight.

(define (last xs)
  (if (null? (cdr xs))
    (car xs)
    (last (cdr xs))))

(assert (first result) '(a b 2))
(assert (last result) '(c b 8))

(display "\nex-4.52 - if-fail\n")

; Exercise 4.52.  Implement a new construct called if-fail that permits the
; user to catch the failure of an expression. If-fail takes two expressions. It
; evaluates the first expression as usual and returns as usual if the
; evaluation succeeds. If the evaluation fails, however, the value of the
; second expression is returned, as in the following example:

(define (analyze-if-fail exp)
  (let ((a (analyze (if-fail-first exp)))
        (b (analyze (if-fail-second exp))))
    (lambda (env succeed fail)
      (a env
         (lambda (a-value fail2) (succeed a-value fail2))
         (lambda () (b env succeed fail))))))

;;; Amb-Eval input:
(amball '(begin

(define (even? n)
  (= (remainder n 2) 0))

(if-fail (let ((x (amb 1 3 5)))
           (require (even? x))
           x)
         'all-odd)

(if-fail (let ((x (amb 1 3 5 8)))
           (require (even? x))
           x)
         'all-odd)

))

(assert result '(8 all-odd))

(display "\nex-4.53\n")

; (let ((pairs '()))
;   (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
;              (permanent-set! pairs (cons p pairs))
;              (amb))
;            pairs))

; The code will yield all prime-sum-pairs as expected.

(display "[answered]\n")

(display "\nex-4.54\n")

; Exercise 4.54.  If we had not realized that require could be implemented as
; an ordinary procedure that uses amb, to be defined by the user as part of a
; nondeterministic program, we would have had to implement it as a special
; form. This would require syntax procedures

; as well the procedure analyze-require that handles require expressions.
; Complete the following definition of analyze-require.

(define (analyze-require exp)
  (let ((pproc (analyze (require-predicate exp))))
    (lambda (env succeed fail)
      (pproc env
             (lambda (pred-value fail2)
               (if (not (true? pred-value))
                   (fail2)
                   (succeed 'ok fail2)))
             fail))))

(display "[done]\n")