《SICP》习题第2章

本人做的SICP习题第2章,如有错误请指正,用的解释器是Racket

 

练习2.1

;; Exercise 2.1
;; 有理数
#lang racket

;; 有理数定义
(define (numer x) (car x))
(define (demon x) (cdr x))
;; 处理分子分母均为正的有理数
(define (make-positive-rat n d)
  (let ((g (gcd n d)))
    (cons (/ n g) (/ d g))))
;; 处理正负有理数
(define (make-rat n d)
  (define positive-rat (make-positive-rat (abs n) (abs d)))
  (if (< (* n d) 0)
      (cons (- (numer positive-rat)) (demon positive-rat))
      positive-rat))

 

练习2.2

point相关的代码

;; Exercise 2.2
;; point
#lang racket
(provide (all-defined-out))

;; selector
(define (x-point x) (car x))
(define (y-point x) (cdr x))

;; make
(define (make-point x y) (cons x y))

;; print
(define (print-point p)
  (newline)
  (display "(")
  (display (x-point p))
  (display ",")
  (display (y-point p))
  (display ")"))

segment相关

;; Exercise 2.2
;; segment
#lang racket
(require "point.rkt")
(provide (all-defined-out))

;; selector
(define (start-segment x) (car x))
(define (end-segment x) (cdr x))

;; make
(define (make-segment start end)
  (cons start end))

;; 平均数
(define (avg x y)
  (/ (+ x y) 2.0))

;; 求中点
(define (midpoint-segment s)
  (make-point (avg (x-point (start-segment s)) (x-point (end-segment s))) (avg (y-point(start-segment s)) (y-point (end-segment s)))))

 

练习2.3

看起来题目是想让我们用多种不同的底层方法实现矩形,然后计算周长和面积的函数不论底层实现怎么样都可以用

先写周长和面积函数

;; Exercise 2.3
;; 矩形的相关计算
#lang racket
(require "rectangle-by-segment.rkt")
(provide (all-defined-out))

;; 计算周长
(define (perimeter rectangle)
  (* 2 (+ (width rectangle) (height rectangle))))

;; 计算面积
(define (area rectangle)
  (* (width rectangle) (height rectangle))) 

第一种实现方法,用两根线定义矩形,为了方便计算长宽,修改练习2.2中的segment,增加一个函数计算线段的长度

;; 求线段长度
(define (length s)
  (sqrt (+ (square (- (x-point (start-segment s)) (x-point (end-segment s))))
           (square (- (y-point (start-segment s)) (y-point (end-segment s)))))))

现在实现矩形

;; Exercise 2.3
;; 通过宽和高定义矩形
#lang racket
(provide (all-defined-out))
(require "segment.rkt")

;; make
(define (make-rectangle s1 s2) (cons s1 s2))

;; selector
(define (width r)
  (length (car r)))
(define (height r)
  (length (cdr r)))

第二种方法,用四个点实现矩形,其实三个点就可以定义一个矩形,为了方便还规定了四个点必须按顺时针顺序输入(不然还要判断哪两个点在对角线上,麻烦)

;; Exercise 2.3
;; 通过4个点定义矩形
#lang racket
(require "point.rkt")
(require "segment.rkt")
(provide (all-defined-out))

;; make
(define (make-rectangle p1 p2 p3 p4)
  (cons (cons p1 p2) (cons p3 p4)))

;; selector
(define (width r)
  (length (make-segment (car (car r)) (cdr (car r)))))
(define (height r)
  (length (make-segment (cdr (car r)) (cdr (cdr r)))))

最后来写一个测试方法,测试两种矩形实现方式

;; Exercise 2.3
;; 矩形测试
#lang racket
(require "point.rkt")
(require "segment.rkt")
(require "rectangle-calculate.rkt")
;; 可以替换矩形底层实现
(require "rectangle-by-point.rkt")
;; (require "rectangle-by-segment.rkt")

;; 定义四个点
(define p1 (make-point 3 4))
(define p2 (make-point 5 6))
(define p3 (make-point 7 4))
(define p4 (make-point 5 2))

;; 定义两条边
(define s1 (make-segment p1 p2))
(define s2 (make-segment p2 p3))

;; 定义矩形
(define r (make-rectangle p1 p2 p3 p4))
;; (define r (make-rectangle s1 s2))

;; 计算周长和面积
(perimeter r)
(area r)

 

练习2.4

;; Exercise 2.4
;; cons的另一种定义方法
#lang racket

;; cons
(define (cons x y)
  (lambda (m) (m x y)))

;; selector
(define (car z)
  (z (lambda (p q) p)))
(define (cdr z)
  (z (lambda (p q) q)))

这段代码,(car (cons x y))可以替换为((lambda (m) (m x y)) (lambda (p q) p))

进一步替换为((lambda (p q) p) x y)

所以(car (cons x y))可以返回x

其实cons就是返回一个匿名函数,这个匿名函数接收一个函数,并将x、y作为参数输入给这个函数

 

练习2.5

;; Exercise 2.5
;; 用2^a3^b这个整数,记录a、b
#lang racket

;; cons
(define (cons a b)
  (* (expt 2 a) (expt 3 b)))

;; 判断是否为偶数
(define (even? x)
  (=  (remainder x 2) 0))

;; 获取x中因子a的个数
(define (get-factor-num x a)
  (define (iter n r)
    (if (= (remainder r a) 0)
        (iter (+ n 1) (/ r a))
        n))
  (iter 0 x))
      
;; selector
(define (car c)
  (get-factor-num c 2))
(define (cdr c)
  (get-factor-num c 3))

 

练习2.6

这道题的题干初看有点懵逼的,我个人肤浅的理解写在了这里SICP习题2.6 题目理解

求1,1就是(add-1 zero),2就是(add-1 one),以此类推,答案在下面,展开就是了

;; Exercise 2.6
;; 丘奇数
#lang racket

;; 0
(define zero (lambda (f) (lambda (x) x)))

;; 加1
(define (add-1 n)
  (lambda (f) (lambda (x) (f ((n f) x)))))

;; 1
(define one
  (lambda (f) (lambda (x) (f x))))

;; 2
(define two
  (lambda (f) (lambda (x) (f (f x)))))

总结一下,丘奇数,就是f(f(f(...x)))中,调用f的次数来表示对应的数的

仔细看一下丘奇数的函数,(丘奇数 f)这个调用所返回的函数就是给输入套上多层f的外壳,丘奇数对应几就套几个f壳

所以加法就是一个套壳的操作,两个输入是m和n(注意是丘奇数不是阿拉伯数字),先套n个壳,再套m个壳,就是加法了

;; 加
(define (add m n)
  (lambda (f)
    (lambda (x)
      ((m f) ((n f) x)))))

 

练习2.7

超简单

;; Exercise 2.7
;; 区间计算
#lang racket

;; make
(define (make-interval a b) (cons a b))

;; selector
(define (lower-bound i)
  (car i))
(define (upper-bound i)
  (cdr i))

 

练习2.8

;; 减
(define (sub-interval x y)
  (make-interval (- (lower-bound x) (upper-bound y))
                 (- (upper-bound y) (lower-bound y))))

 

练习2.9

假设区间[x_1, x_2][y_1, y_2]

 

对于加法,[z_1, z_2]=[x_1, x_2]+[y_1, y_2]=[x_1+y_1,x_2+y_2]

区间[z_1, z_2]的宽度为\frac{x_2+y_2-x_1-y_1}{2} = \frac{x_2-x_1}{2}+\frac{y_2-y_1}{2},等于原区间宽度之和

 

对于减法,[z_1,z_2]=[x_1,x_2]-[y_1,y_2]=[x_1-y_1,x_2-y_2]

区间[z_1, z_2]的宽度为\frac{x_2-y_2-x_1+y_1}{2} = \frac{x_2-x_1}{2}-\frac{y_2-y_1}{2},等于原区间宽度之差

 

对于乘法,假设有区间[3, 4][-2, 1],相乘得到[-6, 4],宽度为5,原宽度是1和3,并不等于原区间宽度的积

对于除法,假设有区间[3, 4][-2, 1],相除得到[-1.5, 4],宽度为5.5,原宽度是1和3,并不等于原区间宽度的商

 

练习2.10

;; 除
(define (div-interval x y)
  (if (span-zero? y)
      (error "the interval spans zero")
      (mul-interval x 
                    (make-interval (/ 1.0 (upper-bound y))
                                   (/ 1.0 (lower-bound y))))))

;; 检测区间是否跨过0,包含端点在0的情况
(define (span-zero? i)
  (and (<= (lower-bound i) 0) (>= (upper-bound i) 0)))

;; 检测区间是否跨过0,包含端点在0的情况
(define (span-zero? i)
  (and (<= (lower-bound i) 0) (>= (upper-bound i) 0)))

 

练习2.11

一个区间有9种情况,在0的左侧,在0的右侧,横跨0

因此两个区间就有9种情况,列个表,假设区间[x_1, x_2][y_1, y_2],区间在0左侧就用<0表示,在0右侧表示为>0

分布情况 乘法
x>0,y>0 [x_1*y_1, x_2*y_2]
x>0,y=0 [x_2*y_1, x_2*y_2]
x>0,y<0 [x_2*y_1, x_1*y_2]
x=0,y>0 [x_1*y_2, x_2*y_2]
x=0,y=0 [min(x_1*y_2,x_2*y_1), max(x_1*y_1,x_2*y_2)]
x=0,y<0 [x_2*y_1, x_1*y_1]
x<0,y>0 [x_1*y_2, x_2*y_1]
x<0,y=0 [x_1*y_2, x_1*y_1]
x<0,y<0 [x_2*y_2, x_1*y_1]

代码如下

;; 判断区间是否在0右侧
(define (right-zero? i)
  (and (> (lower-bound i) 0) (> (upper-bound i) 0)))

;; 乘
(define (mul-interval x y)
  (let ((p1 (* (lower-bound x) (lower-bound y)))
        (p2 (* (lower-bound x) (upper-bound y)))
        (p3 (* (upper-bound x) (lower-bound y)))
        (p4 (* (upper-bound x) (upper-bound y))))
    (cond ((right-zero? x)
           (cond ((right-zero? y) (make-interval p1 p4))
                 ((span-zero? y)  (make-interval p3 p4))
                 (else (make-interval p3 p2))))
          ((span-zero? x)
           (cond ((right-zero? y) (make-interval p2 p4))
                 ((span-zero? y)  (make-interval (min p2 p3) (max p1 p4)))
                 (else (make-interval p3 p1))))
          (else
           (cond ((right-zero? y) (make-interval p2 p3))
                 ((span-zero? y)  (make-interval p2 p1))
                 (else (make-interval p4 p1)))))))

 

练习2.12

;; 百分比表示,make
(define (make-center-percent c p)
  (make-interval (- c (* c p)) (+ c (* c p))))

;; 百分比表示,selector
(define (center i)
  (/ (+ (lower-bound i) (upper-bound i)) 2))
(define (percent i)
  (/ (- (upper-bound i) (center i)) (center i)))

 

练习2.13

假设两个区间,x_c\pm x_cx_py_c\pm y_cy_p,相乘得到的区间为[(x_c- x_cx_p)*(y_c-y_cy_p), (x_c+ x_cx_p)*(y_c+y_cy_p)]

用百分比来表达,中心点为x_cy_c(1+x_py_p),误差百分比是是\frac{x_p+y_p}{1+x_py_p}

 

练习2.14

现有的代码,A/A得不到[1,1]

《SICP》习题第2章_第1张图片

 

练习2.15

par2可以得到正确的结果,par1是错误的

举个例子,两个电阻的阻值范围[2,3],[4,5]

par1计算的分子是[6,8],分母是[8,15]

