Pasted

#lang racket
 
;;;;;;;;;;
;; 4.38 ;;
;;;;;;;;;;
 
(define (partial-solution? baker cooper fletcher miller smith)
  (and ; (distinct? (list baker cooper fletcher miller smith))
       (not (= baker 5))
       (not (= cooper 1))
       (not (= fletcher 5))
       (not (= fletcher 1))
       (> miller cooper)
       ; (not (= (abs (- smith fletcher)) 1))
       (not (= (abs (- fletcher cooper)) 1))))
 
(define (solve-partial-multiple-dwelling)
  (for/list ([floors (in-permutations (range 1 6))]
             #:when (apply partial-solution? floors))
            (map list
                 '(baker cooper fletcher miller smith)
                 floors)))
 
(solve-partial-multiple-dwelling)
;; '(((baker 3) (cooper 4) (fletcher 2) (miller 5) (smith 1))
  ;; ((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1))
  ;; ((baker 1) (cooper 4) (fletcher 2) (miller 5) (smith 3))
  ;; ((baker 1) (cooper 2) (fletcher 4) (miller 5) (smith 3))
  ;; ((baker 1) (cooper 2) (fletcher 4) (miller 3) (smith 5)))
 
;; So there are five solutions to the modified problem.
 
;;;;;;;;;;
;; 4.39 ;;
;;;;;;;;;;
 
;; If computing whether the restrictions are satisfied takes a long time, then it
;; would make sense to put the most stringent restrictions first, to save having to
;; check later restrictions.  However, I doubt checking the restrictions takes
;; significant time compared to generating all the tuples.  So I don't think the
;; order matters very much.
 
;;;;;;;;;;
;; 4.40 ;;
;;;;;;;;;;
 
;; The number of non-distinct assignments is 5 ^ 5 = 3125.  The number of distinct
;; assignments is 5! = 120.
 
