《how to design programs》14章 再论自引用数据

这是一个家族谱：

;child
(define-struct child (father mother name date eyes))

#lang racket

;child
(define-struct child (father mother name date eyes))

;; Oldest Generation:
(define Carl (make-child empty empty 'Carl 1926 'green))
(define Bettina (make-child empty empty 'Bettina 1926 'green))

;; Middle Generation:
(define Adam (make-child Carl Bettina 'Adam 1950 'yellow))
(define Dave (make-child Carl Bettina 'Dave 1955 'black))
(define Eva (make-child Carl Bettina 'Eva 1965 'blue))
(define Fred (make-child empty empty 'Fred 1966 'pink))

;; Youngest Generation:
(define Gustav (make-child Fred Eva 'Gustav 1988 'brown))

;判断a-ftree是否包含一个child结构体，其eyes为blue
(define (blue-eyed-ancestor? a-ftree)
  (cond
    [(empty? a-ftree) false]
    [else (cond
            [(symbol=? (child-eyes a-ftree) 'blue) true]
            [(blue-eyed-ancestor? (child-father a-ftree) ) true]
            [(blue-eyed-ancestor? (child-mother a-ftree)) true]
            [else false]
            )
          ]))
(blue-eyed-ancestor? Gustav)

;求家谱树种人数
(define (count-persons a-ftree)
  (cond
    [(empty? a-ftree) ]
    [else
     (+
      (+ (count-persons (child-father a-ftree)) (count-persons (child-mother a-ftree)))
      )]))
(count-persons Carl)
(count-persons Adam)

x题目：

读入一个家谱树节点和当前年份，返回所有人的平均年龄：

(define (sum-of-ages a-ftree current-year)
    (cond
      [(empty? a-ftree) ]
      [else (+ (- current-year (child-date a-ftree) )
               (+
                (sum-of-ages (child-father a-ftree) current-year)
                 (sum-of-ages (child-mother a-ftree) current-year)
                 )
               )])

  )

(define (average-age a-ftree current-year)
  (/ (sum-of-ages a-ftree current-year)
     (count-persons a-ftree)))

题目：

Exercise 14.1.5.   Develop the function eye-colors, which consumes a family tree node and produces a list of all eye colors in the tree. An eye color may occur more than once in the list.

Hint: Use the Scheme operation append, which consumes two lists and produces the concatenation of the two lists. For example:

  (append (list 'a 'b 'c) (list 'd 'e))
= (list 'a 'b 'c 'd 'e)

We discuss the development of functions like append in section 17.    Solution

(define (eye-colors a-ftree)
  (cond
    [(empty? a-ftree) empty]
    [else
      (cons
        (child-eyes a-ftree)
        (append (eye-colors (child-father a-ftree))
       (eye-colors (child-mother a-ftree))
       ))]
    ))

二叉树：

binary tree Bt是这样2者之一：

1.false

2.（make-node soc pn lft rgt) 其中soc是数，pn是符号，lft和rgt是BT。

这里选用false来表示缺乏信息，这一点是任意的，事实上，恩也可以选用empty，不过，我们更熟悉false，而且比起其他东西，他更好用。

函数bt-contains? 读入一个数和一颗树，判断这个数是否在树中出现：

14.1. | Problem Statement | Table of Contents | 14.2.
;; Language: Beginning Student

;       'Bobby
;         \
;          \
;          'Luke

;       'Bobby
;        /
;       /
;     'Luke

;       'Bobby
;        /     \
;       /       \
;     'Luke    5  'Paul

#|
A BT is either
  . false; or
  . (make-node soc pn lft rgt)
     where soc is a number, pn is a symbol, and lft and rgt are BTs.
|#
(define-struct node (ssn name left right))

(define bt1 (make-node  'Bobby false (make-node 12 'Luke false false)))
(define bt2 (make-node  'Bobby (make-node 12 'Luke false false) false))
(define bt3 (make-node  'Bobby (make-node 12 'Luke false false) (make-node  'Paul false false))) 

;; bt-contains?: number BT -> boolean
;; consumes a number and binary-tree and determines if a-bt contains n
(define (bt-contains? n a-bt)
  (cond
    [(boolean? a-bt) false]
    [else
     (or (= n (node-ssn a-bt))
         (bt-contains? n (node-left a-bt))
         (bt-contains? n (node-right a-bt)))]))

(equal? (bt-contains?  bt1) true)
(equal? (bt-contains?  bt3) true)
(equal? (bt-contains?  bt3) false)
(equal? (bt-contains?  bt2) true)
(equal? (bt-contains?  bt2) false)
(equal? (bt-contains?  bt3) true)

开发函数search-bt,读入一个数n和BT，如果这棵树包含一个node结构体，其soc字段为n，函数就返回这个节点的pn字段的值，否则，函数返回false：

;; search-bt : number binary-tree -> false or
;; returns true if a-n is in a-bt, and false if not.
(define (search-bt a-n a-bt)
  (cond
    [(boolean? a-bt) #f]
    [else
     (cond
       [(= (node-ssn a-bt) a-n)
        (node-name a-bt)]
       [(boolean? (search-bt a-n (node-left a-bt)))
        (search-bt a-n (node-right a-bt))]
       [else
        (search-bt a-n (node-left a-bt))])]))

这里我们用boolean？检查search-bt是否成功作用于某一科子树。（回溯思想）。

二叉搜索树：BST

A binary-search-tree (short: BST) is a BT:

1. false is always a BST;

2. (make-node soc pn lft rgt) is a BST if

   1. lft and rgt are BSTs,

   2. all ssn numbers in lft are smaller than soc, and

   3. all ssn numbers in rgt are larger than soc.

The second and third conditions are different from what we have seen in previous data definitions. They place an additional and unusual burden on the construction BSTs. We must inspect all numbers in these trees and ensure that they are smaller (or larger) than soc.

二叉树中序变量：

;; DEFINITION:
(define (inorder abt)
  (cond
    ((boolean? abt) empty)
    ((node? abt)
     (append (inorder (node-left abt))
             (cons (node-name abt)
               (inorder (node-right abt)))))))

二叉搜索树搜索：

;; search-bst : number binary-tree -> false or
;; returns true if a-n is in a-bt, and false if not.
(define (search-bt a-n a-bt)
  (cond
    [(boolean? a-bt) #f]
    [else
     (cond
       [(= (node-ssn a-bt) a-n)
        (node-name a-bt)]
       [(< (node-ssn a-bt) a-n)
        (search-bt a-n (node-right a-bt))]
       [(> (node-ssn a-bt) a-n)
        (search-bt a-n (node-left a-bt))])]))

插入；

14.2. | Problem Statement | Table of Contents | 14.2.
; DATA DEFINITIONS
(define-struct node (ssn name left right))
; A binary tree is either
;   . false or
;   . (make-node soc pn lft rgt)
;         where soc is a number, pn is a symbol, and lft and rgt are binary
;         trees. 

;; EXAMPLES
; (create-bst false  'b) => (make-node 6 'b false false)
;
; (create-bst (make-node  'a false false) 5 'a)
; =>
; (make-bst  'a false (make-bst 5 'a false false))
;
; (create-bst (make-node  'a false false) 3 'g)
; =>
; (make-node  'a (make-node 3 'g false false) false)
;
; (create-bst (make-node  'a (make-node 2 'a false false) false)  'g)
; =>
; (make-node  'a (make-node 2 'a false (make-node  'g)))

;; TEMPLATE:
;(define (bst-fun abt)
;  (cond
;    ((boolean? abt) ...)
;    ((node? abt)
;     ... (node-ssn abt) ... (node-name abt) ...
;     ... (bst-fun (node-left abt)) ... (bst-fun (node-right abt)) ... )))

;; CONTRACT/HEADER/PURPOSE:
;; create-bst : binary-tree number symbol -> binary-tree
;; to create a binary search tree with the same values as the input tree
;; and also the given number associated with the given name
(define (create-bst bst n s)
  (cond
    [(eq? bst false) (make-node n s false false)]
    [else
     (cond
       [(< n (node-ssn bst))
        (make-node (node-ssn bst)
                   (node-name bst)
                   (create-bst (node-left bst) n s)
                   (node-right bst))]
       [(> n (node-ssn bst))
        (make-node (node-ssn bst)
                   (node-name bst)
                   (node-left bst)
                   (create-bst (node-right bst) n s))]
       [else (error 'create-bst "Number already in BST")])]))

(equal? (create-bst false  'b)  (make-node 6 'b false false))
(equal? (create-bst (make-node  'a false false) 5 'a)
        (make-node  'a false (make-node 5 'a false false)))
(equal? (create-bst (make-node  'a false false) 3 'g)
        (make-node  'a (make-node 3 'g false false) false))
(equal? (create-bst (make-node  'a (make-node 2 'a false false) false)  'g)
        (make-node  'a (make-node 2 'a false (make-node  'g false false)) false))

感觉这个程序有点奇怪， 但仔细相同时合理的。没有多余的创建node。

开发函数，读入一个由数和名字组成的表，反复调用create-bst，返回一个bst。

; create-bst-from-list : list-of-numbers-and-symbols -> binary-tree
; to produce a binary tree with all the numbers in the input list
; associated with their corresponding symbols
(define (create-bst-from-list lons)
  (cond·
    [(empty? lons) false]
    [else
     (create-bst
      (create-bst-from-list (rest lons))
      (first (first lons))
      (second (first lons)))]))

(equal?
 (create-bst-from-list '((1 a) (18 b) (2 g)))
 (make-node 2 'g (make-node 1 'a false false) (make-node 18 'b false false)))
为true。

表中的表:

A Web-page (short: WP) is either

1. empty;

2. (cons s wp) 
   where s is a symbol and wp is a Web page; or

3. (cons ewp wp) 
   where both ewp and wp are Web pages.

This data definition differs from that of a list of symbols in that it has three clauses instead of two and that it has three self-references instead of one. Of these self-references, the one at the beginning of a constructed list is the most unusual. We refer to such Web pages as immediately embedded Web pages.

开发函数size，读入一个网页，返回其自身以及所有嵌入网页所包含的单词数。

Let's develop the function size, which consumes a Web page and produces the number of words that it and all of its embedded pages contain:

;; size : WP  ->  number
;; to count the number of symbols that occur in a-wp
(define (size a-wp) ...)

The two Web pages above suggest two good examples, but they are too complex. Here are three examples, one per subclass of data:

(= (size empty)
   0)

(= (size (cons 'One empty))
   1)

(= (size (cons (cons 'One empty) empty))
   1)

开开发size函数，我们可以按照设计诀窍，数据定义说明我们需要3个cond子句，一个子句处理empty页，一个子句处理由符号开始的页，另一个子句处理由嵌入的网页开始的页。虽然第一个测试empty的条件我们已经很熟悉了，但是第2个和第3个条件需要我们进一步检查，因为在数据定于中，这2个子句都使用了cons，所以简单地使用cons？并不能区分这2种数据形式。

如果网页不是empty，那么他必然是cons结构，后两种数据形式之间的特征是表中的第一个元素，换句话说，第二个条件必须使用一个测试a-wp的第一个元素的谓词：

;求网页单词数
(define  (size a-wp)
  (cond
    [(empty? a-wp) ]
    [(symbol? (first a-wp)) (+  (size (rest a-wp)))]
    [else (+ (size (first a-wp)) (size (rest a-wp)))]
    )
  )
(size  '(a b c))

注意使用

(size '(1 2 3)) 报错：

first: contract violation
expected: (and/c list? (not/c empty?))
given: 1

为什么会报错？

(first (cons 1 2))
. . first: contract violation
expected: (and/c list? (not/c empty?))
given: '(1 . 2)

(first (list 1 2)

正确输出1.

(first lst) The same as (car lst), but only for lists (that are not empty).

求网页深度：

只包含符号的深度为0，包含某个直接嵌入页的深度加1.

;; Language: Intermediate Student

;; depth: web-page -> number
;; computes the depth of embedded web-pages
(define (depth a-wp)
  (cond
   [(empty? a-wp) ]
   [(symbol? (first a-wp))
    (depth (rest a-wp))]
   [else    #cons wp wp
    (max (+ (depth (first a-wp)) )
         (depth (rest a-wp)))]))

;;; tests
(check-expect (depth '()) 0)
(check-expect (depth '(a)) 0)
(check-expect (depth '(())) 1)
(check-expect (depth '(a b c)) 0)
(check-expect (depth '(a (b (c (d))) e (f (g)) h))
              )

对这个有点不解：

 (max (+ (depth (first a-wp)) 1)
         (depth (rest a-wp)))]))

这么理解，list的后面一定为empty。

如果是(list 'a 'b)；
运行2次symbol，结果为0.
如果是'( a (b c))
结果为1。
（list '( (a) ((b)) )
(+ (depth (a) 1) or (depth ((b)) )
  第1个为1，第2个为2.
所以深度为2.

开发函数occurs1，读入一个网页和一个开始符号，返回该符号在网页出现的次数，忽略嵌入的网页：

;; occurs1 : WP symbol -> number
;; produces number of times given symbol occurs
;; in the Web page, ignoring nested WPs
(define (occurs1 a-wp s)
  (cond
    [ (empty? a-wp) ]
    [ (and (symbol? (first a-wp))
           (symbol=? (first a-wp) s))
      (+  (occurs1 (rest a-wp) s))]
    [ else (occurs1 (rest a-wp) s)]))
;; tests
(=  (occurs1 '(The TeachScheme Web Page
                    Here you can find:
                    (LectureNotes for Teachers)
                    (Guidance for (DrScheme: a Scheme programming environment))
                    (Exercise Sets)
                    (Solutions for Exercises)
                    For further information: write to scheme@cs)
              'Exercise))
(=  (occurs1 '(The TeachScheme Web Page
                    Here you can find:
                    (LectureNotes for Teachers)
                    (Guidance for (DrScheme: a Scheme programming environment))
                    (Exercise Sets)
                    (Solutions for Exercises)
                    For further information: you can write to scheme@cs)
              'can))

开发函数occurs2.计算所有出现次数，包括嵌入的网页：

最开始的写法，错误：

(define (occurs2  a-wp s)
  (cond
    [(empty? a-wp) ]
    [(and (symbol? (first a-wp))
          (symbol=? (first a-wp) s)
          )
     (+  (occurs2 (rest a-wp) s))
     ]
    [else
      (+ (occurs2 (first a-wp) s)
         (occurs2 (rest a-wp) s))
      ]
    )
  )

正确代码：

(define (occurs2 a-wp s)
  (cond
    [ (empty? a-wp) ]
    [ (symbol? (first a-wp)) (cond
                               [ (symbol=? (first a-wp) s)
                                 (+  (occurs2 (rest a-wp) s))]
                               [ else (occurs2 (rest a-wp) s)])]
    [ else (+ (occurs2 (first a-wp) s)
              (occurs2 (rest a-wp) s))]))
;; tests

错误的代码错在哪里， 没有处理所有的情况。

开发函数replace，读入符号new和old，以及网页a-wp,返回一个网页，其中所有old出现都被替换为new：

;; replace : symbol symbol WP -> WP
;; replaces all occurences of old with new
(define (replace old new a-wp)
  (cond
    [ (empty? a-wp) empty]
    [ (symbol? (first a-wp))
      (cond
        [ (symbol=? (first a-wp) old)
          (cons new
                (replace old new (rest a-wp)))]
        [else (cons (first a-wp)
                    (replace old new (rest a-wp)))])]
    [ else (cons (replace old new (first a-wp))
                 (replace old new (rest a-wp)))]))

Exercise 15.3.4.   Develop the program find. The function consumes a Web page and a symbol. It produces false, if the symbol does not occur in the body of the page or its embedded Web pages. If the symbol occurs at least once, it produces a list of the headers that are encountered on the way to the symbol.

Hint: Define an auxiliary like find that produces only true when a Web page contains the desired word. Use it to define find. Alternatively, useboolean? to determine whether a natural recursion of find produced a list or a boolean. Then compute the result again. We will discuss this second technique, called backtracking, in the intermezzo at the end of this part.    Solution

;; Data Definitions

(define-struct wp (header body))
;; A Web-page (short: WP) is a structure:
;;   (make-wp h p)
;; where h is a symbol and p is a (Web) document.

;; A (Web) document is either:
;; . empty
;; . (cons s p)  where s is a symbol and p is a (Web) document
;; . (cons wp p)  where wp is a web-page and p is a document

;; A list-of-symbols is either:
;; . empty
;; . (cons symbol list-of-symbols)

;; A los-or-false is either:
;; . false
;; . list-of-symbols

;; find : wp symbol -> los-or-false
(define (find a-wp a-word)
  (append-or-false (list (wp-header a-wp))
                   (find-in-document (wp-body a-wp) a-word)))

;; find-in-body : document symbol -> los-or-false
(define (find-in-document a-page a-word)
  (cond
    [(empty? a-page) false]
    [(symbol? (first a-page)) (cond
                                [(symbol=? (first a-page) a-word) empty]
                                [else (find-in-document (rest a-page) a-word)])]
    [else (local ((define in-subpage (find (first a-page) a-word)))
            (cond
              [(boolean? in-subpage) (find-in-document (rest a-page) a-word)]
              [else in-subpage]))]))

;; append-or-false : list-of-symbols los-or-false -> los-or-false
;; appends y to x if y is not false
(define (append-or-false x y)
  (cond
    [(boolean? y) y]
    [else (append x y)]))

;; --- test code

;; data examples:
(define empty-page (make-wp 'empty-page empty))
(define page--word (make-wp 'page-1-word (cons 'w1 empty)))
(define page--words (make-wp 'page-2-words (list 'w1 'w2)))
(define with--word-subpage (make-wp 'page-1-word-with-subpage (cons page-1-word empty)))
(define with--words-subpage (make-wp 'with-2-words-subpage (cons page-2-words empty)))
(define dense-page1 (make-wp 'realistic (list 'w3  page--words 'w4 page-1-word 'w5)))
(define dense-page2 (make-wp 'realistic (list 'w3  empty-page 'w4 with-1-word-subpage 'w5)))

;; test cases

; test for 'append-or-false'
(check-expect (append-or-false empty false) false)
(check-expect (append-or-false empty empty) empty)
(check-expect (append-or-false (list 'a) false) false)
(check-expect (append-or-false (list 'a) empty) (list 'a))
(check-expect (append-or-false (list 'a) (list 'b)) (list 'a 'b))

;; test for 'find'
(check-expect (find empty-page 'w1) false)
(check-expect (find page--word 'w1) (list 'page--word))
(check-expect (find page--words 'w3) false)
(check-expect (find with--words-subpage 'w2) (list 'with--words-subpage 'page-2-words))
(check-expect (find dense-page1 'no-in-there) false)
(check-expect (find dense-page1 'w1) (list 'realistic 'page-2-words))
(check-expect (find dense-page1 'w2) (list 'realistic 'page-2-words))
(check-expect (find dense-page2 'w1) (list 'realistic 'page-1-word-with-subpage 'page--word))
(check-expect (find dense-page1 'w5) (list 'realistic))

(generate-report)
;; --- end test code

scheme求值：

(define-struct add (left right))

(define-struct mul(left right))

开发函数，读入一个scheme，判断他是不是数值的，（也就是不包含变量）。

;; numeric? : s-exp -> boolean
;; determines if a representation of a scheme expression
;; is numeric
(define (numeric? a-sexp)
  (cond
    [ (number? a-sexp) true]
    [ (symbol? a-sexp) false]
    [ (add? a-sexp) (and (numeric? (add-left a-sexp))
                         (numeric? (add-right a-sexp)))]
    [ (mul? a-sexp) (and (numeric? (mul-left a-sexp))
                         (numeric? (mul-right a-sexp)))]))
;; tests:
(boolean=? (numeric? (make-add (make-mul  'x) 4)) false)
(boolean=? (numeric? (make-add (make-mul  ) )) true)

计算表达式，（遇到变量，返回一个错误）

;; evaluate-expression : s-exp -> number
;; computes value of a scheme expression
(define (evaluate-expression a-sexp)
  (cond
    [ (number? a-sexp) a-sexp]
    [ (symbol? a-sexp) (error 'evaluate-expression "undefined variable")]
    [ (add? a-sexp) (+ (evaluate-expression (add-left a-sexp))
                       (evaluate-expression (add-right a-sexp)))]
    [ (mul? a-sexp) (* (evaluate-expression (mul-left a-sexp))
                       (evaluate-expression (mul-right a-sexp)))]))
;; tests
(= (evaluate-expression (make-add (make-mul  ) )) )
(evaluate-expression (make-add (make-mul  'x) 4)) ;; should throw error

计算表达式，开发一个函数subst,读入变量（的表示法V，数N以及一个scheme表达式(的表示法），他返回一个结构相等的表达式，把其中所有的V都替换为N。

;; subst : symbol number s-exp -> number
;; computes value of a scheme expression
(define (subst v n a-sexp)
  (cond
    [ (number? a-sexp) a-sexp]
    [ (symbol? a-sexp) (cond
                         [ (symbol=? a-sexp v) n]
                         [ else (error 'subst
                                       "undefined variable")])]
    [ (add? a-sexp) (+ (subst v n (add-left a-sexp))
                       (subst v n (add-right a-sexp)))]
    [ (mul? a-sexp) (* (subst v n (mul-left a-sexp))
                       (subst v n (mul-right a-sexp)))]))
;; test
(=  (subst 'x 4 (make-add (make-mul 2 'x) )))
(=  (subst 'y 4 (make-add (make-mul 2 'x) ))) ;; should throw error

比上面的多了个判断symbol是否等于给定的，如果等于就返回新的n。