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