1 12687dd9 2023-08-04 jrmu ;; The first three lines of this file were inserted by DrScheme. They record metadata
2 12687dd9 2023-08-04 jrmu ;; about the language level of this file in a form that our tools can easily process.
3 12687dd9 2023-08-04 jrmu #reader(lib "htdp-intermediate-reader.ss" "lang")((modname 18.1.10) (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 12687dd9 2023-08-04 jrmu ;A parent structure is
5 12687dd9 2023-08-04 jrmu ;(make-parent children name date eyes)
6 12687dd9 2023-08-04 jrmu ;where name and eyes are symbols,
7 12687dd9 2023-08-04 jrmu ;date is a number, and children is a
8 12687dd9 2023-08-04 jrmu ;list-of-children.
10 12687dd9 2023-08-04 jrmu (define-struct parent (children name date eyes))
12 12687dd9 2023-08-04 jrmu ;A list-of-children is either
13 12687dd9 2023-08-04 jrmu ;1. an empty list or
14 12687dd9 2023-08-04 jrmu ;2. (cons p loc) where p is a parent
15 12687dd9 2023-08-04 jrmu ;and loc is a list-of-children.
18 12687dd9 2023-08-04 jrmu ;fun-for-parent: parent -> ???
20 12687dd9 2023-08-04 jrmu ;(define (fun-for-parent a-parent)
21 12687dd9 2023-08-04 jrmu ; ... (parent-children a-parent) ...
22 12687dd9 2023-08-04 jrmu ; ... (parent-name a-parent) ...
23 12687dd9 2023-08-04 jrmu ; ... (parent-date a-parent) ...
24 12687dd9 2023-08-04 jrmu ; ... (parent-eyes a-parent) ...)
27 12687dd9 2023-08-04 jrmu ;fun-for-loc : list-of-children -> ???
28 12687dd9 2023-08-04 jrmu ;(define (fun-for-loc a-loc)
30 12687dd9 2023-08-04 jrmu ; [(empty? a-loc) ...]
31 12687dd9 2023-08-04 jrmu ; [else ... (first a-loc) ...
32 12687dd9 2023-08-04 jrmu ; ... (fun-for-loc (rest a-loc)) ...]))
34 12687dd9 2023-08-04 jrmu ;blue-eyed-descendant? : parent -> boolean
35 12687dd9 2023-08-04 jrmu ;Given a-parent, determines whether the parent
36 12687dd9 2023-08-04 jrmu ;or any of its descendants have blue eyes.
39 12687dd9 2023-08-04 jrmu (define (blue-eyed-descendant? a-parent)
41 12687dd9 2023-08-04 jrmu [(symbol=? (parent-eyes a-parent) 'blue) true]
42 12687dd9 2023-08-04 jrmu [else (blue-eyed-children? (parent-children a-parent))]))
44 12687dd9 2023-08-04 jrmu ;blue-eyed-children? : list-of-children -> boolean
45 12687dd9 2023-08-04 jrmu ;Given a-loc (list-of-children), return true if
46 12687dd9 2023-08-04 jrmu ;any parent structure within the list-of-children have blue eyes
47 12687dd9 2023-08-04 jrmu ;or if any of their descendants have blue eyes.
49 12687dd9 2023-08-04 jrmu (define (blue-eyed-children? a-loc)
51 12687dd9 2023-08-04 jrmu [(empty? a-loc) false]
52 12687dd9 2023-08-04 jrmu [else (or (blue-eyed-descendant? (first a-loc))
53 12687dd9 2023-08-04 jrmu (blue-eyed-children? (rest a-loc)))]))
55 12687dd9 2023-08-04 jrmu ;Third Generation
56 12687dd9 2023-08-04 jrmu (define Gustav (make-parent empty 'Gustav 1988 'brown))
58 12687dd9 2023-08-04 jrmu ;Second Generation
59 12687dd9 2023-08-04 jrmu (define Fred (make-parent (list Gustav) 'Fred 1966 'pink))
60 12687dd9 2023-08-04 jrmu (define Eva (make-parent (list Gustav) 'Eva 1965 'blue))
61 12687dd9 2023-08-04 jrmu (define Dave (make-parent empty 'Dave 1955 'black))
62 12687dd9 2023-08-04 jrmu (define Adam (make-parent empty 'Adam 1950 'yellow))
64 12687dd9 2023-08-04 jrmu ;First Generation
65 12687dd9 2023-08-04 jrmu (define Bettina (make-parent (list Adam Dave Eva) 'Bettina 1926 'green))
66 12687dd9 2023-08-04 jrmu (define Carl (make-parent (list Adam Dave Eva) 'Carl 1926 'green))
68 12687dd9 2023-08-04 jrmu ;Test - All should return true
69 12687dd9 2023-08-04 jrmu ;(blue-eyed-descendant? Bettina)
70 12687dd9 2023-08-04 jrmu ;(blue-eyed-descendant? Eva)
71 12687dd9 2023-08-04 jrmu ;(not (blue-eyed-descendant? Gustav))
72 12687dd9 2023-08-04 jrmu ;(not (blue-eyed-descendant? Adam))
74 12687dd9 2023-08-04 jrmu ;how-far-removed : parent -> number/false
75 12687dd9 2023-08-04 jrmu ;Determine how many generations removed
76 12687dd9 2023-08-04 jrmu ;a parent is from a blue-eyed child. If
77 12687dd9 2023-08-04 jrmu ;the parent himself has blue eyes, return 0.
78 12687dd9 2023-08-04 jrmu ;If there is no blue-eyed child within
79 12687dd9 2023-08-04 jrmu ;the parent's descendants, return false.
81 12687dd9 2023-08-04 jrmu (define (how-far-removed a-parent)
83 12687dd9 2023-08-04 jrmu [(symbol=? (parent-eyes a-parent) 'blue) 0]
86 12687dd9 2023-08-04 jrmu [(false? (how-far-removed-children (parent-children a-parent))) false]
88 12687dd9 2023-08-04 jrmu (how-far-removed-children (parent-children a-parent)))])]))
90 12687dd9 2023-08-04 jrmu ;how-far-removed-children : list-of-children -> number/false
91 12687dd9 2023-08-04 jrmu ;Given a-loc, determine how many generations removed
92 12687dd9 2023-08-04 jrmu ;the children are from blue-eyed descendants. Return
93 12687dd9 2023-08-04 jrmu ;false if there are no descendants with blue eyes, and
94 12687dd9 2023-08-04 jrmu ;0 if one of the parent structures in a-loc has blue eyes.
95 12687dd9 2023-08-04 jrmu ;If multiple descendants have blue-eyes, return the lowest number.
97 12687dd9 2023-08-04 jrmu (define (how-far-removed-children a-loc)
99 12687dd9 2023-08-04 jrmu [(empty? a-loc) false]
102 12687dd9 2023-08-04 jrmu [(and (false? (how-far-removed (first a-loc)))
103 12687dd9 2023-08-04 jrmu (false? (how-far-removed-children (rest a-loc)))) false]
104 12687dd9 2023-08-04 jrmu [(false? (how-far-removed (first a-loc))) (how-far-removed-children (rest a-loc))]
105 12687dd9 2023-08-04 jrmu [(false? (how-far-removed-children (rest a-loc))) (how-far-removed (first a-loc))]
106 12687dd9 2023-08-04 jrmu [else (min (how-far-removed (first a-loc))
107 12687dd9 2023-08-04 jrmu (how-far-removed-children (rest a-loc)))])]))
109 12687dd9 2023-08-04 jrmu ;count-descendants : parent -> number
110 12687dd9 2023-08-04 jrmu ;Given a-parent, compute the number of descendants.
111 12687dd9 2023-08-04 jrmu ;The parent himself is included,
112 12687dd9 2023-08-04 jrmu ;so only nonzero natural numbers should be returned.
114 12687dd9 2023-08-04 jrmu (define (count-descendants a-parent)
116 12687dd9 2023-08-04 jrmu (count-descendants-children (parent-children a-parent))))
118 12687dd9 2023-08-04 jrmu ;count-descendants-children : list-of-children -> number
119 12687dd9 2023-08-04 jrmu ;Given a-loc, determine the number of descendants
120 12687dd9 2023-08-04 jrmu ;of the children. The children are themselves included.
122 12687dd9 2023-08-04 jrmu (define (count-descendants-children a-loc)
124 12687dd9 2023-08-04 jrmu [(empty? a-loc) 0]
125 12687dd9 2023-08-04 jrmu [else (+ (count-descendants (first a-loc))
126 12687dd9 2023-08-04 jrmu (count-descendants-children (rest a-loc)))]))
128 12687dd9 2023-08-04 jrmu ;count-proper-descendants : parent -> number
129 12687dd9 2023-08-04 jrmu ;Given a-parent, determine the number
130 12687dd9 2023-08-04 jrmu ;of proper descendants. The parent himself
131 12687dd9 2023-08-04 jrmu ;is not included.
133 12687dd9 2023-08-04 jrmu (define (count-proper-descendants a-parent)
134 12687dd9 2023-08-04 jrmu (- (count-descendants a-parent)
137 12687dd9 2023-08-04 jrmu ;A list of symbols is either
138 12687dd9 2023-08-04 jrmu ;1. an empty list or
139 12687dd9 2023-08-04 jrmu ;2. (cons s los) where s is a symbol and los is a list-of-symbols.
141 12687dd9 2023-08-04 jrmu ;eye-colors : parent -> list-of-symbols
142 12687dd9 2023-08-04 jrmu ;Given a-parent, finds the eye colors of all
143 12687dd9 2023-08-04 jrmu ;the descendants and returns them as a
144 12687dd9 2023-08-04 jrmu ;list-of-symbols.
146 12687dd9 2023-08-04 jrmu (define (eye-colors a-parent)
147 12687dd9 2023-08-04 jrmu (append (list (parent-eyes a-parent))
148 12687dd9 2023-08-04 jrmu (eye-colors-children (parent-children a-parent))))
150 12687dd9 2023-08-04 jrmu ;eye-colors-children : list-of-children -> list-of-symbols
151 12687dd9 2023-08-04 jrmu ;Given a-loc, determine the eye colors
152 12687dd9 2023-08-04 jrmu ;of the list-of-children and their descendants and return
153 12687dd9 2023-08-04 jrmu ;them as a list-of-symbols.
155 12687dd9 2023-08-04 jrmu (define (eye-colors-children a-loc)
157 12687dd9 2023-08-04 jrmu [(empty? a-loc) empty]
158 12687dd9 2023-08-04 jrmu [else (append (eye-colors (first a-loc))
159 12687dd9 2023-08-04 jrmu (eye-colors-children (rest a-loc)))]))