#| 
(define (multiple-dwelling)
  (let ([baker (amb 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 (not (= (abs (- smith fletcher)) 1)))
            (my-require (distinct? (list baker cooper fletcher miller smith)))
            (list (list 'baker baker)
                  (list 'cooper cooper)
                  (list 'fletcher fletcher)
                  (list 'miller miller)
                  (list 'smith smith))))))))
|#
 
;;;;;;;;;;
;; 4.41 ;;
;;;;;;;;;;
 
(define (solution? baker cooper fletcher miller smith)
  (and ; (distinct? (list baker cooper fletcher miller smith))
       (not (= baker 5))
       (not (= cooper 1))
       (not (= fletcher 5))
       (not (= fletcher 1))
       (> miller cooper)
       (not (= (abs (- smith fletcher)) 1))
       (not (= (abs (- fletcher cooper)) 1))))
 
(define (solve-multiple-dwelling)
  (for/list ([floors (in-permutations (range 1 6))]
             #:when (apply solution? floors))
            (map list
                 '(baker cooper fletcher miller smith)
                 floors)))
 
(solve-multiple-dwelling)
;; '(((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
 
;;;;;;;;;;
;; 4.42 ;;
;;;;;;;;;;
 
(define (liars-solution? betty ethel joan kitty mary)
  (define betty1 (= kitty 2))
  (define betty2 (= betty 3))
  (define ethel1 (= ethel 1))
  (define ethel2 (= joan 2))
  (define joan1 (= joan 3))
  (define joan2 (= ethel 5))
  (define kitty1 (= kitty 2))
  (define kitty2 (= mary 4))
  (define mary1 (= mary 4))
  (define mary2 (= betty 1))
  (define (one-false-one-true? s1 s2)
    (or (and s1 (not s2))
        (and (not s1) s2)))
  (and (one-false-one-true? betty1 betty2)
       (one-false-one-true? ethel1 ethel2)
       (one-false-one-true? joan1 joan2)
       (one-false-one-true? kitty1 kitty2)
       (one-false-one-true? mary1 mary2)))
 
(define (solve-liars)
  (for/list ([places (in-permutations (range 1 6))]
             #:when (apply liars-solution? places))
            (map list
                 '(betty ethel joan kitty mary)
                 places)))
 
(solve-liars)
;; '(((betty 3) (ethel 5) (joan 2) (kitty 1) (mary 4)))
 
;;;;;;;;;;
;; 4.43 ;;
;;;;;;;;;;
 
;; Each has a require depending on parker, so parker is first.  Then I arranged them
;; by the number of requires each needed.
 
;; Note that I did not try to pre-compute any of the assignments, even though we know
;; several of the men's yachts and some of their daughters.  That doesn't seem to be
;; in the spirit of this kind of program.
 
;; Also note that the statement "Gabrielle's father's yacht is named after Parker's
;; daughter" means "X-daughter = 'gabrielle => X-yacht = parker-daughter", which is
;; equivalent to "X-daughter != 'gabrielle or X-yacht = parker-daughter" for each of
;; the five men X.
 
#|
(define (fathers-daughters-and-yachts)
  (define names '(mary-ann gabrielle lorna rosalind melissa))
  (let ([parker-daughter (an-element-of names)]
        [parker-yacht (an-element-of names)])
    (my-require (not (eq? parker-daughter parker-yacht)))
    (my-require (or (not (eq? parker-daughter 'gabrielle))
                    (eq? parker-yacht parker-daughter)))
    (let ([hood-daughter (an-element-of names)]
          [hood-yacht (an-element-of names)])
      (my-require (eq? hood-yacht 'gabrielle))
      (my-require (eq? hood-daughter 'melissa))
      (my-require (not (eq? hood-daughter hood-yacht)))
      (my-require (or (not (eq? hood-daughter 'gabrielle))
                      (eq? hood-yacht parker-daughter)))
      (let ([moore-daughter (an-element-of names)]
            [moore-yacht (an-element-of names)])
        ;; (my-require (eq? moore-daughter 'mary-ann))
        (my-require (eq? moore-yacht 'lorna))
        (my-require (not (eq? moore-daughter moore-yacht)))
        (my-require (or (not (eq? moore-daughter 'gabrielle))
                        (eq? moore-yacht parker-daughter)))
        (let ([downing-daughter (an-element-of names)]
              [downing-yacht (an-element-of names)])
          (my-require (eq? downing-yacht 'melissa))
          (my-require (not (eq? downing-daughter downing-yacht)))
          (my-require (or (not (eq? downing-daughter 'gabrielle))
                          (eq? downing-yacht parker-daughter)))
          (let ([hall-daughter (an-element-of names)]
                [hall-yacht (an-element-of names)])
            (my-require (eq? hall-yacht 'rosalind))
            (my-require (not (eq? hall-daughter hall-yacht)))
            (my-require (or (not (eq? hall-daughter 'gabrielle))
                            (eq? hall-yacht parker-daughter)))
            (list (list 'moore moore-daughter)
                  (list 'downing downing-daughter)
                  (list 'hall hall-daughter)
                  (list 'hood hood-daughter)
                  (list 'parker parker-daughter))))))))
|#
 
(define (partial-fd-solution?
          moore-daughter
          downing-daughter
          hall-daughter
          hood-daughter
          parker-daughter
          moore-yacht
          downing-yacht
          hall-yacht
          hood-yacht
          parker-yacht)
  (and 
    (not (eq? moore-daughter moore-yacht))
    (not (eq? downing-daughter downing-yacht))
    (not (eq? hall-daughter hall-yacht))
    (not (eq? hood-daughter hood-yacht))
    (not (eq? parker-daughter parker-yacht))
    ; (eq? moore-daughter 'mary-ann)
    (eq? hood-yacht 'gabrielle)
    (eq? moore-yacht 'lorna)
    (eq? hall-yacht 'rosalind)
    (eq? downing-yacht 'melissa)
    (eq? hood-daughter 'melissa)
    (or (not (eq? moore-daughter 'gabrielle))
        (eq? moore-yacht parker-daughter))
    (or (not (eq? downing-daughter 'gabrielle))
        (eq? downing-yacht parker-daughter))
    (or (not (eq? hall-daughter 'gabrielle))
        (eq? hall-yacht parker-daughter))
    (or (not (eq? hood-daughter 'gabrielle))
        (eq? hood-yacht parker-daughter))
    (or (not (eq? parker-daughter 'gabrielle))
        (eq? parker-yacht parker-daughter))
          ))
 
(define (solve-partial-fathers-and-daughters)
  (define names '(mary-ann gabrielle lorna rosalind melissa))
  (for*/list ([daughters (in-permutations names)]
              [yachts (in-permutations names)]
              #:when (apply partial-fd-solution?
                            (append daughters yachts)))
             (map list
                  '(moore downing hall hood parker)
                  daughters)))
 
(solve-partial-fathers-and-daughters)
;; '(((moore gabrielle)
   ;; (downing rosalind)
   ;; (hall mary-ann)
   ;; (hood melissa)
   ;; (parker lorna))
  ;; ((moore mary-ann)
   ;; (downing lorna)
   ;; (hall gabrielle)
   ;; (hood melissa)
   ;; (parker rosalind)))
 
;; If we don't know that moore-daughter = 'mary-ann, then there are two solutions.
 
;;;;;;;;;;
;; 4.44 ;;
;;;;;;;;;;
 
;; A queen is a list of two numbers, the row coordinate and the column coordinate.  A
;; position is a list of queens.
 
(define (make-queen row col) (list row col))
(define (row-coord queen) (first queen))
(define (col-coord queen) (second queen))
 
(define (safe? queen1 queen2)
  (and (not (= (row-coord queen1)
               (row-coord queen2)))
       (not (= (abs (- (col-coord queen1)
                       (col-coord queen2)))
               (abs (- (row-coord queen1)
                       (row-coord queen2)))))))
 
(define (safe-from-others? queen other-queens)
  (andmap (lambda (q) (safe? queen q)) other-queens))
 
#|
(define (queens)
  (define rows (range 1 9))
  (let ([row1 (an-element-of rows)]
        [row2 (an-element-of rows)]
        [row3 (an-element-of rows)]
        [row4 (an-element-of rows)]
        [row5 (an-element-of rows)]
        [row6 (an-element-of rows)]
        [row7 (an-element-of rows)]
        [row8 (an-element-of rows)])
    (define queen1 (make-queen row1 1))
    (define queen2 (make-queen row2 2))
    (define queen3 (make-queen row3 3))
    (define queen4 (make-queen row4 4))
    (define queen5 (make-queen row5 5))
    (define queen6 (make-queen row6 6))
    (define queen7 (make-queen row7 7))
    (define queen8 (make-queen row8 8))
    (define all-queens
      (list queen1 queen2 queen3 queen4
            queen5 queen6 queen7 queen8))
    (define (queens-following queen)
      (rest (member queen all-queens)))
    (my-require (safe-from-others? queen1 (queens-following queen1)))
    (my-require (safe-from-others? queen2 (queens-following queen2)))
    (my-require (safe-from-others? queen3 (queens-following queen3)))
    (my-require (safe-from-others? queen4 (queens-following queen4)))
    (my-require (safe-from-others? queen5 (queens-following queen5)))
    (my-require (safe-from-others? queen6 (queens-following queen6)))
    (my-require (safe-from-others? queen7 (queens-following queen7)))
    all-queens))
|#
 
;;;;;;;;;;
;; 4.45 ;;
;;;;;;;;;;
 
#|
 
;; 1. The student is in the class, the student has a 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)
                                (simple-noun-phrase
                                  (article the) (noun class)))
                   (prep-phrase (prep with)
                                (simple-noun-phrase
                                  (article the) (noun cat)))))))
 
;; 2. The student is in the class, the class has a 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)
                                (simple-noun-phrase
                                  (article the) (noun class))
                                (prep-phrase (prep with)
                                             (simple-noun-phrase
                                               (article the) (noun cat))))))))
 
;; 3. The student is in the class, the professor has a 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)
                                (simple-noun-phrase
                                  (article the) (noun class)))))
    (prep-phrase (prep with)
                 (simple-noun-phrase
                   (article the) (noun cat)))))
 
;; 4. The professor is in the class, the professor has a 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)
                 (simple-noun-phrase
                   (article the) (noun class)))
    (prep-phrase (prep with)
                 (simple-noun-phrase
                   (article the) (noun cat)))))
 
;; 5. The professor is in the class, the class has a 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)
                 (simple-noun-phrase
                   (article the) (noun class))
                 (prep-phrase (prep with)
                              (simple-noun-phrase
                                (article the) (noun cat))))))
 
|#
 
;;;;;;;;;;
;; 4.46 ;;
;;;;;;;;;;
 
;; None of the parsing procedures takes more than one parameter, so the order of
;; evaluation cannot matter.  What the authors must mean, is that the amb function
;; must do DFS starting with the left-most element of the list of elements to choose
;; from.  If that were not the case, then the maybe-extend procedures could not yield
;; a simple phrase, but would be forced to always choose an extended phrase.
 
;;;;;;;;;;
;; 4.47 ;;
;;;;;;;;;;
 
;; ; book definition
;; (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)))
 
;; ; loose reasoner definition
;; (define (parse-verb-phrase)
  ;; (amb (parse-word verbs)
       ;; (list 'verb-phrase
             ;; (parse-verb-phrase)
             ;; (parse-prepositional-phrase))))
 
;; This does not work.  If the next unparsed word is not a verb, you would enter an
;; infinite loop, instead of doing the right thing and failing.
 
;; If the order of the amb clauses was reversed, you would immediately fall into an
;; infinite loop irregardless of what the next word was.
 
;;;;;;;;;;
;; 4.48 ;;
;;;;;;;;;;
 
;; To add adjectives and adverbs, we need to use amb to make their appearance
;; optional at the beginning of a maybe extended noun or verb phrase.
 
#|
(define (parse-simple-noun-phrase)
  (list 'simple-noun-phrase
        (parse-word articles)
        (parse-word nouns)))
 
(define (parse-modified-noun-phrase)
  (list 'modified-noun-phrase
        (parse-word articles)
        (parse-word adjectives)
        (parse-word nouns)))
 
(define (parse-noun-phrase)
  (define initial-noun-phrase
    (amb (parse-simple-noun-phrase)
         (parse-modified-noun-phrase)))
  (define (maybe-extend noun-phrase)
    (amb noun-phrase
         (maybe-extend (list 'noun-phrase
                             noun-phrase
                             (parse-prepositional-phrase)))))
  (maybe-extend initial-noun-phrase))
 
(define (parse-verb-phrase)
  (define initial-verb-phrase
    (amb (parse-word verbs)
         (list 'modified-verb
               (parse-word adverbs)
               (parse-word verbs))))
  (define (maybe-extend verb-phrase)
    (amb verb-phrase
         (maybe-extend (list 'verb-phrase
                             verb-phrase
                             (parse-prepositional-phrase)))))
  (maybe-extend initial-verb-phrase))
|#
 
;;;;;;;;;;
;; 4.49 ;;
;;;;;;;;;;
 
;; Originally I gave the parser/generator a 50/50 chance to use maybe-extend, but the
;; sentences were way too long.  So now the chance to use maybe-extend is 1 in 5.
 
(require racket/random) ; for random-ref, to randomly choose elt from a list
 
(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 (generate-word word-list)
  (list (first word-list)
        (random-ref (rest word-list))))
 
(define (generate-prepositional-phrase)
  (list 'prep-phrase
        (generate-word prepositions)
        (generate-noun-phrase)))
 
(define (generate-verb-phrase)
  (define (maybe-extend verb-phrase)
    (if (not (zero? (random 5))) ; 80% chance of true
      verb-phrase
      (maybe-extend (list 'verb-phrase
                          verb-phrase
                          (generate-prepositional-phrase)))))
  (maybe-extend (generate-word verbs)))
 
(define (generate-simple-noun-phrase)
  (list 'simple-noun-phrase
        (generate-word articles)
        (generate-word nouns)))
 
(define (generate-noun-phrase)
  (define (maybe-extend noun-phrase)
    (if (not (zero? (random 5)))
      noun-phrase
      (maybe-extend (list 'noun-phrase
                          noun-phrase
                          (generate-prepositional-phrase)))))
  (maybe-extend (generate-simple-noun-phrase)))
 
(define (generate-sentence)
  (list 'sentence
        (generate-noun-phrase)
        (generate-verb-phrase)))
 
#|
(for ([i 6]) (displayln (generate-sentence)))
 
;; "A class eats for a professor."
(sentence
  (simple-noun-phrase (article a)
                      (noun class))
  (verb-phrase (verb eats)
               (prep-phrase (prep for)
                            (simple-noun-phrase (article a)
                                                (noun professor)))))
 
;; The professor for a student for a class with a professor studies by a class.
(sentence
  (noun-phrase
    (noun-phrase
      (noun-phrase
        (simple-noun-phrase (article the)
                            (noun professor))
        (prep-phrase (prep for)
                     (simple-noun-phrase (article a)
                                         (noun student))))
      (prep-phrase (prep for)
                   (simple-noun-phrase (article a)
                                       (noun class))))
    (prep-phrase (prep with)
                 (simple-noun-phrase (article a)
                                     (noun professor))))
  (verb-phrase (verb studies)
               (prep-phrase (prep by)
                            (simple-noun-phrase (article a)
                                                (noun class)))))
 
;; A cat studies.
(sentence
  (simple-noun-phrase (article a)
                      (noun cat))
  (verb studies))
 
;; A student lectures.
(sentence
  (simple-noun-phrase (article a)
                      (noun student))
  (verb lectures))
 
;; The cat eats.
(sentence
  (simple-noun-phrase (article the)
                      (noun cat))
  (verb eats))
 
;; The cat lectures.
(sentence (simple-noun-phrase (article the)
                              (noun cat))
          (verb lectures))
|#