src/sicp/ex4_43.rkt

   1 #lang racket
   2
   3 (require "amb-eli.rkt")
   4 (require "distinct.rkt")
   5
   6 #|
   7
   8 Fathers:
   9
  10 1. Moore  - yatch - lorna
  11 2. Colonel Downing - melissa
  12 3. Mr. Hall - rosalind
  13 4. Sir Barnacle Hood (Melissa's father) - gabreille
  14 5. Dr. Parker - mary ann moore
  15
  16 Daughters
  17
  18 1. Mary Ann Moore
  19 2. Gabrielle
  20 3. Lorna
  21 4. Rosalind
  22 5. Melissa's father is Sir Barnacle Hood
  23
  24 |#
  25
  26 (define (get-yatch father)
  27   (case (string->symbol (string-append (symbol->string father) "-y"))
  28     [(moore-y) 'lorna]
  29     [(downing-y) 'melissa]
  30     [(hall-y) 'rosa]
  31     [(barnacle-y) 'gab]
  32     [(parker-y) 'mary]))
  33
  34 (define (father x) (first x))
  35 (define (daughter x) (second x))
  36 (define (yat x) (third x))
  37
  38 (define (yatch)
  39   (let ([moore (list (amb 'mary) 'lorna)]
  40         [downing  (list 'downing (amb 'gab 'lorna 'rosa) 'melissa)]
  41         [hall (list 'hall (amb 'gab 'lorna) 'rosa)]
  42         [barnacle (list 'barnacle (amb 'melissa) 'gab)]
  43         [parker (list 'parker (amb 'gab 'lorna 'rosa) 'mary)])
  44     (let ([gab-father (amb hall downing parker)]
  45           [lorna-father (amb hall downing parker)])
  46       (assert (eq? (daughter gab-father) 'gab))
  47       (assert (eq? (daughter lorna-father) 'lorna))
  48       (assert (eq? (yat gab-father) (daughter parker)))
  49       (assert (not (eq? (daughter lorna-father) (yat lorna-father))))
  50       (assert (not (eq? (daughter gab-father) (yat gab-father))))
  51       lorna-father)))
  52
  53 (yatch)