除出来是[0.6000000000000001,1.0],是错误的,因为分子的最大值,8,是阻值取3和5的结果,而分母的最小值8,是阻值取2和4的结果

虽然电阻存在误差,但是一个电阻的阻值是不会变的,所以par1计算的是不可能存在的结果

学术一点来说,就是每个区间之间是独立的,但是出现在一个公式里的相同区间不是独立的,而我们程序考虑的都是每个输入区间完全独立的情况

如果每个区间只在计算中出现一次,就避免了这种情景,所以Eva Lu Ator说的是对的

 

练习2.16

思考了一下,区间运算,本质就是一个熟悉的数学问题,给出一个函数和多个自变量的范围,求函数的取值范围

如果自变量只有一个,很好做,初中都学过,如果自变量有多个呢,驻点、求偏导等一系列操作

首先,要写出正确的程序,我们必须时刻关注,出现一次以上的区间的相关性,需要把相同的区间区分开来

其次,要求偏导,求驻点,求偏导需要符号计算,求驻点需要解方程……

我感觉我这个水平做不到

 

练习2.17

;; Exercise 2.17
;; list
#lang racket

;; 返回list最后一个元素
(define (last-pair l)
  (if (null? (cdr l))
      (car l)
      (last-pair (cdr l))))

 

练习2.18

;; 反转list
(define (reverse l)
  (define (reverse-iter remain result)
    (if (null? remain)
        result
        (reverse-iter (cdr remain) (cons (car remain) result))))
  (reverse-iter l null))

 

练习2.19

;; Exercise 2.19
;; 使用list重写count-change
#lang racket

;; 硬币大小
(define us-coins (list 50 25 10 5 1))
(define uk-coins (list 100 50 20 10 5 2 1 0.5))

;; 计算找零方式
(define (cc amount coin-values)
  (cond ((= amount 0) 1)
        ((or (< amount 0) (no-more? coin-values)) 0)
        (else
         (+ (cc amount
                (except-first-denomination coin-values))
            (cc (- amount
                   (first-denomination coin-values))
                coin-values)))))

;; 判断是否没有其余硬币作为选择
(define (no-more? coin-values)
  (null? coin-values))

;; 放弃使用当前硬币
(define (except-first-denomination coin-values)
  (cdr coin-values))

;; 获取当前硬币价值
(define (first-denomination coin-values)
  (car coin-values))

 

练习2.20

构建一个新的list,把符合条件的元素加到list里,最后反转整个list得到

;; Exercise 2.20
;; 返回与第一个元素奇偶性一致的元素
#lang racket
(require "list.rkt")

;; 判断奇偶性一致
(define (same? x y)
  (= (remainder x 2) (remainder y 2)))

;; 过滤
(define (same-parity x . l)
  (define (same-parity-iter remain result)
    (if (null? remain)
        (cons x (reverse result))
        (if (same? x (car remain))
            (same-parity-iter (cdr remain) (cons (car remain) result))
            (same-parity-iter (cdr remain) result))))
  (same-parity-iter l null))

 

练习2.21

;; 对队列中的每个数取平方,递归版
(define (square-list-recursive items)
  (if (null? items)
      null
      (cons (* (car items) (car items)) (square-list-recursive (cdr items)))))

;; 对队列中的每个数取平方,map版
(define (square-list-map items)
  (map (lambda(x) (* x x)) items))

 

练习2.22

越先和result进行cons操作的元素,越排在列表的后面

迭代的时候是从头到尾迭代的,所以最后的结果是反的

 

第二段代码是错误的,假设一个list是(1,2,3,4,5)

第一次迭代时,调用了(iter (1,2,3,4,5) nil),最后执行了(cons null 1)

第二次迭代时,调用了(iter (2,3,4,5) (cons null 1),最后执行了(cons (cons null 1) 4))

所以这段代码调用的结果是(((((() . 1) . 4) . 9) . 16) . 25),这个结构不是list,是list结构的颠倒,如果把car和cdr调换一下,本质上还是一个(25,16,9,4,1)

 

练习2.23

;; Exercise 2.23
;; for循环
#lang racket

;; 对l中的每个元素执行f
(define (for-each f l)
  (cond ((not (null? l))
         (f (car l))
         (for-each f (cdr l)))))

 

练习2.24

eval之后是(1 (2 (3 4)))

《SICP》习题第2章_第2张图片

 

《SICP》习题第2章_第3张图片

 

练习2.25

比较难的就是第三个,对l3执行一次cdr之后得到的是一个list,但不是直接(2,3,4,5,6,7),而是一个((2,3,4,5,6,7), null),所以要一个car取出list

;; Exercise 2.25
;; 获取list中的7
#lang racket

(define l1 (list 1 3 (list 5 7) 9))
(define l2 (list (list 7)))
(define l3 (list 1 (list 2 (list 3 (list 4 (list 5 (list 6 7)))))))

;; 获取7
(car (cdr (car (cdr (cdr l1)))))
(car (car l2))
(car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr l3))))))))))))

 

练习2.26

答案分别是:

(1 2 3 4 5 6)
((1 2 3) 4 5 6)
((1 2 3) (4 5 6))

 

这一章一直很疑惑,为什么(cons (list 1 2) (list 3 4))是((1 2) 3 4)

展开一下list,是(cons 1 (cons 2 nil))和(cons 3 (cons 4 nil))

所以展开(cons (list 1 2) (list 3 4))

(cons (cons 1 (cons 2 nil)) (cons 3 (cons 4 nil))),打印出来是((1 2) 3 4),从展开式可以看出来这是一个3元素的list,第1个元素是list,后两个元素是数字,因为缺少了一个nil

再展开一下(list (list 1 2) (list 3 4))

(cons (cons 1 (cons 2 nil)) (cons (cons 3 (cons 4 nil)) nil)),打印出来是((1 2) (3 4)),从展开式可以看出来这是一个2元素的list,每个元素都是一个list

 

练习2.27

;; Exercise 2.27
;; 深度翻转list
#lang racket

;; 深度翻转list
(define (deep-reverse l)
  (define (iter remain result)
    (if (null? remain)
        result
        (iter (cdr remain) (cons (deep-reverse (car remain)) result))))
  (if (pair? l)
      (iter l null)
      l))

 

练习2.28

;; Exercise 2.28
;; 从左到右,返回一棵树的所有叶节点
#lang racket

;; 返回叶节点
(define (fringe tree)
  (cond ((null? tree) null)
        ((pair? tree) (append (fringe (car tree)) (fringe (cdr tree))))
        (else (list tree))))

 

练习2.29

a.

;; mobile selector
(define (left-branch m)
  (car m))
(define (right-branch m)
  (car (cdr m)))

;; branch selector
(define (branch-length m)
  (car m))
(define (branch-structure m)
  (car (cdr m)))

b.

;; 判断branch是否包含mobile
(define (branch-contains-mobile b)
  (pair? (branch-structure b)))

;; 判断branch的总重
(define (total-weight-branch b)
  (cond ((null? b) 0)
        ((branch-contains-mobile b) (total-weight (branch-structure b)))
        (else (branch-structure b))))

;; mobile的总重
(define (total-weight m)
  (cond ((null? m) 0)
        ((pair? m) (+ (total-weight-branch (left-branch m))
                      (total-weight-branch (right-branch m))))
        (else m)))

c.

;; 计算branch产生的力矩
(define (torque b)
  (* (branch-length b) (total-weight-branch b)))

;; 判断branch是否平衡
(define (balance-branch b)
  (if (branch-contains-mobile b)
      (balance (branch-structure b))
      true))

;; 判断mobile是否平衡
(define (balance m)
  (if (null? m)
      true
      (and (= (torque (left-branch m)) (torque (right-branch m)))
           (balance-branch (left-branch m))
           (balance-branch (right-branch m)))))

d.

只需要修改selector即可

;; Exercise 2.29
;; 用cons构造mobile
#lang racket

;; make mobile
(define (make-mobile left right)
  (cons left right))

;; make branch
(define (make-branch length structure)
  (cons length structure))

;; mobile selector
(define (left-branch m)
  (car m))
(define (right-branch m)
  (cdr m))

 

练习2.30

;; Exercise 2.39
;; 对树里的所有元素取平方
#lang racket

;; 对树里所有元素取平方
(define (square-tree t)
  (cond ((null? t) null)
        ((pair? t) (cons (square-tree (car t)) (square-tree (cdr t))))
        (else (square t))))

;; 平方
(define (square x)
  (* x x))

 

练习2.31

;; Exercise 2.31
;; 对树里的所有元素采取某种操作
#lang racket

;; map
(define (tree-map proc t)
  (cond ((null? t) null)
        ((pair? t) (cons (tree-map proc (car t)) (tree-map proc (cdr t))))
        (else (proc t))))

(define t
  (list 1
       (list 2 (list 3 4) 5)
       (list 6 7)))

(tree-map (lambda (x) (* x x)) t)

 

练习2.32

把一个集合分成两部分,首元素和其余部分,那么这个集合的所有子集,也可以分为两个部分

一个部分是其余部分的子集,另一个部分是其余部分的子集再加上首元素

以(1 2 3)为例,分为1和(2 3),其子集分为两个部分

(2 3)的子集() (3) (2) (2 3)

和(2 3)子集并入首元素1,(1) (1 3) (1 2) (1 2 3)

;; Exercise 2.32
;; 生成一个list的所有子list
#lang racket

;; 子list生成
(define (subsets s)
  (if (null? s)
      (list null)
      (let ((rest (subsets (cdr s))))
        (append rest (map (lambda (l) (cons (car s) l)) rest)))))

 

练习2.33

;; map-by-accumulate
(define (map-by-accumulate p sequence)
  (accumulate (lambda (x y) (cons (p x) y)) null sequence))

;; append-by-accumulate
(define (append-by-accumulate seq1 seq2)
  (accumulate cons seq2 seq1))

;; length-by-accumulate
(define (length-by-accumulate sequence)
  (accumulate (lambda(x y) (+ y 1)) 0 sequence))

 

练习2.34

;; polynomial-by-accumulate
(define (horner-eval x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms) (+
                                                  (* higher-terms x)
                                                  this-coeff))
               0
               coefficient-sequence))

 

练习2.35

首先使用map函数处理tree,tree是一个嵌套的list,用map函数把每个嵌套的子树映射为子树叶节点数量

map函数里递归调用了count-leaves来处理子树

;; count-leaves-by-accumulate
(define (count-leaves t)
  (accumulate +
              0
              (map (lambda(x)
                     (cond ((null? x) 0)
                           ((pair? x) (count-leaves x))
                           (else 1)))
                   t)))

 

练习2.36

加入输入的list都是3元素的,就先把所有队列第一个元素提取出来,计算,然后和剩余的(剩下的2元素)做cons

这里有一个小问题,为什么一开始判断null用的是(car seqs)而不是seqs

因为到最后seqs是(() ()),这种list不是空的,所以要用(car seqs)判断

;; 若干个list的对应位累计
(define (accumulate-n op initial seqs)
  (if (null? (car seqs))
      null
      (cons (accumulate op initial (map (lambda(x)
                                          (car x))
                                        seqs))
            (accumulate-n op initial (map (lambda(x)
                                            (cdr x))
                                          seqs)))))

 

练习2.37

;; 矩阵向量乘
(define (matrix-*-vector m v)
  (map (lambda (x) (dot-product x v)) m))

;; 矩阵转置
(define (transpose mat)
  (accumulate-n cons null mat))

;; 矩阵乘矩阵
(define (matrix-*-matrix m n)
  (let ((cols (transpose n)))
    (map (lambda(x) (matrix-*-vector cols x)) m)))

 

