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-advanced-reader.ss" "lang")((modname |32.1|) (read-case-sensitive #t) (teachpacks ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #t #t none #f ((lib "draw.ss" "teachpack" "htdp") (lib "arrow.ss" "teachpack" "htdp") (lib "gui.ss" "teachpack" "htdp")))))
4 (define-struct child (father mother name date eyes))
5 
6 ;A ftn (family tree node) is either
7 ;1. empty or
8 ;2. (make-child f m na da ec) where f, m are ftns, na, ec are symbols, and da is a number.
9 ;
10 ;all-blue-eyed-ancestors : ftn -> (listof symbol)
11 ;Given aftree0, return a list of all blue-eyed-ancestors as a (listof symbols).
12 
13 (define (all-blue-eyed-ancestors aftree0)
14   (local
15     ;accumulator represents all the blue-eyed ancestors on the mother side of tree paths
16     ;from [aftree0,aftree1)
17     ((define (all-a aftree1 accumulator)
18        (cond
19          [(empty? aftree1) accumulator]
20          [else
21           (local
22             ((define in-parents
23                (all-a (child-father aftree1)
24                       (all-a (child-mother aftree1)
25                              accumulator))))
26             (cond
27               [(symbol=? 'blue (child-eyes aftree1))
28                (cons (child-name aftree1)
29                      in-parents)]
30               [else in-parents]))])))
31     (all-a aftree0 empty)))
32 
33 (define eight (make-child empty empty 'eight 1999 'blue))
34 (define nine (make-child empty empty 'nine 1999 'blue))
35 (define ten (make-child empty empty 'ten 1999 'blue))
36 (define eleven (make-child empty empty 'eleven 1999 'blue))
37 (define twelve  (make-child empty empty 'twelve 1999 'blue))
38 (define thirteen (make-child empty empty 'thirteen 1999 'blue))
39 (define fourteen (make-child empty empty 'fourteen 1999 'blue))
40 (define fifteen (make-child empty empty 'fifteen 1999 'blue))
41 (define four (make-child eight nine 'four 1999 'blue))
42 (define five (make-child ten eleven 'five 1999 'blue))
43 (define six (make-child twelve thirteen 'six 1999 'blue))
44 (define seven (make-child fourteen fifteen 'seven 1999 'blue))
45 (define two (make-child four five 'two 1999 'blue))
46 (define three (make-child six seven 'three 1999 'blue))
47 (define one (make-child two three 'one 1999 'blue))
48 
49 (all-blue-eyed-ancestors one)
50 
51 #|
52 (define Carl (make-child empty empty 'Carl 1926 'green))
53 (define Bettina (make-child empty empty 'Bettina 1926 'green))
54 (define Adam (make-child Carl Bettina 'Adam 1950 'yellow))
55 (define Dave (make-child Carl Bettina 'Dave 1955 'black))
56 (define Eva (make-child Carl Bettina 'Eva 1965 'blue))
57 (define Fred (make-child empty empty 'Fred 1966 'pink))
58 (define Gustav (make-child Fred Eva 'Gustav 1988 'brown))
59 |#
60 
61 ;all-blue-eyed-ancestors2 : ftn -> (listof symbols)
62 
63 (define (all-blue-eyed-ancestors2 aftree0)
64   (local ;the accumulator todo represents a list of nodes we have yet to process
65     ;counting from [aftree0,aftree1)
66     ((define (all-a aftree1 todo)
67        (cond
68          [(empty? aftree1)
69           (cond
70             [(empty? todo) empty]
71             [else (all-a (first todo) (rest todo))])]
72          [else (local
73                  ((define in-parents
74                     (all-a (child-father aftree1) (cons (child-mother aftree1) todo))))
75                  (cond
76                    [(symbol=? (child-eyes aftree1) 'blue)
77                     (cons (child-name aftree1) in-parents)]
78                    [else in-parents]))]))) 
79     (all-a aftree0 empty)))
80 
81 (all-blue-eyed-ancestors2 one)