1 ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 ;; about the language level of this file in a form that our tools can easily process.
3 #reader(lib "htdp-intermediate-reader.ss" "lang")((modname 15.1.1) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp")))))
4 ;A parent structure is
5 ;(make-parent children name date eyes)
6 ;where name and eyes are symbols,
7 ;date is a number, and children is a
8 ;list-of-children.
9 
10 (define-struct parent (children name date eyes))
11 ;
12 ;A list-of-children is either
13 ;1. an empty list or
14 ;2. (cons p loc) where p is a parent
15 ;and loc is a list-of-children.
16 
17 ;
18 ;fun-for-parent: parent -> ???
19 ;Template
20 ;(define (fun-for-parent a-parent)
21 ;  ... (parent-children a-parent) ...
22 ;  ... (parent-name a-parent) ...
23 ;  ... (parent-date a-parent) ...
24 ;  ... (parent-eyes a-parent) ...)
25 
26 ;
27 ;fun-for-loc : list-of-children -> ???
28 ;(define (fun-for-loc a-loc)
29 ;  (cond
30 ;    [(empty? a-loc) ...]
31 ;    [else ... (first a-loc) ...
32 ;          ... (fun-for-loc (rest a-loc)) ...]))
33 
34 ;blue-eyed-descendant? : parent -> boolean
35 ;Given a-parent, determines whether the parent
36 ;or any of its descendants have blue eyes.
37 
38 
39 (define (blue-eyed-descendant? a-parent)
40   (cond
41     [(symbol=? (parent-eyes a-parent) 'blue) true]
42     [else (blue-eyed-children? (parent-children a-parent))]))
43 ;
44 ;blue-eyed-children? : list-of-children -> boolean
45 ;Given a-loc (list-of-children), return true if
46 ;any parent structure within the list-of-children have blue eyes
47 ;or if any of their descendants have blue eyes.
48 
49 (define (blue-eyed-children? a-loc)
50   (cond
51     [(empty? a-loc) false]
52     [else (or (blue-eyed-descendant? (first a-loc))
53               (blue-eyed-children? (rest a-loc)))]))
54 
55 ;Third Generation
56 (define Gustav (make-parent empty 'Gustav 1988 'brown))
57 
58 ;Second Generation
59 (define Fred (make-parent (list Gustav) 'Fred 1966 'pink))
60 (define Eva (make-parent (list Gustav) 'Eva 1965 'blue))
61 (define Dave (make-parent empty 'Dave 1955 'black))
62 (define Adam (make-parent empty 'Adam 1950 'yellow))
63 
64 ;First Generation
65 (define Bettina (make-parent (list Adam Dave Eva) 'Bettina 1926 'green))
66 (define Carl (make-parent (list Adam Dave Eva) 'Carl 1926 'green))
67 
68 ;Test - All should return true
69 ;(blue-eyed-descendant? Bettina)
70 ;(blue-eyed-descendant? Eva)
71 ;(not (blue-eyed-descendant? Gustav))
72 ;(not (blue-eyed-descendant? Adam))
73 ;
74 ;how-far-removed : parent -> number/false
75 ;Determine how many generations removed
76 ;a parent is from a blue-eyed child.  If
77 ;the parent himself has blue eyes, return 0.
78 ;If there is no blue-eyed child within
79 ;the parent's descendants, return false.
80 
81 (define (how-far-removed a-parent)
82  (cond
83    [(symbol=? (parent-eyes a-parent) 'blue) 0]
84    [else
85     (cond
86       [(false? (how-far-removed-children (parent-children a-parent))) false]
87       [else (+ 1
88                (how-far-removed-children (parent-children a-parent)))])]))
89 
90 ;how-far-removed-children : list-of-children -> number/false
91 ;Given a-loc, determine how many generations removed
92 ;the children are from blue-eyed descendants.  Return
93 ;false if there are no descendants with blue eyes, and
94 ;0 if one of the parent structures in a-loc has blue eyes.
95 ;If multiple descendants have blue-eyes, return the lowest number.
96 
97 (define (how-far-removed-children a-loc)
98   (cond
99     [(empty? a-loc) false]
100     [else
101      (cond
102        [(and (false? (how-far-removed (first a-loc)))
103              (false? (how-far-removed-children (rest a-loc)))) false]
104        [(false? (how-far-removed (first a-loc))) (how-far-removed-children (rest a-loc))]
105        [(false? (how-far-removed-children (rest a-loc))) (how-far-removed (first a-loc))]
106        [else (min (how-far-removed (first a-loc))
107                   (how-far-removed-children (rest a-loc)))])]))
108 ;
109 ;count-descendants : parent -> number
110 ;Given a-parent, compute the number of descendants.
111 ;The parent himself is included,
112 ;so only nonzero natural numbers should be returned.
113 ;
114 (define (count-descendants a-parent)
115   (+ 1
116      (count-descendants-children (parent-children a-parent))))
117 
118 ;count-descendants-children : list-of-children -> number
119 ;Given a-loc, determine the number of descendants
120 ;of the children.  The children are themselves included.
121 
122 (define (count-descendants-children a-loc)
123   (cond
124     [(empty? a-loc) 0]
125     [else (+ (count-descendants (first a-loc))
126              (count-descendants-children (rest a-loc)))]))
127 
128 ;count-proper-descendants : parent -> number
129 ;Given a-parent, determine the number
130 ;of proper descendants.  The parent himself
131 ;is not included.
132 
133 (define (count-proper-descendants a-parent)
134   (- (count-descendants a-parent)
135      1))
136 ;
137 ;A list of symbols is either
138 ;1. an empty list or
139 ;2. (cons s los) where s is a symbol and los is a list-of-symbols.
140 
141 ;eye-colors : parent -> list-of-symbols
142 ;Given a-parent, finds the eye colors of all
143 ;the descendants and returns them as a
144 ;list-of-symbols.
145 
146 (define (eye-colors a-parent)
147   (append (list (parent-eyes a-parent))
148           (eye-colors-children (parent-children a-parent))))
149 
150 ;eye-colors-children : list-of-children -> list-of-symbols
151 ;Given a-loc, determine the eye colors
152 ;of the list-of-children and their descendants and return
153 ;them as a list-of-symbols.
154 
155 (define (eye-colors-children a-loc)
156   (cond
157     [(empty? a-loc) empty]
158     [else (append (eye-colors (first a-loc))
159                   (eye-colors-children (rest a-loc)))]))