练习2.38

第一组,答案分别是3/2和1/6

fold-right,也就是accumulate,看一下展开的过程,是1/(2/(3/1))

fold-left,展开是1/1/2/3

第二组,答案分别是list (1 list (2 list (3 (nil))))和(list (list (list nil 1) 2) 3)

跟上面类似,不展开了

跟执行顺序无关的符号,满足结合律,即算子(参数)位置没有改变,运算顺序(用括号改变)不会对结果有影响

比如加法,就可以在fold-right和fold-left取得相同结果

 

练习2.39

fold-right,利用append

;; 翻转
(define (reverse sequence)
  (fold-right (lambda(x y)
                (append y (list x)))
              null
              sequence))

fold-left的很好写

;; 翻转
(define (reverse sequence)
  (fold-left (lambda(x y) (cons y x)) null sequence))

 

练习2.40

;; 生成整数对,并过滤和不为质数的部分
(define (prime-sum-pairs n)
  (map make-pair-sum
       (filter prime-sum? (unique-pairs n))))

;; 产生1<= j< i<= n的整数对
(define (unique-pairs n)
  (flatmap
   (lambda (i)
     (map (lambda(j) (list i j))
          (enumerate-interval 1 (- i 1))))
   (enumerate-interval 1 n)))

 

练习2.41

和上面的类似,照着写就行了

;; 产生1<=k

 

练习2.42

;; Exercise 2.42
;; N皇后
#lang racket
(require "prime-sum-pairs.rkt")
(require "sequence-operations.rkt")

;; N皇后
;; 当前棋盘的可能状态用一组list表示,每个list表示一种皇后放置方法,每个list对应下标存放的数值表示这一列皇后放在哪一行
(define (queens board-size)
  (define (queen-cols k)  
    (if (= k 0)
        (list empty-board)
        (filter
         (lambda (positions) (safe? k positions))
         (flatmap
          (lambda (rest-of-queens)
            (map (lambda (new-row)
                   (adjoin-position new-row k rest-of-queens))
                 (enumerate-interval 1 board-size)))
          (queen-cols (- k 1))))))
  (queen-cols board-size))

;; 空棋盘
(define empty-board null)

;; 放入新的一列,new-row表示新放入的第k列皇后处于哪一行
(define (adjoin-position new-row k rest-of-queens)
  (cons new-row rest-of-queens))

;; 判断第k列的皇后位置是否合法
(define (safe? k positions)
  ;; 判断皇后所处行是否有重复,是否会在对角线碰撞
  (and (unique-first positions)
       ;; 判断皇后是否在对角线碰撞
       (not-crash? positions)))
       
;; 判断list中首元素是否是不重复
(define (unique-first l)
  (= (list-item-num l (car l)) 1))

;; 获取list中某个给定值出现了几次
(define (list-item-num l item)
  (length (filter (lambda(x) (= x item)) l)))

;; 判断新皇后是否会和其他皇后碰撞
(define (not-crash? l)
  ;; 沿着对角线逐步检查是否相撞
  ;; cur表示会与新皇后相撞的位置
  ;; direction为±1,表示两个对角线方向
  (define (check remain cur direction)
    (if (null? remain)
        #t
        (and (not (= (car remain) cur))
             (check (cdr remain) (+ cur direction) direction))))
  (and (check (cdr l) (+ (car l) 1) 1)
       (check (cdr l) (+ (car l) -1) -1)))

部分答案如下

《SICP》习题第2章_第4张图片

 

练习2.43

原来的写法,每次做flatmap时,调用一次queen-cols,线形调用,耗费的时间是O(n)

现在这种写法,每次做flatmap时,调用board-size次queen-cols,变成了树形递归调用,根据前面的知识,树形递归调用耗费的时间是O(C^n),随问题规模呈指数增长,常数与执行一次调用耗费时间有关,显然C大致为O(n)

所以更改后的代码,耗费时间大约为T^n

 

练习2.4

;; 在画作上方画两幅更小的画作
(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
        (below painter (beside smaller smaller)))))

 

练习2.45

;; split,d1表示小画和大画的组合方式,d2表示两幅小画的组合方式
(define (split d1 d2)
  (lambda (painter n)
    (if (= n 0)
        painter
        (let ((smaller ((split d1 d2) painter (- n 1))))
          (d1 painter (d2 smaller smaller))))))

 

练习2.46

没什么难度

;; Exercise 2.46
;; 向量
#lang racket

;; make
(define (make-vect x y)
  (cons x y))

;; selector
(define (xcor-vect v)
  (car v))
(define (ycor-vect v)
  (cdr v))

;; 加
(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
             (+ (ycor-vect v1) (ycor-vect v2))))

;; 减
(define (sub-vect v1 v2)
  (make-vect (- (xcor-vect v1) (xcor-vect v2))
             (- (ycor-vect v1) (ycor-vect v2))))

;; 乘系数
(define (scale-vect v s)
  (make-vect (* (xcor-vect v) s)
             (* (ycor-vect v) s)))

 

练习2.47

第一种

;; Exercise 2.47
;; frame
#lang racket

;; make
(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

;; selector
(define (origin-frame f)
  (car f))
(define (edge1-frame f)
  (cadr f))
(define (edge2-frame f)
  (cadr (cdr f)))

第二种

;; Exercise 2.47
;; frame
#lang racket

;; make
(define (make-frame origin edge1 edge2)
  (cons origin (cons edge1 edge2)))

;; selector
(define (origin-frame f)
  (car f))
(define (edge1-frame f)
  (cadr f))
(define (edge2-frame f)
  (cdr (cdr f)))

 

练习2.48

;; Exercise 2.48
;; segment
#lang racket
(require "vector.rkt")
(provide (all-defined-out))

;; make
(define (make-segment v1 v2)
  (cons v1 v2))

;; selector
(define (start-segment s)
  (car s))
(define (end-segment s)
  (cdr s))

 

练习2.49

a.

;; 画出外框
(define (draw-outline frame)
  ;; 四个端点
  (let ((v1 (make-vect 0 1))
        (v2 (make-vect 0 0))
        (v3 (make-vect 1 0))
        (v4 (make-vect 1 1)))
    (segments->painter (list (make-segment v1 v2)
                             (make-segment v2 v3)
                             (make-segment v3 v4)
                             (make-segment v4 v1)))))

b.

;; 画X
(define (draw-x frame)
  ;; 四个端点
  (let ((v1 (make-vect 0 1))
        (v2 (make-vect 0 0))
        (v3 (make-vect 1 0))
        (v4 (make-vect 1 1)))
    (segments->painter (list (make-segment v1 v3)
                             (make-segment v2 v4)))))

c.

;; 画菱形
(define (draw-diamond frame)
  ;; 四个中点
  (let ((v1 (make-vect 0.0 0.5))
        (v2 (make-vect 0.5 1.0))
        (v3 (make-vect 1.0 0.5))
        (v4 (make-vect 0.5 0.0)))
    (segments->painter (list (make-segment v1 v2)
                             (make-segment v2 v3)
                             (make-segment v3 v4)
                             (make-segment v4 v1)))))

d.

我必须承认我是从网上抄的

;; 画挥手的小人
(define wave-painter-segments
  (segments->painter
   (list (make-segment (make-vect 0.2 0.0) (make-vect 0.4 0.4))
         (make-segment (make-vect 0.4 0.4) (make-vect 0.3 0.5))
         (make-segment (make-vect 0.3 0.5) (make-vect 0.1 0.3))
         (make-segment (make-vect 0.1 0.3) (make-vect 0.0 0.6))
         (make-segment (make-vect 0.0 0.8) (make-vect 0.1 0.5))
         (make-segment (make-vect 0.1 0.5) (make-vect 0.3 0.6))
         (make-segment (make-vect 0.3 0.6) (make-vect 0.4 0.6))
         (make-segment (make-vect 0.4 0.6) (make-vect 0.3 0.8))
         (make-segment (make-vect 0.3 0.8) (make-vect 0.4 1.0))
         (make-segment (make-vect 0.6 1.0) (make-vect 0.7 0.8))
         (make-segment (make-vect 0.7 0.8) (make-vect 0.6 0.6))
         (make-segment (make-vect 0.6 0.6) (make-vect 0.8 0.6))
         (make-segment (make-vect 0.8 0.6) (make-vect 1.0 0.4))
         (make-segment (make-vect 1.0 0.2) (make-vect 0.6 0.4))
         (make-segment (make-vect 0.6 0.4) (make-vect 0.8 0.0))
         (make-segment (make-vect 0.7 0.0) (make-vect 0.5 0.3))
         (make-segment (make-vect 0.5 0.3) (make-vect 0.3 0.0)))))

 

练习2.50

;; 水平翻转
(define (flip-horiz painter)
  ((transform-painter painter
                      (make-vect 1.0 0.0)
                      (make-vect 0.0 0.0)
                      (make-vect 1.0 1.0))
   painter))

;; 顺时针旋转180度
(define (rotate180 painter)
  ((transform-painter painter
                      (make-vect 1 1)
                      (make-vect 0 1)
                      (make-vect 1 0))
   painter))

;; 顺时针旋转270度
(define (rotate270 painter)
  ((transform-painter painter
                      (make-vect 0 1)
                      (make-vect 0 0)
                      (make-vect 1 1))
   painter))

 

练习2.51

仿照beside的写法

;; below
(define (below painter-bottom painter-top)
  (let ((paint-top
         (transform-painter painter-top
                            (make-vect 0.0 0.5)
                            (make-vect 1.0 0.5)
                            (make-vect 0.0 1.0)))
        (paint-below
         (transform-painter painter-bottom
                            (make-vect 0.0 0.0)
                            (make-vect 1.0 0.0)
                            (make-vect 0.0 0.5))))
    (lambda (frame)
      (paint-top frame)
      (paint-bottom frame))))

如果用beside加rotate实现below

;; beside实现below
(define (below-by-biside painter-bottom painter-top)
  (rotate270 (beside (rotate90 painter-bottom)
                      (rotate90 painter-up))))

 

练习2.52

a.

给你画个对角线

;; 画挥手的小人
(define wave-painter-segments
  (segments->painter
   (list (make-segment (make-vect 0.0 0.0) (make-vect 1.0 1.0))
         (make-segment (make-vect 0.2 0.0) (make-vect 0.4 0.4))
         (make-segment (make-vect 0.4 0.4) (make-vect 0.3 0.5))
         (make-segment (make-vect 0.3 0.5) (make-vect 0.1 0.3))
         (make-segment (make-vect 0.1 0.3) (make-vect 0.0 0.6))
         (make-segment (make-vect 0.0 0.8) (make-vect 0.1 0.5))
         (make-segment (make-vect 0.1 0.5) (make-vect 0.3 0.6))
         (make-segment (make-vect 0.3 0.6) (make-vect 0.4 0.6))
         (make-segment (make-vect 0.4 0.6) (make-vect 0.3 0.8))
         (make-segment (make-vect 0.3 0.8) (make-vect 0.4 1.0))
         (make-segment (make-vect 0.6 1.0) (make-vect 0.7 0.8))
         (make-segment (make-vect 0.7 0.8) (make-vect 0.6 0.6))
         (make-segment (make-vect 0.6 0.6) (make-vect 0.8 0.6))
         (make-segment (make-vect 0.8 0.6) (make-vect 1.0 0.4))
         (make-segment (make-vect 1.0 0.2) (make-vect 0.6 0.4))
         (make-segment (make-vect 0.6 0.4) (make-vect 0.8 0.0))
         (make-segment (make-vect 0.7 0.0) (make-vect 0.5 0.3))
         (make-segment (make-vect 0.5 0.3) (make-vect 0.3 0.0)))))

b.

;; corner split
(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
            (right (right-split painter (- n 1)))
            (corner (corner-split painter (- n 1))))
        (beside (below painter up)
                (below right corner)))))

