Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #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))
- |#
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement