先看一下loop都做了什么，它把第一个列的开头部分和第二个列重新组合，然后对第一列余下的部分和新组合得的列再次应用loop。

不难看出mystery实际上返回的是一个列的逆序列，但该过程的side effect值得注意，它把原先的x的“尾巴”全部截掉了！

done

一开始的版本实际上被我写成

(define (f num)
  (let ((s 1))
    (if (= s 1)
        (begin (set! s 0) num)
        0)))
 这样的话f永远都是把给她的参数原样反回

;the idea behind the procedure is straightforward
;it only passes argument once, after that it returns zero no matter what
(define f
  (let ((s 1))
    (lambda (num)
    (if (= s 1)
        (begin (set! s 0) num)
        0))))
   

;不难看出make-joint需要做的是在客户账户中添加一条额外的密钥并返回该账户
;由于帐户这个对象在系统中是以过程形式定义的，不调用过程无法修改其本地参数
;有必要在make-account中添加额外的命令来收集新密钥

(define (make-account balance password);初始化时以list形式输入password
  (define (withdraw amount)
    (if (>= balance amount)
        (begin (set! balance (- balance amount))
               balance)
        "Insufficient funds"))
  (define (deposit amount)
    (set! balance (+ balance amount))
    balance)
  (define (in? p password1)
          (cond ((null? password1) #f)
                ((eq? p (car password1)) #t)
                (else (in? p (cdr password1)))))
  (define (addpassword password1)
          (set! password (cons password1 password)))
                
  (define (dispatch p m)
    (if (in? p password);测试p是否在password列表中
        (cond ((eq? m 'withdraw) withdraw)
              ((eq? m 'deposit) deposit)
              ((eq? m 'addpassword) addpassword)
              (else (error "Unknown request -- MAKE-ACCOUNT"
                           m)))
        (error "Incorrect password" m))
    )

  dispatch)
(define (make-joint account oldpassword newpassword)
  (begin ((account oldpassword 'addpassword) newpassword) account))

 

(define (make-monitored func)
  (let ((init 0))     
    (lambda (x)
      (cond ((eq? x 'how-many-calls?) init)
            ((eq? x 'reset-count) (set! init 0))
            (else (set! init (+ 1 init)) (func x))))))

因为各个部门编制的员工文件有不同的数据结构，对数据的具体操作需要与其所在的部门文件相适应，可以使用(list 'division file)的方式给不同部门的文件打上标签，再使用data-directed方法构造通用函数，即使其后有新部门加入只需在type-operation表中添加相应procedure就可以了.

(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? object)
  (eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))

(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))
(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))
(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))
(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

;********************************************* my work begin from here

(define (generate-huffman-tree pairs)
  (successive-merge (make-leaf-set pairs)))

(define (successive-merge treeset);the treeset here must be in ascending order
  (if (null? (cddr treeset));test if treeset has only two elements
      (make-code-tree (car treeset) (cadr treeset))
      (successive-merge (merge-then-arrange treeset))))

(define (merge-then-arrange treeset)
  (addjoin-ascending (make-code-tree (car treeset) (cadr treeset)) (cddr treeset)))

(define (addjoin-ascending tree treeset)
  (cond ((null? treeset) (list tree))
        ((> (weight tree) (weight (car treeset)))
         (cons (car treeset) (addjoin-ascending tree (cdr treeset))))
        (else (cons tree treeset))))

(define (make-leaf-set pairs)
  (if (null? pairs)
      '()
      (let ((pair (car pairs)))
        (addjoin-ascending (make-leaf (car pair)    ; symbol
                               (cadr pair))  ; frequency
                           (make-leaf-set (cdr pairs))))))

;********************************************* for testing
(define sample-pairs '((A 4) (B 2) (C 2) (D 1)))
(generate-huffman-tree sample-pairs)

;my work is between the two asterisk lines
(define (make-leaf symbol weight)
  (list 'leaf symbol weight))
(define (leaf? object)
  (eq? (car object) 'leaf))
(define (symbol-leaf x) (cadr x))
(define (weight-leaf x) (caddr x))

(define (make-code-tree left right)
  (list left
        right
        (append (symbols left) (symbols right))
        (+ (weight left) (weight right))))

(define (left-branch tree) (car tree))
(define (right-branch tree) (cadr tree))

(define (symbols tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))
(define (weight tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

(define (decode bits tree)
  (define (decode-1 bits current-branch)
    (if (null? bits)
        '()
        (let ((next-branch
               (choose-branch (car bits) current-branch)))
          (if (leaf? next-branch)
              (cons (symbol-leaf next-branch)
                    (decode-1 (cdr bits) tree))
              (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))
(define (choose-branch bit branch)
  (cond ((= bit 0) (left-branch branch))
        ((= bit 1) (right-branch branch))
        (else (error "bad bit -- CHOOSE-BRANCH" bit))))
;*********************
(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))

(define (encode message tree)
  (if (null? message)
      '()
      (append (encode-symbol (car message) tree)
              (encode (cdr message) tree))))

(define (encode-symbol symbol tree);it would be better to apply some tree checking method here
  (encode-symbol1 symbol '() (left-branch tree) (right-branch tree)))
 

(define (encode-symbol1 symbol result left-b right-b)
  (cond ((element-of-set? symbol (symbols left-b))
         (if (leaf? left-b)
             (append result '(0))
             (encode-symbol1 symbol (append result '(0)) (left-branch left-b) (right-branch left-b))))
        ((element-of-set? symbol (symbols right-b))
         (if (leaf? right-b)
             (append result '(1))
             (encode-symbol1 symbol (append result '(1)) (left-branch right-b) (right-branch right-b))))
        (else (error "encounter symbol could not be encoded with current dictionary:" symbol))))

 

;*********************
(define sample-tree
  (make-code-tree (make-leaf 'A 4)
                  (make-code-tree
                   (make-leaf 'B 2)
                   (make-code-tree (make-leaf 'D 1)
                                   (make-leaf 'C 1)))))

(define sample-message '(0 1 1 0 0 1 0 1 0 1 1 1 0))
(define sample-symbols (decode sample-message sample-tree))
(encode sample-symbols sample-tree);test if my procedure could encode message right
(encode '(A B S) sample-tree);test the error reporting func.

是想要告诉大家虽然平衡二叉树的索引效率较高，做集合运算还是将先其转换为序列比较有效率？应该是这样吧。

以递归的方法将一序列转换成平衡二叉树的方法简要来说就是

1.找出序列中间的元素n0

2.将原序列以n0为分割，分割成不含n0的前方序列t1和后方t2

3.以n0为node，将序列t1和t2转换后的平衡二叉树分别作为其左右分支，从而构建出更大的平衡二叉树

具体实现方法可以有细微的区别，书中给出的partial-tree定义简洁优雅，相当强!

 

由于转换过程实际上遍例序列中所有元素一次，其步骤复杂度为theta(n),n为序列元素个数

(define (union-set set1 set2)
  (if (null? set2)
      set1
      (union-set-good set1 set2 set2)))
(define (union-set-good set1 result set2base)
  (if (null? set1)
      result
      (if (element-of-set? (car set1) set2base)
          (union-set-good (cdr set1) result set2base)
          (union-set-good (cdr set1) (cons (car set1) result) set2base))))

    
(define (element-of-set? x set)
  (cond ((null? set) #f)
        ((equal? x (car set)) #t)
        (else (element-of-set? x (cdr set)))))

;只改进加法部分，乘法类似

(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        ((eq? (car a2) '+) (cons '+ (cons a1 (cdr a2))));though not necessary, I try to reduce the result to a simpler form
        (else (list '+ a1 a2))))
(define (=number? exp num)
  (and (number? exp) (= exp num)))

(define (augend s)
  (if (pair? (cdddr s));check if s havs more than 2 terms
      (cons '+ (cddr s))
      (caddr s)))

 

 

(define (deriv exp var)
  (cond ((number? exp) 0)
        ((variable? exp)
         (if (same-variable? exp var) 1 0))
        ((sum? exp)
         (make-sum (deriv (addend exp) var)
                   (deriv (augend exp) var)))
        ((product? exp)         
         (make-sum
           (make-product (multiplier exp)
                         (deriv (multiplicand exp) var))
           (make-product (deriv (multiplier exp) var)
                         (multiplicand exp))))
        ((exponentiation? exp) ;what we derive here should be limited to certain combination
         (make-product
         (make-product (exponent exp)
                       (make-exponent  (base exp)  (- (exponent exp) 1)))
         (deriv (base exp) var)
         ))
        
        (else
         (error "unknown expression type -- DERIV" exp))))

;data abstraction layer
(define (variable? x) (symbol? x))

(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (make-sum a1 a2) (list '+ a1 a2))

(define (make-product m1 m2) (list '* m1 m2))

(define (sum? x)
  (and (pair? x) (eq? (car x) '+)))

(define (addend s) (cadr s))

(define (augend s) (caddr s))

(define (product? x)
  (and (pair? x) (eq? (car x) '*)))

(define (multiplier p) (cadr p))

(define (multiplicand p) (caddr p))

;my definition start here
(define (exponentiation? x)
  (and (pair? x) (eq? (car x) '**)))

(define (make-exponent b e)
  (list '** b e))

(define (base e)
  (cadr e))

(define (exponent e)
  (caddr e))