c.

;; square limit
(define (square-limit painter n)
  (let ((combine4 (square-of-four identity flip-horiz
                                  flip-vert rotate180)))
    (combine4 (corner-split painter n))))

 

练习2.53

'(a b c)
'((george))
'((y1 y2))  后面还有一个nil,所以是一个list,里面包含(y1,y2)和nil
'(y1 y2)
#f
#f  检查两个元素(red shoes)和(blue socks),均不等于red
'(red shoes blue socks)

 

练习2.54

;; Exercise 2.54
;; 判断list是否相等
#lang racket

;; 判断两个list是否完全相等
(define (equal? l1 l2)
  (cond ((and (null? l1) (null? l2)) #t)
        ((or (null? l1) (null? l2) (not (eq? (car l1) (car l2)))) #f)
        (else (equal? (cdr l1) (cdr l2)))))

 

练习2.55

(car ''abracadabra),展开就是(car '(quote abracadabra))

 

练习2.56

简单写了一个,仅支持指数为数字的形式

先写幂运算相关的make和selector

;; 判断是否是求幂
(define (exp? x)
  (and (pair? x)
       (eq? (car x) '**)))

;; 求幂
(define (make-exp base exponent)
  (if (or (=number? base 1) (=number? exponent 0))
      1
      (list '** base exponent)))

;; 获取幂的基数、指数
(define (base e) (cadr e))
(define (exponent e) (caddr e))

然后修改求导

;; 求导
(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))))
        ((exp? exp)
         (make-product (make-product (exponent exp)
                                     (make-exp (base exp) (- (exponent exp) 1)))
                       (deriv (base exp) var)))
        (else
         (error "unknwon expression type -- DERIV" exp))))

 

练习2.57

只修改augend和multiplicand的定义,举个例子,addend还是保存第一项,augend保存之后的所有项的和

例如,(+ x y z)的addend是x,augend是(+ y z)

;; 获取加数
(define (augend s)
  (let ((rest (cddr s)))
    (if (null? (cdr rest))
        (car rest)
        (cons '+ rest))))

;; 获取乘数
(define (multiplicand p)
  (let ((rest (cddr p)))
    (if (null? (cdr rest))
        (car rest)
        (cons '* rest))))

 

练习2.58

a.

;; 判断是否是求和式
(define (sum? x)
  (and (pair? x) (eq? (cadr x) '+)))

;; 判断是否是求积式
(define (product? x)
  (and (pair? x) (eq? (cadr x) '*)))

;; 获取加数
(define (addend s) (car s))
(define (augend s) (caddr s))

;; 获取乘数
(define (multiplier p) (car p))
(define (multiplicand p) (caddr p))

;; 求和
(define (make-sum a1 a2)
  (cond ((=number? a1 0) a2)
        ((=number? a2 0) a1)
        ((and (number? a1) (number? a2)) (+ a1 a2))
        (else (list a1 '+ a2))))

;; 求积
(define (make-product m1 m2)
  (cond ((or (=number? m1 0) (=number? m2 0)) 0)
        ((=number? m1 1) m2)
        ((=number? m2 1) m1)
        ((and (number? m1) (number? m2)) (* m1 m2))
        (else (list m1 '* m2))))

 

b.

需要考虑的情况是,当加法前含有乘法运算时,如何准确地识别加法

例如,4 * x + x * x,需要判定为求和,并且拆分出4 * x和x * x,再对子项进行求导

那么只需要在判断表达式的死后,当表达式含有+,就判定为加法,先行进行处理

;; 判断是否是求和式
(define (sum? x)
  (contains? x '+))

;; 判断是否是求积式
(define (product? x)
  (and (not (contains? x '+)) (contains? x '*)))

;; 判断list中是否含有某元素
(define (contains? l item)
  (cond ((null? l) #f)
        ((eq? (car l) item) #t)
        (else (contains? (cdr l) item))))

乘法的selector修改成类似习题2.57中的样子(但需要修改,注意*号的位置,不是最前面而是中间),以支持多项计算,加法的selector需要在“+”处切分

;; 从list中获取指定item之前的部分
(define (get-before l item)
  (define (iter remain)
    (if (or (null? remain) (eq? (car remain) item))
        null
        (cons (car remain) (iter (cdr remain)))))
  (remove-brackets-if-only-one (iter l)))

;; 从list中获取指定item之后的部分
(define (get-after l item)
  (define (iter remain)
    (cond ((null? remain) null)
          ((eq? (car remain) item) (cdr remain))
          (else (iter (cdr remain)))))
  (remove-brackets-if-only-one (iter l)))

;; 若list中只含有一个元素,去除括号
(define (remove-brackets-if-only-one l)
  (if (null? (cdr l))
      (car l)
      l))

;; 获取加数
(define (addend s) (get-before s '+))
(define (augend s) (get-after s '+))

;; 获取乘数
(define (multiplier p) (car p))
(define (multiplicand p)
  (let ((rest (cddr p)))
    (if (null? (cdr rest))
        (car rest)
        rest)))

 

练习2.59

;; 取并集
(define (union-set set1 set2)
  (cond ((or (null? set1) (null? set2)) set2)
        ((element-of-set? (car set1) set2)
         (union-set (cdr set1) set2))
        (else (cons (car set1) (union-set (cdr set1) set2)))))

 

练习2.60

由可重复列表构成的集合,代码如下

;; Exercise 2.60
;; 允许重复的列表构成的集合
#lang racket

;; 判断集合是否包含某个元素
(define (element-of-set? x set)
  (cond ((null? set) false)
        ((equal? x (car set)) true)
        (else (element-of-set? x (cdr set)))))

;; 在集合中加入元素
(define (adjoin-set x set)
  (cons x set))

;; 取交集 
(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((null? set2) set1)
        (else (union-set (cdr set1) (cons (car set1) set2)))))

;; 取并集
(define (intersection-set set1 set2)
  (cond ((or (null? set1) (null? set2)) null)
        ((element-of-set? (car set1) set2)
         (cons (car set1)
               (intersection-set (cdr set1) set2)))
        (else (intersection-set (cdr set1) set2))))

和由不可重复列表构成集合的各项操作复杂度对比

分类 element-of-set? adjoin-set union-set intersection-set
重复列表 \Theta (n) \Theta (1) \Theta (n) \Theta (n^2)
不可重复列表 \Theta (n) \Theta (n) \Theta (n^2) \Theta (n^2)

虽然有部分操作复杂度降低了,但是带来的是更大的存储开销,在数据重复度很高的情况下,重复列表的长度会比不重复列表大很多,操作也会变慢,因此需要根据应用来选择合适的底层实现方式

 

练习2.61

;; Exercise 2.61
;; 有序列表构成的集合
#lang racket

;; 向集合增加元素
(define (adjoin-set x set1)
  (cond ((null? set1) (cons x null))
        ((= (car set1) x) set1)
        ((> (car set1) x) (cons x set1))
        (else (cons (car set1) (adjoin-set x (cdr set1))))))

 

练习2.62

;; 取交集
(define (union-set set1 set2)
  (cond ((null? set1) set2)
        ((null? set2) set1)
        (else
         (let ((x1 (car set1))
               (x2 (car set2)))
           (cond ((= x1 x2) (cons x1 (union-set (cdr set1) (cdr set2))))
                 ((< x1 x2) (cons x1 (union-set (cdr set1) set2)))
                 (else (cons x2 (union-set set1 (cdr set2)))))))))

 

练习2.63

a.

两种写法都一样,是前序遍历

对于图2.16,结果都是1 3 5 7 9 11

b.

两种写法的递归调用次数都是差不多的,那么就比较每一次的操作

第一种写法使用了append操作,比第二种写法的cons操作,显然复杂度更高

 

练习2.64

a.

非常多的let嵌套简直惊悚,建议从下往上看,清晰很多

首先partial-tree有两个输入,一个是元素列表,一个是元素列表长度

partial-tree的返回是一个pair,从最后一行可以猜出,pair是已经组合好的树和未处理的元素

再读一读let嵌套就可以知道,partial-tree先把左子树的所有元素处理成树,返回未处理的元素(包含entry和右子树的所有元素),然后依次处理entry和右子树

处理的结果是(5 (1 () (3 () ())) (9 (7 () ()) (11 () ())))

对每个元素都处理依次,因此复杂度为\Theta (n)

b.

首先把二叉树转换成list,再按照需求进行交或并的归并,再把处理好的list转换成二叉树

三种操作的复杂度都是\Theta (n)

;; 取交集
(define (union-set set1 set2)
  (let ((list1 (tree->list-1 set1))
        (list2 (tree->list-1 set2)))
    ;; 取两个有序列表交集
    (define (merge list1 list2)
      (cond ((null? list1) list2)
            ((null? list2) list1)
            (else
             (let ((x1 (car list1))
                   (x2 (car list2)))
               (cond ((= x1 x2) (cons x1 (merge (cdr list1) (cdr list2))))
                     ((< x1 x2) (cons x1 (merge (cdr list1) list2)))
                     (else (cons x2 (merge list1 (cdr list2)))))))))
    (let ((union-list (merge list1 list2)))
      (list->tree union-list))))

;; 取交集
(define (intersection-set set1 set2)
  (let ((list1 (tree->list-1 set1))
        (list2 (tree->list-2 set2)))
    ;; 取两个有序列表并集
    (define (merge list1 list2)
      (if (or (null? list1) (null? list2))
          null
          (let ((x1 (car list1))
                (x2 (car list2)))
            (cond ((= x1 x2) (cons x1 (merge (cdr list1) (cdr list2))))
                  ((< x1 x2) (merge (cdr list1) list2))
                  (else (merge list1 (cdr list2)))))))
    (let ((intersection-list (merge list1 list2)))
      (list->tree intersection-list))))

 

练习2.66

;; 查找
(define (lookup set1 key)
  (if (null? set1)
      false
      (let ((x (entry set1)))
        (cond ((= x key) true)
              ((< x key) (lookup (right-branch set1) key))
              (else (lookup (left-branch set1) key))))))

 

练习2.67

A D A B B C A

 

练习2.68

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

;; 编码一个symbol
(define (encode-symbol symbol tree)
  ;; 判断有序集合中是否含有某元素
  (define (contains? set1 s)
    (cond ((null? set1) false)
          ((equal? (car set1) s) true)
          (else (contains? (cdr set1) s))))
  ;; 判断子树是否包含symbol
  (define (tree-contains? s t)
    (contains? (symbols t) s))
  (cond ((leaf? tree) null)
        ((tree-contains? symbol (left-branch tree))
         (cons 0 (encode-symbol symbol (left-branch tree))))
        ((tree-contains? symbol (right-branch tree))
         (cons 1 (encode-symbol symbol (right-branch tree))))
        (else (error ("待加密信息输入错误")))))
         
;; 测试编码      
(define sample-characters '(A D A B B C A))
(encode sample-characters sample-tree)

 

练习2.69

;; 将最小的元素合并为一个节点
(define (successive-merge ordered-pairs)
  (if (= (length ordered-pairs) 1)
      (car ordered-pairs)
      (let ((leaf1 (car ordered-pairs))
            (leaf2 (cadr ordered-pairs))
            (remains (cddr ordered-pairs)))
        (successive-merge (adjoin-set (make-code-tree leaf1 leaf2) remains)))))

 

练习2.70

利用霍夫曼编码,只要84位bit,定长3-bit编码需要108位

 

练习2.71

对于这种频率,在合并树节点的时候,两个最小的节点合并后仍然是最小的节点,n=5的时候霍夫曼树如下

《SICP》习题第2章_第5张图片

因此这种情况,频率最高的节点,霍夫曼编码是1位,频率最低的节点,霍夫曼编码是n-1位

 

练习2.72

对一个长度为n的message,假设单词为m个,调用n次encode函数,每个encode函数调用一次encode-symbol

一次encode-symbol,每次都要在节点的set中搜寻symbol是否存在,然后沿着节点一次向下搜寻沿着节点,所以复杂度和霍夫曼树是否平衡有关。在不知道霍夫曼树结构的情况下,计算复杂度是很困难的

练习2.71中的霍夫曼树为例

对于最频繁出现的symbol,在第一个节点set中搜寻即可找到,第一个节点set长度为n,所以复杂度是\Theta (n)

对于最不频繁出现的symbol,要在(n-1)个节点的set中搜寻,每个set的长度与n成正比,所以复杂度是\Theta (n^2)

 

练习2.73

a.

数据导向的求导程序

因为数字和符号已经有了内置的number?、variable?这种函数,如果对数字、变量也打数据标签,要多很多操作

b.

先把给数据打标签的代码写好

;; 带标签数据
#lang racket
(provide (all-defined-out))

;; 给数据打标签
(define (attach-tag type-tag contents)
  (cons type-tag contents))

;; 获取数据标签
(define (type-tag datum)
  (if (pair? datum)
      (car datum)
      (error "Bad tagged datum -- TYPE-TAG" datum)))

;; 获取数据内容
(define (contents datum)
  (if (pair? datum)
      (cdr datum)
      (error "Bad tagged datum -- CONTENTS" datum)))

sum和product的install代码

;; sum数据类型
(define (install-sum-package)
  ;; 内部函数
  ;; 构造函数
  (define (make-sum x y)
    (cond ((=number? x 0) y)
          ((=number? y 0) x)
          ((and (number? x) (number? y)) (+ x y))
          (else (attach-tag '+ x y))))
  ;; 获取第一个加数
  (define (addend s)
    (car s))
  ;; 获取第二个加数
  (define (augend s)
    (cadr s))
  ;; 求导
  (define (diff-sum operands var)
    (make-sum (deriv (addend operands) var)
              (deriv (augend operands) var)))
  ;; 注册函数
  (put 'deriv '+ diff-sum))
  (put 'make  '+ make-sum))

;; product数据类型
(define (install-product-package)
  ;; 内部函数
  ;; 构造函数
  (define (make-product x y)
    (cond ((=number? x 1) y)
          ((=number? y 1) x)
          ((or (=number? x 0) (=number? y 0)) 0)
          ((and (number? x) (number? y)) (+ x y))
          (else (attach-tag '* x y))))
  ;; 获取第一个乘数
  (define (multiplier s)
    (car s))
  ;; 获取第二个乘数
  (define (multiplicand s)
    (cadr s))
  ;; 求导
  (define (diff-product operands var)
    (make-sum (make-product
               (multiplier operands)
               (deriv (multiplicand operands) var))
              (make-product
               (deriv (multiplier operands) var)
               (multiplicand operands))))
  ;; 接口
  (put 'deriv '* diff-product)
  (put 'make  '* make-product))

(define make-sum (get 'make '+))
(define make-product (get 'make '*))

c.

;; 指数数据类型
(define (install-exp-package)
  ;; 内部函数
  ;; 构造函数
  (define (make-exp x y)
    (cond ((=number? y 0) 1)
          ((=number? y 1) x)
          ((and (number? x) (number? y)) (** x y))
          (else (attach-tag '** x y))))
  ;; 获取基数
  (define (base s)
    (car s))
  ;; 获取指数
  (define (exponent s)
    (cadr s))
  ;; 求导
  (define (diff-exp operands var)
    (let ((b (base operands))
          (e (exponent operands)))
      (make-product e
                    (make-product (deriv e var)
                                  (make-exp b (make-sum e -1)))))
  ;; 接口
  (put 'deriv '** diff-exp)
  (put 'make  '** make-exp))

d.

把所有put操作的前两个参数调换位置就可以了

 

2.74

由题意,每个独立文件以不同的数据结构存放员工信息,以员工姓名为主键

a.

每个文件的数据都分配一个tag,都公开以下接口:

  • 通过员工姓名查询员工信息记录的get函数
  • 各种select函数,包括薪水、入职日期等

get_record函数通过员工姓名在文件中查询员工信息,在不同文件中查询时,只要根据不同的数据tag选择对应的get函数就可以了

b.

通过每条员工信息的数据tag,选择对应的select函数,查询薪水

c.

在不同文件中搜索,直到搜索到该姓名为止

d.

分配给新公司一个tag,并在它原来的员工数据基础上,增加对应的get和select函数

 

2.75

这个message写起来比tag简单多了

伟大的面向对象思想

;; 极坐标
(define (make-from-mag-ang m a)
  (define (dispatch op)
    (cond ((eq? op 'magnitude) m)
          ((eq? op 'angle) a)
          ((eq? op 'real-part) (* m (cos a)))
          ((eq? op 'imag-part) (* m (sin a)))
          (else
           (error "Unknown op -- MAKE-FROM-MAG-ANG" op))))
  dispatch)

 

2.76

显式分派:非常麻烦,每个类型的每个方法名字要注意区分,大型系统中简直是噩梦的存在

tag:增加类型,要分配一个新tag,并更新全局函数表;增加方法要更新全局函数表;之前的代码无需修改

message:增加类型几乎不需要额外的开销;增加方法,其实和tag相比要加入的代码量是类似的,但是tag法的方法代码可以不和同类代码放在一起,message的方法必须和类写在一个dispatch函数里,所以tag法增加方法更加地方便一些(写起来方便,写的量我觉得差不多)

综上,经常增加类,使用message法,经常增加方法,使用tag法

 

练习2.77

magnitude只在install函数内部定义了,其他函数无法直接调用install函数内部定义的函数

 

练习2.78

加个判断分支就好,number和symbol不打tag,获取标签的时候,判断为number?或symbol?的直接返回对应tag

;; Exercise 2.78
;; 带标签数据,可处理系统自带number和symbol
#lang racket

;; 给数据打标签
(define (attach-tag type-tag contents)
  (cons type-tag contents))

;; 获取数据标签
(define (type-tag datum)
  (cond ((number? datum) 'number)
        ((symbol? datum) 'symbol)
        ((pair? datum) (car datum))
        (else (error "Bad tagged datum -- TYPE-TAG" datum))))

;; 获取数据内容
(define (contents datum)
  (cond ((or (number? datum) (symbol? datum)) datum)
        ((pair? datum) (cdr datum))
        (else (error "Bad tagged datum -- CONTENTS" datum))))

 

练习2.79

写数字包

;; 数字包
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "install-rational-package.rkt")
(provide (all-defined-out))

;; 数字包
(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  ;; 判断数字是否为0
  (define (number-zero? n)
    (= n 0))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  ;; 判断数字是否相等
  (put 'equ? '(scheme-number scheme-number) =)
  'done)

;; 构造函数
(define (make-scheme-number x)
  ((get 'make 'scheme-number) x))

有理数判断是否相等

;; 判断有理数是否相等
(define (rational-eq? r1 r2)
  (= (* (numer r1) (denom r2))
     (* (denom r1) (numer r2))))
(put 'equ? 'rational rational-eq?)

复数判断是否相等

;; 判断复数是否相等
(define (equ? z1 z2)
  (and (= (real-part z1) (real-part z2)) (= (imag-part z1) (imag-part z2))))
(put 'equ? '(complex complex) equ?)

练习2.80

类似操作

;; Exercise 2.80
;; 泛型数字操作
#lang racket

;; 判断有理数是否为零
(define (rational-zero? r)
  (= (numer r) 0))
(put 'zero? 'rational rational-zero?)

;; 判断复数是否为零
(define (complex-zero? c)
  (and (= (real-part c) 0) (= (imag-part c) 0)))
(put 'zero? 'complex complex-zero?)

;; 判断数字是否为0
(define (number-zero? n)
  (= n 0))
(put 'zero? 'number number-zero?)

 

练习2.81

a.

apply-generic函数有两个分支:一个分支是找到当前输入类型对应的操作函数,调用函数,完成操作;或者尝试输入数据的类型转换,再用新输入类型调用apply-generic

如果加上scheme-number自身的转换,(apply-generic scheme-number scheme-number)会重复a1->a2类型转换,然后调用(apply-generic scheme-number scheme-number),程序陷入死循环

b.

从上一小题分析可以看出来,apply-generic首先查找是否有对应输入类型的操作函数,查找不到就会尝试进行类型转换;如果加入同类型转换的函数,转换前后没有任何改变,找不到操作函数还是找不到,必然会引起死循环调用

c.

要运行这个函数,要自己模拟一下get-coercion函数

;; Exercise 2.81
;; 使用泛型函数
#lang racket
(require "tag-datum.rkt")
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(provide (all-defined-out))

;; 泛型操作
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if (not (null? proc))
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                ;; 如果两个输入数据类型相同,报错
                (if (equal? type1 type2)
                    (error "No method for these types")
                    (let ((t1->t2 (get-coercion type1 type2))
                          (t2->t1 (get-coercion type2 type1)))
                      (cond ((not (null? t1->t2))
                             (apply-generic op (t1->t2 a1) a2))
                            ((not (null? t2->t1))
                             (apply-generic op a1 (t2->t1 a2)))
                            (else
                             (error "No method for these types"
                                    (list op type-tags)))))))
              (error "No method for these types"
                     (list op type-tags)))))))

;; 获取转换函数
(define (get-coercion type1 type2)
  (get 'coercion (list type1 type2)))

 

练习2.82

这种实现方式,如果存在输入类型不同的通用函数,比如(exp scheme-number complex),是不能找到这个通用函数的,只能找到所有输入类型都是一样的通用函数

;; Exercise 2.81
;; 使用泛型函数
#lang racket
(require "tag-datum.rkt")
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(provide (all-defined-out))

;; 多输入泛型操作
(define (apply-generic op . args)
  ;; 尝试转换arg为type类型
  (define (change-type type)
    (lambda(arg)
      (let ((change-proc (get-coercion (type-tag arg) type)))
        (if (null? change-proc)
             arg
             (change-proc arg)))))
  ;; origin-types表示最初输入参数的类型list
  (define (iter origin-types changed-args)
    ;; 查找对应输入类型的函数
    (let ((type-tags (map type-tag changed-args)))
      (let ((proc (get op type-tags)))
        (if (not (null? proc))
            ;; 如果找到对应输入类型的函数
            (apply proc (map contents changed-args))
            ;; 如果没有找到,转换为origin-types中的首元素类型
            (if (null? origin-types)
                ;; 已经尝试了所有类型,仍未找到,报错
                (error "No method for these types")
                ;; 转换参数类型,递归调用
                (iter (cdr origin-types) (map (change-type (car origin-types)) args)))))))
  ;; 调用
  (iter (map type-tag args) args))
          
;; 获取转换函数
(define (get-coercion type1 type2)
  (get 'coercion (list type1 type2)))

 

练习2.83

先写好integer和real的包

;; 整数包
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "install-rational-package.rkt")
(provide (all-defined-out))

;; 安装整数包
(define (install-integer-package)
  ;; internal procedures
  (define (make-integer x)
    x)
  ;; 升级为有理数
  (define (raise-integer x)
    ((get 'make 'rational) x 1))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'integer x))
  (put 'make 'integer
       (lambda (x) (tag (make-integer x))))
  (put 'raise '(integer)
       raise-integer)
  ;; 判断是否相等
  (put 'equ? '(integer integer)
       (lambda (x y) (= x y)))
  'done)

  ;; 构造函数
(define (make-integer x)
  ((get 'make 'integer) x))
;; 实数包
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "install-complex-package.rkt")
(provide (all-defined-out))

;; 安装实数包
(define (install-real-package)
  ;; internal procedures
  (define (make-real x)
    x)
  ;; 升级为复数
  (define (raise-real x)
    ((get 'make-from-real-imag 'complex) x 0))
  ;; interface to rest of the system
  (define (tag x) (attach-tag 'real x))
  (put 'make 'real
       (lambda (x) (tag (make-real x))))
  (put 'raise '(real)
       raise-real)
  ;; 判断是否相等
  (put 'equ? '(real real)
       (lambda (x y) (= x y)))
  'done)

  ;; 构造函数
(define (make-real x)
  ((get 'make 'real) x))

rational包添加raise函数

;; 升级为实数
(define (raise-rational r)
  ((get 'make 'real) (/ (numer r) (denom r))))
(put 'raise '(rational) raise-rational)

 

练习2.84

类型关系用了hash表来模拟

;; 模拟类型塔
(define levels (hash 'integer 3 'rational 2 'real 1 'complex 0))

;; 带raise的多输入泛型操作
(define (apply-generic-with-raise op . args)
  ;; raise到指定类型
  (define (raise-to type)
    (lambda(arg)
      (define (iter cur)
        (if (equal? type (type-tag cur))
            cur
            (let ((proc (get 'raise (list (type-tag cur)))))
              (if (null? proc)
                  (error "Cannot raise")
                  (iter (proc (contents cur)))))))
      (iter arg)))
  ;; 找到输入参数中最高级类型
  (define (highest-type args)
    (define (iter remains higher)
      (if (null? remains)
          (type-tag higher)
          (let ((arg (car remains)))
            (if (> (hash-ref levels (type-tag arg)) (hash-ref levels (type-tag higher)))
                (iter (cdr remains) arg)
                (iter (cdr remains) arg)))))
    (iter (cdr args) (car args)))
;; 找到参数中最高级类型,把所有参数转换为该类型,寻找对应通用函数
  (let ((changed-proc (raise-to (highest-type args))))
    (let ((changed-args (map changed-proc args)))
      (let ((proc (get op (map type-tag changed-args))))
        (if (null? proc)
            (error "No method for these types")
            (apply proc (map contents changed-args)))))))

 

练习2.85

要求写出一个drop程序,把某个类型尽可能地降级成低级的类型,直到不能转换为止(例如复数3+4i降级成实数,会损失虚部)

关键在于如何判断是否可以转换成低级类型,即是否降级会造成误差,题目给出的方法是,写一个project函数,把一个类型降级,再调用raise提升回原类型,判断得到的数据是否和原来相等,如果相等,就证明降级不会造成误差

首先,在每个类里加上project这个函数

;; 降级为整数
(define (project-rational r)
  ((get 'make 'integer) (round (/ (numer r) (denom r)))))
(put 'project '(rational) project-rational)
;; 降级为有理数
(define (project-real x)
  ((get 'make 'rational) (* x 100000000) 100000000))
(put 'project '(real) project-real)  
;; 降级为实数
(define (project-complex c)
  ((get 'make 'real) (real-part c)))
(put 'project '(complex) project-complex)

最后写出drop函数

;; Exercise 2.85
;; 数据类型降级
#lang racket
(require "apply-generic.rkt")
(require "tag-datum.rkt")
(provide (all-defined-out))

;; 数据降级
(define (apply-drop arg)
  (if (equal? (type-tag arg) 'integer)
      arg
      ;; 尝试降级
      (let ((projected-arg (apply-generic 'project arg)))
        ;; 判断降级后数据,raise后是否等于原数据
        (if (apply-generic 'equ? arg (apply-generic 'raise projected-arg))
            (apply-drop projected-arg)
            arg))))

 

练习2.86

为了不和以前的代码混淆,创建新类new-complex、new-rectangular-complex和new-polar-complex

要注意构造函数不能再用cons,而要改用list,因为(cons (cons 'integer 3) (cons 'integer 3))的结果是((cons 'integer 3) 'integer 3)

很简单,把每个+、-、*、/、sqrt、square之类的操作全部用apply-generic替换,代码如下

;; Exercise 2.86
;; 新复数包,实部和虚部可以用任意数字类型表示
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "install-new-rectangular-package.rkt")
(require "install-new-polar-package.rkt")
(require "apply-generic.rkt")
(provide (all-defined-out))

;; 安装复数子包
(install-new-rectangular-package)
(install-new-polar-package)

;; select
(define (real-part z) (apply-generic 'real-part z))
(define (imag-part z) (apply-generic 'imag-part z))
(define (magnitude z) (apply-generic 'magnitude z))
(define (angle z) (apply-generic 'angle z))

;; 安装新复数包
(define (install-new-complex-package)
  ;; imported procedures from rectangular and polar packages
  (define (make-from-real-imag x y)
    ((get 'make-from-real-imag 'rectangular) x y))
  (define (make-from-mag-ang r a)
    ((get 'make-from-mag-ang 'polar) r a))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag
     (apply-generic 'add (real-part z1) (real-part z2))
     (apply-generic 'add (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (apply-generic 'sub (real-part z1) (real-part z2))
                         (apply-generic 'sub (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (apply-generic 'mul (magnitude z1) (magnitude z2))
                       (apply-generic 'add (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (apply-generic 'div (magnitude z1) (magnitude z2))
                       (apply-generic 'sub (angle z1) (angle z2))))
  ;; 判断复数是否相等
  (define (equ? z1 z2)
    (and (apply-generic 'equ? (real-part z1) (real-part z2)) (apply-generic 'equ? (imag-part z1) (imag-part z2))))
  ;; 判断复数是否为零
  (define (complex-zero? c)
    (and (apply-generic 'zero? (real-part c)) (apply-generic 'zero? (imag-part c))))
  ;; 降级为实数
  (define (project-complex c)
    ((get 'make 'real) (real-part c)))
  ;; interface to rest of the system
  (define (tag z) (attach-tag 'complex z))
  (put 'add '(complex complex)
       (lambda (z1 z2) (tag (add-complex z1 z2))))
  (put 'sub '(complex complex)
       (lambda (z1 z2) (tag (sub-complex z1 z2))))
  (put 'mul '(complex complex)
       (lambda (z1 z2) (tag (mul-complex z1 z2))))
  (put 'div '(complex complex)
       (lambda (z1 z2) (tag (div-complex z1 z2))))
  (put 'make-from-real-imag 'complex
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'complex
       (lambda (r a) (tag (make-from-mag-ang r a))))
  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'equ? '(complex complex) equ?)
  (put 'zero? '(complex) complex-zero?)
  (put 'project '(complex) project-complex)
  'done)

;; 构造函数
(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))
(define (make-complex-from-mag-ang r a)
  ((get 'make-from-mag-ang 'complex) r a))

 

;; Exercise 2.86
;; 新直角坐标复数包,支持任意数字类型
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "apply-generic.rkt")
(provide (all-defined-out))

;; 安装新直角坐标复数包
(define (install-new-rectangular-package)
  ;; internal procedures
  (define (real-part z) (car z))
  (define (imag-part z) (cadr z))
  (define (make-from-real-imag x y) (list x y))
  (define (magnitude z)
    (apply-generic 'square
                   (apply-generic 'add
                                  (apply-generic 'square (real-part z))
                                  (apply-generic 'square (imag-part z)))))
  (define (angle z)
    (apply-generic 'atan (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a) 
    (cons
     (apply-generic 'mul r (apply-generic 'cos a))
     (apply-generic 'mul r (apply-generic 'sin a))))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'rectangular x))
  (put 'real-part '(rectangular) real-part)
  (put 'imag-part '(rectangular) imag-part)
  (put 'magnitude '(rectangular) magnitude)
  (put 'angle '(rectangular) angle)
  (put 'make-from-real-imag 'rectangular 
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'rectangular 
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

;; 构造函数
(define (make-from-real-imag x y)
  ((get 'make-from-real-imag 'rectangular) x y))

 

;; 新极坐标复数包,支持任意数字类型
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "apply-generic.rkt")
(provide (all-defined-out))

;; 安装新极坐标复数包
(define (install-new-polar-package)
  ;; internal procedures
  (define (magnitude z) (car z))
  (define (angle z) (cadr z))
  (define (make-from-mag-ang r a) (list r a))
  (define (real-part z)
    (apply-generic 'mul (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (apply-generic 'mul (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y) 
    (cons (apply-generic 'sqrt (apply-generic 'add (* x x) (* y y)))
          (apply-generic 'atan y x)))
  ;; interface to the rest of the system
  (define (tag x) (attach-tag 'polar x))
  (put 'real-part '(polar) real-part)
  (put 'imag-part '(polar) imag-part)
  (put 'magnitude '(polar) magnitude)
  (put 'angle '(polar) angle)
  (put 'make-from-real-imag 'polar
       (lambda (x y) (tag (make-from-real-imag x y))))
  (put 'make-from-mag-ang 'polar 
       (lambda (r a) (tag (make-from-mag-ang r a))))
  'done)

;; 构造函数
(define (make-from-mag-ang r a)
  ((get 'make-from-mag-ang 'polar) r a))

现在给scheme-number类添加add、sub等函数,以便complex调用

;; 数字包
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "install-rational-package.rkt")
(provide (all-defined-out))

;; 数字包
(define (install-scheme-number-package)
  (define (tag x)
    (attach-tag 'scheme-number x))
  ;; 判断数字是否为0
  (define (number-zero? n)
    (= n 0))
  (put 'add '(scheme-number scheme-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(scheme-number scheme-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(scheme-number scheme-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(scheme-number scheme-number)
       (lambda (x y) (tag (/ x y))))
  (put 'square '(scheme-number)
       (lambda (x) (* x x)))
  (put 'sqrt '(scheme-number)
       (lambda (x) (sqrt x)))
  (put 'sin '(scheme-number)
       (lambda (x) (sin x)))
  (put 'cos '(scheme-number)
       (lambda (x) (cos x)))
  (put 'atan '(scheme-number)
       (lambda (x) (atan x)))
  (put 'make 'scheme-number
       (lambda (x) (tag x)))
  ;; 判断数字是否相等
  (put 'equ? '(scheme-number scheme-number) =)
  (put 'zero? '(scheme-number) number-zero?)
  ;; 指数计算
  (put 'exp '(scheme-number scheme-number)
       (lambda (x y) (tag (expt x y))))
  'done)

;; 构造函数
(define (make-scheme-number x)
  ((get 'make 'scheme-number) x))

写一个代码测试一下

(define c1 (make-complex-from-real-imag (make-scheme-number 3) (make-scheme-number 4)))
(define c2 (make-complex-from-real-imag (make-scheme-number 7) (make-scheme-number 5)))
(apply-generic 'add c1 c2)

输出

 

练习2.87

;; 判断该项是否为0
(define (=zero? n1) (apply-generic 'zero? n1))

 

练习2.88

减法可以转换为加法来做,只要给每个代数包加上一个求负数的函数就可以

在多项式包里增加减法

;; 多项式减法
(define (sub-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
    (make-poly (variable p1)
               (sub-terms (term-list p1)
                          (term-list p2)))
    (error "Polys not in same var -- SUB-POLY"
           (list p1 p2))))
(define (sub-terms L1 L2)
  ;; 将多项式的一项系数取负
  (define (negation-term term)
    (list (order term) (apply-generic 'negation (coeff term))))
  (add-terms L1 (map negation-term L2)))

(put 'sub '(polynomial polynomial) 
     (lambda (p1 p2) (tag (sub-poly p1 p2))

举个例子,在scheme-number包里增加求负数的方法

;; 求负数
(put 'negation '(scheme-number)
     (lambda (x) (tag (- x))))

 

练习2.89

用稠密表示法,系数的结构很简单,一个list就可以搞定,从0阶开始排列,然后重写加法、减法和乘法,整个类的代码如下

;; 多项式包,稠密表示法
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "apply-generic.rkt")
(require "install-polynomial-parse-package.rkt")
(provide (all-defined-out))

(define (install-polynomial-dense-package)
  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  ;; 返回稀疏表示法的稀疏list
  (define (parse-terms p)
    (define (iter cur remains res)
      (if (null? remains)
          res
          (iter (+ cur 1) (cdr remains) (cons (list cur (car remains)) res))))
    (iter 0 p null))
  ;; 稠密转稀疏
  (define (dense-to-parse p)
    (let ((content (contents p)))
      (make-polynomial-parse (variable content) (parse-terms (term-list content)))))
  ;; 判断是否是同一变量
  (define (same-variable? x y)
    (equal? x y))
  ;; 多项式加法
  (define (add-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (make-poly (variable p1)
                 (add-terms (term-list p1)
                            (term-list p2)))
      (error "Polys not in same var -- ADD-POLY"
             (list p1 p2))))
  ;; 多项式乘法
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))
  ;; 多项式减法
  (define (sub-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (sub-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))
  ;; term-list
  (define (sub-terms L1 L2)
    ;; 将多项式的一项系数取负
    (define (negation-term term)
      (apply-generic 'sub 0 term))
    (add-terms L1 (map negation-term L2)))
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (cons (apply-generic 'add (first-term L1) (first-term L2))
                 (add-terms (rest-terms L1) (rest-terms L2))))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) (cons 0 L2)))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (map (lambda (x) (apply-generic 'mul x t1)) L)))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial-dense p))
  (put 'add '(polynomial-dense polynomial-dense) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial-dense polynomial-dense) 
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'sub '(polynomial-dense polynomial-dense) 
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put 'make 'polynomial-dense
       (lambda (var terms) (tag (make-poly var terms))))
  (put 'coercion '(polynomial-dense polynomial-parse) dense-to-parse)
  'done)

;; 构造函数
(define (make-polynomial-dense variable term-list)
  ((get 'make 'polynomial-dense) variable term-list))

(install-polynomial-dense-package)

 

练习2.90

把原来的多项式包改一下标签和包名,变为稀疏指数包,再和练习2.89里的稠密多项式包一起作为多项式包的两个子包

;; 多项式包,稀疏表示法
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "apply-generic.rkt")
(provide (all-defined-out))

(define (install-polynomial-parse-package)
  ;; internal procedures
  ;; representation of poly
  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  ;; 判断是否是同一变量
  (define (same-variable? x y)
    (equal? x y))
  ;; 多项式加法
  (define (add-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (make-poly (variable p1)
                 (add-terms (term-list p1)
                            (term-list p2)))
      (error "Polys not in same var -- ADD-POLY"
             (list p1 p2))))
  ;; 多项式乘法
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))
  ;; 多项式减法
  (define (sub-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (make-poly (variable p1)
                 (sub-terms (term-list p1)
                            (term-list p2)))
      (error "Polys not in same var -- SUB-POLY"
             (list p1 p2))))
  ;; term-list
  (define (sub-terms L1 L2)
    ;; 将多项式的一项系数取负
    (define (negation-term term)
      (list (order term) (apply-generic 'negation (coeff term))))
    (add-terms L1 (map negation-term L2)))
  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))
  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial-parse p))
  (put 'add '(polynomial-parse polynomial-parse) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial-parse polynomial-parse) 
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'sub '(polynomial-parse polynomial-parse) 
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  (put 'make 'polynomial-parse
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

;; 构造函数
(define (make-polynomial-parse variable term-list)
  ((get 'make 'polynomial-parse) variable term-list))

(define (add n1 n2) (apply-generic 'add n1 n2))
(define (mul n1 n2) (apply-generic 'mul n1 n2))
;; 判断该项是否为0
(define (=zero? n1) (apply-generic 'zero? n1))

(install-polynomial-parse-package)

多项式包除了提供一些对外的接口,还要处理两个不同表示法的多项式数据进行计算的情况,一个思路是,把两个参数转换为同一个表示法,从稠密转稀疏更加简单一些,所以我用了这种,在稠密表示法中增加一个类型转换方法

;; 返回稀疏表示法的稀疏list
(define (parse-terms p)
  (define (iter cur remains res)
    (if (null? remains)
        res
        (iter (+ cur 1) (cdr remains) (cons (list cur (car remains)) res))))
  (iter 0 p null))
;; 稠密转稀疏
(define (dense-to-parse p)
  (make-polynomial-parse (variable p) (parse-terms p)))

(put 'coercion '(polynomial-dense polynomial-parse) dense-to-parse)

多项式包如下

;; 多项式包
#lang racket
(require (file "../2.4.3 Data-Directed Programming and Additivity/funcs-table.rkt"))
(require "tag-datum.rkt")
(require "apply-generic.rkt")
(require "install-polynomial-parse-package.rkt")
(require "install-polynomial-dense-package.rkt")
(provide (all-defined-out))

(define (install-polynomial-package)
  ;; internal procedures
  ;; 多项式加法
  (define (add-poly p1 p2) (apply-generic 'add p1 p2))
  ;; 多项式乘法
  (define (mul-poly p1 p2) (apply-generic 'mul p1 p2))
  ;; 多项式减法
  (define (sub-poly p1 p2) (apply-generic 'sub p1 p2))
  ;; interface to rest of the system
  (put 'add '(polynomial polynomial) 
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial) 
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put 'sub '(polynomial polynomial) 
       (lambda (p1 p2) (tag (sub-poly p1 p2))))
  'done)

(define (tag p) (attach-tag 'polynomial p))
;; 构造函数
(define (make-polynomial-from-dense variable term-list)
  (tag ((get 'make 'polynomial-dense) variable term-list)))
(define (make-polynomial-from-parse variable term-list)
  (tag ((get 'make 'polynomial-parse) variable term-list)))

(install-polynomial-package)

测试一下

(require "install-polynomial-package.rkt")
(require "install-scheme-number-package.rkt")
(require "apply-generic.rkt")

(define n1 (make-scheme-number 1))
(define n2 (make-scheme-number 2))
(define n3 (make-scheme-number 3))
(define n4 (make-scheme-number 4))
  
(define p1 (make-polynomial-from-dense 'x (list n1 n3 n4)))
(define p2 (make-polynomial-from-dense 'x (list n1 n3 n2)))
(define p3 (make-polynomial-from-parse 'x (list
                                           (list 100 n3)
                                           (list 3 n4)
                                           (list 1 n1))))
(define p4 (make-polynomial-from-parse 'x (list
                                           (list 5 n3)
                                           (list 3 n1)
                                           (list 1 n1))))

(display "测试稠密表示法\n")
(apply-generic 'add p1 p2)
(apply-generic 'sub p1 p2)
(apply-generic 'mul p1 p2)

(display "测试稀疏表示法\n")
(apply-generic 'add p3 p4)
(apply-generic 'sub p3 p4)
(apply-generic 'mul p3 p4)

(display "测试混合类型计算\n")
(define p5 (make-polynomial-from-dense 'x (list n2 n3 n4)))
(define p6 (make-polynomial-from-parse 'x (list
                                           (list 4 n3)
                                           (list 2 n4)
                                           (list 1 n1))))
(apply-generic 'add p5 p6)
(apply-generic 'sub p5 p6)
(apply-generic 'mul p5 p6)

《SICP》习题第2章_第6张图片

《SICP》习题第2章_第7张图片

《SICP》习题第2章_第8张图片

 

练习2.91

在稀疏包插入下面的代码,当然还要在稀疏包和多项式包里都加上各种put,略去不写

;; 多项式除法
(define (div-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (let ((res (div-terms (term-list p1) (term-list p2))))
        (list (tag (make-poly (variable p1)
                              (car res)))
              (tag (make-poly (variable p2)
                              (cadr res)))))
      (error "Polys not in same var -- DIV-POLY"
             (list p1 p2))))
;; 除法
(define (div-terms L1 L2)
    (if (empty-termlist? L1)
      (list (the-empty-termlist) (the-empty-termlist))
      (let ((t1 (first-term L1))
            (t2 (first-term L2)))
        (if (> (order t2) (order t1))
            (list (the-empty-termlist) L1)
            (let ((new-c (apply-generic 'div (coeff t1) (coeff t2)))
                  (new-o (- (order t1) (order t2))))
              (let ((rest-of-result
                     (div-terms
                      (sub-terms
                       L1
                       (mul-terms L2 (list (list new-o new-c))))
                      L2)
                     ))
                (list (adjoin-term
                       (list new-o new-c)
                       (car rest-of-result))
                      (cadr rest-of-result))
                ))))))

 

练习2.92

题目的意思是,给定一个变量的优先级序列,当低优先级变量多项式和高优先级多项式相加时,低优先级变量就当做常量来处理

做了很久,怎么写都觉得不优雅,算了直接发

这里只用稀疏表示法来做

首先,给出个判断变量优先级的模块,可以比较两个变量的优先级高低

;; 判断变量优先级
#lang racket
(provide (all-defined-out))

;; 优先级列表
(define priority (make-hash (list (cons 'x 0) (cons 'y 1) (cons 'z 2))))

;; 判断优先级
(define (higher-priority? x y)
  (let ((n1 (hash-ref priority x))
        (n2 (hash-ref priority y)))
    (> n1 n2)))

然后,当某个变量多项式因为优先级低降级为系数,就需要处理多项式和数字相加的情况,因此数字包里需要增加一个转换为多项式的代码

;; 转换为多项式
(put 'to-polynomial '(symbol scheme-number)
     (lambda (var x) (make-polynomial-parse var (list (list 0 x)))))

现在来修改稀疏包里的加法函数,需要修改两个地方:其一,之前加法判断两个变量不相同就报错,现在修改为,两个变量不同,判断优先级,将低优先级的变量多项式转化为系数;其二,要支持多项式和数字的相加

对于其一,修改add-poly代码很容易解决

对于其二, 修改add-poly里的代码肥肠难做到松耦合,因为多项式在调用到add-poly的时候,已经去掉了tag,所以要判断加法的两个参数类型是多项式还是数字,所以我给数字包增加了一个标记,在数字包里加入这样一个函数,然后就可以通过调用(apply-generic 'isNumber? n)判断n是不是数字了,所有实现这个标记的数字包都可以在多项式包里作为系数使用

;; 数字标记
(put 'isNumber? 'scheme-number true)

系数有可能是多项式,那么zero?的代码也要修改,兼容多项式的判断

;; 判断该项是否为0
(define (=zero? n1)
  (if (isNumber? n1)
      (apply-generic 'zero? n1)
      (null? (term-list n1))))

最后add的代码是这样的

add-poly,判断两个多项式的变量是否相同,如果相同直接调用add-terms,变量不同,把低优先级的多项式变为系数,在调用add-poly

add-terms,没有变化,改变的是调用的add函数

add,原来add是直接apply-generic,现在改一下,让他支持多项式和数字的相加,方法是把数字转换为多项式再调用add-poly计算

;; 多项式加法
(define (add-poly p1 p2)
  (let ((var1 (variable p1))
        (var2 (variable p2)))
    (if (same-variable? var1 var2)
        (make-poly var1
                   (add-terms (term-list p1)
                              (term-list p2)))
        ;; 如果变量不同,判断优先级
        (if (higher-priority? var1 var2)
            (add-poly p1 (make-poly var1 (list (list 0 p2))))
            (add-poly (make-poly var2 (list (list 0 p1))) p2))))) 
(define (add-terms L1 L2)
   (cond ((empty-termlist? L1) L2)
         ((empty-termlist? L2) L1)
         (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))
;; 加法计算
;; 如果两项均为数字,直接调用该数字类型的加法
;; 如果是多项式和数字,则数字升级为多项式,进行加法计算
;; 如果是两个多项式,直接调用add-poly
(define (add n1 n2)
  (cond ((and (isNumber? n1) (isNumber? n2)) (apply-generic 'add n1 n2))
        ((isNumber? n1) (tag (add-poly (contents (apply-generic 'to-polynomial (variable n2) n1)) n2)))
        ((isNumber? n2) (tag (add-poly n1 (contents (apply-generic 'to-polynomial (variable n1) n2)))))
        (else (add-poly n1 n2))))
;; 判断是否是数字
(define (isNumber? x)
  (let ((flag (get 'isNumber? (type-tag x))))
    (not (null? flag))))

乘法照着加法的方法类似地做,不再多说

;; 多项式乘法
(define (mul-poly p1 p2)
  (let ((var1 (variable p1))
        (var2 (variable p2)))
    (if (same-variable? var1 var2)
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (if (higher-priority? var1 var2)
            (mul-poly p1 (make-poly var1 (list (list 0 p2))))
            (mul-poly (make-poly var2 (list (list 0 p1))) p2)))))
(define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
;; 乘法计算
;; 如果两个都是数字,调用apply-generic
;; 如果是多项式和数字,把数字变为多项式计算
;; 如果是两个多项式,直接调用mul-poly
(define (mul n1 n2)
  (cond ((and (isNumber? n1) (isNumber? n2)) (apply-generic 'mul n1 n2))
        ((isNumber? n1) (tag (mul-poly (contents (apply-generic 'to-polynomial (variable n2) n1)) n2)))
        ((isNumber? n2) (tag (mul-poly n1 (contents (apply-generic 'to-polynomial (variable n1) n2)))))
        (else (mul-poly n1 n2))))

测试一下

(display "测试多变量\n")
(define p9 (make-polynomial-from-parse 'x (list
                                           (list 5 n1)
                                           (list 0 n-1))))
(define p10 (make-polynomial-from-parse 'y (list
                                            (list 2 n1)
                                            (list 0 n-1))))
(apply-generic 'add p9 p10)
(apply-generic 'mul p9 p10)

《SICP》习题第2章_第9张图片

 

练习2.93

要把rational包里的*、+等替换为apply-generic

(define (numer x) (car x))
(define (denom x) (cadr x))
(define (make-rat n d)
  (list n d))
;; 计算
(define (add x y) (apply-generic 'add x y))
(define (mul x y) (apply-generic 'mul x y))
(define (add-rat x y)
  (make-rat (add (mul (numer x) (denom y))
                 (mul (numer y) (denom x)))
            (mul (denom x) (denom y))))

测试

(define n1 (make-scheme-number 1))
(define p1 (make-polynomial-parse 'x (list
                                      (list 2 n1)
                                      (list 0 n1))))
(define p2 (make-polynomial-parse 'x (list
                                      (list 3 n1)
                                      (list 0 n1))))
(define rf (make-rational p2 p1))
(apply-generic 'add rf rf)

输出

《SICP》习题第2章_第10张图片

 

练习2.94

现在给稀疏包增加一个化简的代码

;; 求公因子
(define (gcd-poly p1 p2)
(if (same-variable? (variable p1) (variable p2))
    (make-poly (variable p1)
               (gcd-terms (term-list p1)
                          (term-list p2)))
    (error "Polys not in same var -- DIV-POLY"
           (list p1 p2))))  
(define (gcd-terms a b)
  ;; 求余
  (define (remainder-terms a b)
    (cadr (div-terms a b)))
  (if (empty-termlist? b)
      a
      (gcd-terms b (remainder-terms a b))))

(put 'greatest-common-divisor
     '(polynomial-parse polynomial-parse)
     (lambda (p1 p2) (tag (gcd-poly p1 p2))))

测试

(define p3 (make-polynomial-parse 'x (list
                                      (list 4 (make-scheme-number 1))
                                      (list 3 (make-scheme-number -1))
                                      (list 2 (make-scheme-number -2))
                                      (list 1 (make-scheme-number 2)))))
(define p4 (make-polynomial-parse 'x (list
                                      (list 3 (make-scheme-number 1))
                                      (list 1 (make-scheme-number -1)))))
(apply-generic 'greatest-common-divisor p3 p4) 

代码给出的答案是x-x^2

 

练习2.95

撰写测试代码

(define p5 (make-polynomial-parse 'x (list
                                      (list 2 (make-scheme-number 1))
                                      (list 1 (make-scheme-number -2))
                                      (list 0 (make-scheme-number 1)))))
(define p6 (make-polynomial-parse 'x (list
                                      (list 2 (make-scheme-number 11))
                                      (list 0 (make-scheme-number 7)))))
(define p7 (make-polynomial-parse 'x (list
                                      (list 1 (make-scheme-number 13))
                                      (list 0 (make-scheme-number 5)))))
(define p8 (apply-generic 'mul p5 p6))
(define p9 (apply-generic 'mul p5 p7))
(apply-generic 'greatest-common-divisor p8 p9) 

结果肥肠诡异,但是我们把那三个分数都乘以169/1458,就可以得到1,-2,1

《SICP》习题第2章_第11张图片

在gcd-terms代码中加入display查看每次迭代做除法的两个数,太长只贴出一部分

《SICP》习题第2章_第12张图片

《SICP》习题第2章_第13张图片

 

练习2.96

a.

为了防止简化后的系数出现分数,在计算公因子的时候,每次除法都给被除数乘上一个整数因子,以保证结果中不会有分数出现

举例来说,现在有多项式P和Q,O1和O2是他们的最高阶,c是Q的最高阶项系数,在做多项式除法前,将P乘以系数c^{1+O1 -O2}, 之后再做除法就不会有分数系数产生

现在给数字包加一个求factor的函数

;; 返回pseudo的因子
(put 'pseudo-factor '(scheme-number scheme-number scheme-number)
     (lambda (c o1 o2)
       (tag (expt c (+ 1 o1 o2)))))

修改gcd

(define (gcd-terms a b)
    ;; pseudoremainder-terms,保证结果不出现分数
    (define (pseudoremainder-terms a b)
      (let ((t1 (first-term a))
            (t2 (first-term b)))
          (let ((c (coeff t2))
                (o1 (order t1))
                (o2 (order t2)))
            (let ((factor (apply-generic 'pseudo-factor c o1 o2)))
              (cadr (div-terms (map
                                (lambda (x)
                                  (make-term (order x)
                                             (apply-generic 'mul (coeff x) factor)))
                                a)
                               b))))))
    (if (empty-termlist? b)
        a
        (gcd-terms b (pseudoremainder-terms a b))))

再次运行测试代码,得到的结果

《SICP》习题第2章_第14张图片

确实没有分数

b.

因为乘了很多个整数因子,所以得到的系数变得非常大,现在要将这几个系数化简,就是要先求这几个数字的最大公约数,然后都除以最大公约数

首先在数字包加一个求最大公约数的接口

;; 求一组数的最大公约数
(put 'gcd 'scheme-number
     (lambda (L)
       (let ((numbers (map contents L)))
         (tag (apply gcd numbers)))))

然后在稀疏包里添加化简系数的代码,把原理的gcd-terms改成gcd-terms-iter

;; 化简后的gcd
(define (gcd-terms a b)
  (simplify-terms (gcd-terms-iter a b)))
;; 系数化简
(define (simplify-terms a)
  (if (empty-termlist? a)
      a
      (let ((coeffs (map coeff a)))
        (let ((g ((get 'gcd (type-tag (car coeffs))) coeffs)))
          (map (lambda (t) (make-term (order t) (apply-generic 'div (coeff t) g))) a)))))

再次运行结果

《SICP》习题第2章_第15张图片

 

练习2.97

a.

现在我们要化简两个多项式P和Q,书上给出的方法是首先求出GCD,再分别用pseudo的方法,得到P除GCD、Q除GCD的结果,最后化简系数

我很费解,如果GCD都已经是化简过的了,为嘛还要这顿操作,直接除就不会有分数出现啊,算了还是按照书上说的来

;; 两个多项式化简
(define (reduce-poly p1 p2)
  (if (same-variable? (variable p1) (variable p2))
      (let ((res (reduce-terms (term-list p1) (term-list p2))))
        (list (tag (make-poly (variable p1)
                              (car res)))
              (tag (make-poly (variable p2)
                              (cadr res)))))
      (error "Polys not in same var -- REDUCE-POLY"
             (list p1 p2))))
(define (reduce-terms a b)
  ;; 系数列表中每个系数乘以或除以一个因子
  (define (factor-terms a factor op)
    (map (lambda (t) (make-term (order t) (apply-generic op (coeff t) factor))) a))
  (let ((g (gcd-terms a b)))
    (let ((factor1 (apply-generic 'pseudo-factor (coeff (first-term g)) (order (first-term a)) (order (first-term g))))
          (factor2 (apply-generic 'pseudo-factor (coeff (first-term g)) (order (first-term b)) (order (first-term g)))))
      (list
       (factor-terms (car (div-terms (factor-terms a factor1 'mul) g)) factor1 'div)
       (factor-terms (car (div-terms (factor-terms b factor2 'mul) g)) factor2 'div)))))

(put 'reduce '(polynomial-parse polynomial-parse)
     (lambda (p1 p2) (reduce-poly p1 p2)))

现在再运行一下测试代码

(define p5 (make-polynomial-parse 'x (list
                                      (list 2 (make-scheme-number 1))
                                      (list 1 (make-scheme-number -2))
                                      (list 0 (make-scheme-number 1)))))
(define p6 (make-polynomial-parse 'x (list
                                      (list 2 (make-scheme-number 11))
                                      (list 0 (make-scheme-number 7)))))
(define p7 (make-polynomial-parse 'x (list
                                      (list 1 (make-scheme-number 13))
                                      (list 0 (make-scheme-number 5)))))
(define p8 (apply-generic 'mul p5 p6))
(define p9 (apply-generic 'mul p5 p7))

(apply-generic 'reduce p8 p9)

化简的结果,和练习2.95里的式子是一致的

b.

在数字包加约分代码

;; 两个数约分
(put 'reduce '(scheme-number scheme-number)
     (lambda (n d)
       (let ((g (gcd n d)))
         (list (/ n g) (/ d g)))))

有理数包,修改make函数

(define (make-rat n d)
  (apply-generic 'reduce n d))

测试

p_1=x+1,p_2=x^3-1,p_3=x,p_4=x^2-1

rf_1+rf_2=\frac{x^3+2x^2+3x+1}{x^4+x^3-x-1}

 

(define p11 (make-polynomial-parse 'x (list (list 1 (make-scheme-number 1)) (list 0 (make-scheme-number 1)))))
(define p12 (make-polynomial-parse 'x (list (list 3 (make-scheme-number 1)) (list 0 (make-scheme-number -1)))))
(define p13 (make-polynomial-parse 'x (list (list 1 (make-scheme-number 1)))))
(define p14 (make-polynomial-parse 'x (list (list 2 (make-scheme-number 1)) (list 0 (make-scheme-number -1)))))

(define rf1 (make-rational p11 p12))
(define rf2 (make-rational p13 p14))

(apply-generic 'add rf1 rf2)

《SICP》习题第2章_第16张图片

虽然全都变负了,结果还是很正确的

你可能感兴趣的:(SICP,SICP,SICP习题)