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 14.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 12687dd9 2023-08-04 jrmu ;A child structure is
5 12687dd9 2023-08-04 jrmu ;(make-child father mother name date eyes) where
7 12687dd9 2023-08-04 jrmu ;1. name and eyes are symbols,
8 12687dd9 2023-08-04 jrmu ;2. date is a number,
9 12687dd9 2023-08-04 jrmu ;3. and father and mother are either
10 12687dd9 2023-08-04 jrmu ;a. child structures or
13 12687dd9 2023-08-04 jrmu (define-struct child (father mother name date eyes))
15 12687dd9 2023-08-04 jrmu ;A family tree node (ftn) is either
16 12687dd9 2023-08-04 jrmu ;1. empty or
17 12687dd9 2023-08-04 jrmu ;2. (make-child father mother name date eyes) where
18 12687dd9 2023-08-04 jrmu ;a. father and mother are ftn,
19 12687dd9 2023-08-04 jrmu ;b. name and eyes are symbols,
20 12687dd9 2023-08-04 jrmu ;c. and date is a number.
23 12687dd9 2023-08-04 jrmu (define Carl (make-child empty empty 'Carl 1926 'green))
24 12687dd9 2023-08-04 jrmu (define Bettina (make-child empty empty 'Bettina 1926 'green))
25 12687dd9 2023-08-04 jrmu (define Adam (make-child Carl Bettina 'Adam 1950 'yellow))
26 12687dd9 2023-08-04 jrmu (define Dave (make-child Carl Bettina 'Dave 1955 'black))
27 12687dd9 2023-08-04 jrmu (define Eva (make-child Carl Bettina 'Eva 1965 'blue))
28 12687dd9 2023-08-04 jrmu (define Fred (make-child empty empty 'Fred 1966 'pink))
29 12687dd9 2023-08-04 jrmu (define Gustav (make-child Fred Eva 'Gustav 1988 'brown))
32 12687dd9 2023-08-04 jrmu ;fun-for-ftn : ftn -> ???
33 12687dd9 2023-08-04 jrmu ;(define (fun-for-ftn a-ftree)
35 12687dd9 2023-08-04 jrmu ; [(empty? a-ftree) ...]
37 12687dd9 2023-08-04 jrmu ; ... (fun-for-ftn (child-father a-ftree)) ...
38 12687dd9 2023-08-04 jrmu ; ... (fun-for-ftn (child-mother a-ftree)) ...
39 12687dd9 2023-08-04 jrmu ; ... (child-name a-ftree) ...
40 12687dd9 2023-08-04 jrmu ; ... (child-date a-ftree) ...
41 12687dd9 2023-08-04 jrmu ; ... (child-eyes a-ftree) ...]))
43 12687dd9 2023-08-04 jrmu ;blue-eyed-ancestor? : ftn -> boolean
44 12687dd9 2023-08-04 jrmu ;Given a-ftree, determine if there is
45 12687dd9 2023-08-04 jrmu ;a child in a-ftree with 'blue in eyes field.
46 12687dd9 2023-08-04 jrmu (define (blue-eyed-ancestor? a-ftree)
48 12687dd9 2023-08-04 jrmu [(empty? a-ftree) false]
51 12687dd9 2023-08-04 jrmu (symbol=? (child-eyes a-ftree) 'blue)
52 12687dd9 2023-08-04 jrmu (blue-eyed-ancestor? (child-father a-ftree))
53 12687dd9 2023-08-04 jrmu (blue-eyed-ancestor? (child-mother a-ftree)))]))
55 12687dd9 2023-08-04 jrmu ;count-persons : ftn -> number
56 12687dd9 2023-08-04 jrmu ;Given a-ftree, determines the number of people in the
57 12687dd9 2023-08-04 jrmu ;family tree.
60 12687dd9 2023-08-04 jrmu ;(count-persons Carl)
62 12687dd9 2023-08-04 jrmu ;(count-persons Dave)
65 12687dd9 2023-08-04 jrmu (define (count-persons a-ftree)
67 12687dd9 2023-08-04 jrmu [(empty? a-ftree) 0]
70 12687dd9 2023-08-04 jrmu (count-persons (child-father a-ftree))
71 12687dd9 2023-08-04 jrmu (count-persons (child-mother a-ftree)))]))
73 12687dd9 2023-08-04 jrmu ;average-age : ftn -> number
74 12687dd9 2023-08-04 jrmu ;Computes the average age of all the people
75 12687dd9 2023-08-04 jrmu ;in a family tree. Sums the ages
76 12687dd9 2023-08-04 jrmu ;and divides by the count of persons.
78 12687dd9 2023-08-04 jrmu (define (average-age a-ftree)
79 12687dd9 2023-08-04 jrmu (/ (sum-of-ages a-ftree)
80 12687dd9 2023-08-04 jrmu (count-persons a-ftree)))
82 12687dd9 2023-08-04 jrmu ;sum-of-ages : ftn -> number
83 12687dd9 2023-08-04 jrmu ;Computes the sum of the ages of
84 12687dd9 2023-08-04 jrmu ;the people in a family tree.
87 12687dd9 2023-08-04 jrmu ;(sum-of-ages Carl)
89 12687dd9 2023-08-04 jrmu ;(sum-of-ages Eva)
92 12687dd9 2023-08-04 jrmu (define CURRENTYEAR 2009)
94 12687dd9 2023-08-04 jrmu (define (sum-of-ages a-ftree)
96 12687dd9 2023-08-04 jrmu [(empty? a-ftree) 0]
98 12687dd9 2023-08-04 jrmu (+ (- CURRENTYEAR (child-date a-ftree))
99 12687dd9 2023-08-04 jrmu (sum-of-ages (child-father a-ftree))
100 12687dd9 2023-08-04 jrmu (sum-of-ages (child-mother a-ftree)))]))
102 12687dd9 2023-08-04 jrmu ;A list-of-eye-colors is either
103 12687dd9 2023-08-04 jrmu ;1. an empty list or
104 12687dd9 2023-08-04 jrmu ;2. (cons ec loec) where ec is a symbol and
105 12687dd9 2023-08-04 jrmu ;loec is a list-of-eye-colors.
106 12687dd9 2023-08-04 jrmu ;(alternatively written as (list ec1 ec2 ... empty)
107 12687dd9 2023-08-04 jrmu ;where each argument represents a symbol).
109 12687dd9 2023-08-04 jrmu ;eye-colors : ftn -> list-of-eye-colors
111 12687dd9 2023-08-04 jrmu (define (eye-colors a-ftree)
113 12687dd9 2023-08-04 jrmu [(empty? a-ftree) empty]
114 12687dd9 2023-08-04 jrmu [else (append
115 12687dd9 2023-08-04 jrmu (list (child-eyes a-ftree))
116 12687dd9 2023-08-04 jrmu (eye-colors (child-father a-ftree))
117 12687dd9 2023-08-04 jrmu (eye-colors (child-mother a-ftree)))]))
119 12687dd9 2023-08-04 jrmu ;proper-blue-eyed-ancestor? : ftn -> boolean
120 12687dd9 2023-08-04 jrmu ;Given a-ftree, determine if the person
121 12687dd9 2023-08-04 jrmu ;has a proper blue eyed ancestor
122 12687dd9 2023-08-04 jrmu ;(someone in the family tree with blue eyes
123 12687dd9 2023-08-04 jrmu ; who is not the person in question)
125 12687dd9 2023-08-04 jrmu (define (proper-blue-eyed-ancestor? a-ftree)
127 12687dd9 2023-08-04 jrmu [(empty? a-ftree) false]
128 12687dd9 2023-08-04 jrmu [else (or (blue-eyed-ancestor? (child-father a-ftree))
129 12687dd9 2023-08-04 jrmu (blue-eyed-ancestor? (child-mother a-ftree)))]))
