本人做的SICP习题第3章，如有错误请指正，用的解释器是Racket
练习3.1
;; 累加器
(define (make-accumulator initial)
(lambda (x)
(let ((sum (+ initial x)))
(set! initial (+ initial x))
sum)))
练习3.2
;; 监控器
(define (make-monitored f)
(let ((cnt 0))
(define (dispatch op)
(cond ((equal? op "how-many-calls") cnt)
((equal? op "reset-count") (set! cnt 0))
(else
(begin
(set! cnt (+ cnt 1))
(f op)))))
dispatch))
练习3.3
;; 账户
(define (make-account balance password)
;; 判断密码是否正确
(define (password-correct? pass)
(equal? pass password))
(define (withdraw pass amount)
(if (password-correct? pass)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds")
"Incorrect password"))
(define (deposit pass amount)
(if (password-correct? pass)
(begin (set! balance (+ balance amount))
balance)
"Incorrect password"))
(define (dispatch m)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT"
m))))
dispatch)
练习3.4
;; 账户
(define (make-account balance password)
(let ((cnt 0))
;; 判断密码是否正确
(define (password-correct? pass)
(if (equal? pass password)
true
(begin
(set! cnt (+ cnt 1))
(if (> cnt 6)
(call-the-cops)
false)
false)))
;; 叫警察
(define (call-the-cops)
(display "Call the cops\n"))
(define (withdraw pass amount)
(if (password-correct? pass)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds")
"Incorrect password"))
(define (deposit pass amount)
(if (password-correct? pass)
(begin (set! balance (+ balance amount))
balance)
"Incorrect password"))
(define (dispatch m)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT"
m))))
dispatch))
练习3.5
先写生成指定范围随机数的代码，racket和scheme略有不同
;; 生成随机数
#lang racket
(provide (all-defined-out) )
;; 生成指定范围的随机数
(define (random-in-range low high)
(let ((ranges (- high low)))
(+ low (* (random) ranges))))蒙特卡洛测试代码，顺便写一个小测试
;; Exercise 3.5
;; 蒙特卡罗法计算积分
#lang racket
(require "random-in-range.rkt")
;; 计算积分
(define (estimate-integral x1 x2 y1 y2 P)
;; 蒙特卡洛测试
(define (monte-carlo trials)
(define (iter trials-remains cnt)
(cond ((= trials-remains 0) cnt)
((P (random-in-range x1 x2) (random-in-range y1 y2))
(iter (- trials-remains 1) (+ cnt 1)))
(else (iter (- trials-remains 1) cnt))))
(/ (iter trials 0) trials))
(* 1.0 (* (* (- x2 x1) (- y2 y1)) (monte-carlo 100000))))
;; 测试
;; 判断点是否落在f=x^2曲线下方
(define (test x y)
(<= y (* x x)))
(estimate-integral 2 3 0 20 test)
练习3.6
我的racket没有rand-update，所以用一个递增的东西模拟一下
;; Exercise 3.6
;; 可以重置的rand生成
#lang racket
;; 带重置随机数生成
(define (rand-with-reset random-init)
(let ((x random-init))
(define (generate)
(set! x (rand-update x))
x)
(define (reset new-value)
(set! x new-value))
(define (dispatch op)
(cond ((equal? op 'generate) generate)
((equal? op 'reset) reset)
(else ("Wrong Operation"))))
dispatch))
;; 模拟rand-update
(define (rand-update x)
(+ x 1))
(define generator (rand-with-reset 0))
((generator 'generate))
((generator 'generate))
((generator 'reset) 7)
((generator 'generate))
((generator 'generate))测试一下
练习3.7
先改一下之前的account代码，原来把校验密码放在了每个函数里，现在放在dispatch
;; 账户
(define (make-account balance password)
(let ((cnt 0))
;; 判断密码是否正确
(define (password-correct? pass)
(if (equal? pass password)
true
(begin
(set! cnt (+ cnt 1))
(if (> cnt 6)
(call-the-cops)
false)
false)))
;; 叫警察
(define (call-the-cops)
(display "Call the cops\n"))
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(begin (set! balance (+ balance amount))
balance))
(define (dispatch m pass)
(if (password-correct? pass)
(cond ((eq? m 'withdraw) withdraw)
((eq? m 'deposit) deposit)
(else (error "Unknown request -- MAKE-ACCOUNT"
m)))
("Incorrect password")))
dispatch))make-joint就很简单了
;; 连接账户
(define (make-joint acc password joint-password)
(define (dispatch op pass)
(if (equal? pass joint-password)
(acc op password)
(error "Incorrect password")))
dispatch)
练习3.8
;; 测试
(define f
(lambda (first)
(set! f (lambda (second) 0))
first))
练习3.9
递归
迭代
练习3.10
执行 (W1 50) 时
执行 (W1 50) 后
练习3.11
(define acc (make-account 50))
((acc 'deposit) 40)
这一步其实执行了两个过程对象
((acc 'withdraw) 60)
类似于上一步
执行完毕后的balance
练习3.12
使用append，(cdr x)是(b)
使用append!，(cdr x)是(b,c,d)
因为append是把x、y的元素一个一个重新拼接生成list，而append!是直接修改x的尾元素的cdr指针，所以x元素也被改变了
练习3.13
(last-pair z)会陷入死循环
练习3.14
v是(a)，w是(d,c,b,a)
练习3.15
练习3.16
最简单的list，返回值为3
返回值为4
返回值为7
死循环
练习3.17
racket和书上的语法有点不一样，list、car、cons、cdr这些出来的都是不可变的，如果要可变需要使用m开头的关键字，比如mlist
;; Exercise 3.17
;; 计算 list 中的 pair 个数
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
;; 计算 pair 个数
(define (count-pairs l)
(let ((counted null))
(define (count-iter remains)
(if (and (mpair? remains) (not (member remains counted)))
(
begin
(set! counted (cons remains counted))
(+ 1 (count-iter (mcar remains)) (count-iter (mcdr remains)))
)
0))
(count-iter l)))
;; Exercise 3.16 中的错误代码
(define (error-count-pairs x)
(if (not (mpair? x))
0
(+ (error-count-pairs (mcar x))
(error-count-pairs (mcdr x))
1)))
;; 测试
(define p1 (mcons 'c null))
(define p2 (mcons 'b p1))
(define p3 (mcons 'a p2))
(count-pairs p3)
(error-count-pairs p3)
(newline)
(set! p3 (mcons p1 p2))
(count-pairs p3)
(error-count-pairs p3)
(newline)
(set! p2 (mcons p1 p1))
(set! p3 (mcons p2 p2))
(count-pairs p3)
(error-count-pairs p3)
(newline)
;; 错误的程序会在最后进入死循环
(set! p1 (mcons 'c null))
(set! p2 (mcons 'b p1))
(set! p3 (mcons 'a p2))
(set-mcdr! p1 p3)
(count-pairs p3)
(error-count-pairs p3)
练习3.18
只要保存遍历过的每个节点，发现遍历到重复节点就可以认为列表有环
;; 保存遍历过的节点法
(define (loop1? l)
(let ((counted null))
(define (iter remains)
(cond ((null? remains) #f)
((member (mcar remains) counted) #t)
(else (
begin
(set! counted (cons (mcar remains) counted))
(iter (mcdr remains))))))
(iter l)))测试代码
;; 测试
(define p1 (mcons 'c null))
(define p2 (mcons 'b p1))
(define p3 (mcons 'a p2))
(loop1? p3)
(loop2? p3)
(set! p1 (mcons 'c null))
(set! p2 (mcons 'b p1))
(set! p3 (mcons 'a p2))
(set-mcdr! p1 p3)
(loop1? p3)
(loop2? p3)
练习3.19
算法题里很经典的快慢指针法
;; 快慢指针法
(define (loop2? l)
(define (iter fast slow)
(if (or (null? fast) (null? (mcdr fast)))
#f
(let ((fast-move (mcdr (mcdr fast)))
(slow-move (mcdr slow)))
(if (eq? fast-move slow-move)
#t
(iter fast-move slow-move)))))
(iter l l))
练习3.20
图里省略了global-env中的car、cdr、set-car!、set-cdr!
画的快死了
(define x (cons 1 2))
(define z (cons x x))
(set-car! (cdr z) 17)
(car x)
练习3.21
看一下队列的构造图，一个队列是一个pair，pair的第一个元素是一个list，第二个元素是list的尾元素
所以打印的时候，会先打印出list中的所有元素，再打印尾元素，就成了“((list中所有元素) 尾元素)”这样
为什么最后删除了所有元素，打印出的队列是(() b)？因为这个队列程序删除到最后一个元素的时候，并不会把尾指针也删除掉，而只是删除头指针。毕竟判断空队列只判断头指针是否为null，而有新元素要插入的时候，会把头尾指针都给设置为新元素，这样的做法并不会产生问题
打印队列中所有元素，可以通过头指针把包含所有元素的list取出就可以了
;; 打印队列中所有元素
(define (print-queue q)
(if (empty-queue? q)
(display "空队列")
(front-ptr q)))
练习3.22
;; Exercise 3.22
;; 用local state实现队列
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
;; 构造队列
(define (make-queue)
;; 头尾指针
(let ((front-ptr null)
(rear-ptr null))
;; 判断队列是否为空
(define (empty-queue?)
(null? front-ptr))
;; 获取头元素
(define (front-queue)
(if (empty-queue?)
(error "FRONT called with an empty queue")
(car front-ptr)))
;; 插入新元素
(define (insert-queue! item)
(let ((new-pair (mcons item null)))
(cond ((empty-queue?)
(set! front-ptr new-pair)
(set! rear-ptr new-pair))
(else
(set-mcdr! rear-ptr new-pair)
(set! rear-ptr (mcdr rear-ptr))))))
;; 删除头元素
(define (delete-queue!)
(cond ((empty-queue?)
(error "DELETE! called with an empty queue"))
(else
(set! front-ptr (mcdr front-ptr)))))
;; 打印队列
(define (print-queue)
front-ptr)
(define (dispatch m . params)
(cond ((eq? m 'empty?) (empty-queue?))
((eq? m 'front) (front-queue))
((eq? m 'insert!) (insert-queue! (car params)))
((eq? m 'delete!) (delete-queue!))
((eq? m 'print) (print-queue))
(else (error "错误的操作" m))))
dispatch))
练习3.23
双端队列，最常见的做法，每个节点都包含两个指针，一个指针指向前一个节点，另一个指针指向后一个节点
;; Exercise 3.23
;; 双端队列
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
;; 节点定义
(define (make-node item pre next)
;; 设置前节点
(define (set-pre! p)
(set! pre p))
;; 设置后节点
(define (set-next! n)
(set! next n))
;; dispatch
(define (dispatch m . param)
(cond ((eq? m 'item) item)
((eq? m 'pre) pre)
((eq? m 'next) next)
((eq? m 'set-pre!) (set-pre! (car param)))
((eq? m 'set-next!) (set-next! (car param)))
(else (error "错误的操作" m))))
dispatch)
;; 双端队列
(define (make-deque)
;; 头尾指针
(let ((front-ptr null)
(rear-ptr null))
;; 判断队列是否为空
(define (empty-queue?)
(null? front-ptr))
;; 获取头元素
(define (front-queue)
(car front-ptr))
;; 获取尾元素
(define (rear-queue)
(car rear-ptr))
;; 从头部插入元素
(define (insert-front-queue! item)
(let ((new-node (make-node item null null)))
(cond ((empty-queue?)
(set! front-ptr new-node)
(set! rear-ptr new-node))
(else
(new-node 'set-next! front-ptr)
(front-ptr 'set-pre! new-node)
(set! front-ptr new-node)))))
;; 从尾部插入元素
(define (insert-rear-queue! item)
(let ((new-node (make-node item null null)))
(cond ((empty-queue?)
(set! front-ptr new-node)
(set! rear-ptr new-node))
(else
(new-node 'set-pre! rear-ptr)
(rear-ptr 'set-next! new-node)
(set! rear-ptr new-node)))))
;; 删除头元素
(define (delete-front-queue!)
(cond ((empty-queue?)
(error "DELETE! called with an empty queue"))
(else
(let ((new-front (front-ptr 'next)))
(cond ((null? new-front)
(set! front-ptr null)
(set! rear-ptr null))
(else
(new-front 'set-pre! null)
(set! front-ptr new-front)))))))
;; 删除尾元素
(define (delete-rear-queue!)
(cond ((empty-queue?)
(error "DELETE! called with an empty queue"))
(else
(let ((new-rear (rear-ptr 'pre)))
(cond ((null? new-rear)
(set! rear-ptr null)
(set! front-ptr null))
(else
(new-rear 'set-next! null)
(set! rear-ptr new-rear)))))))
;; 打印队列
(define (print-queue)
(define (iter remains)
(cond ((null? remains)
(newline))
(else
(display (remains 'item))
(display " ")
(iter (remains 'next)))))
(iter front-ptr))
;; dispatch
(define (dispatch m . params)
(cond ((eq? m 'empty?) (empty-queue?))
((eq? m 'front) (front-queue))
((eq? m 'rear) (rear-queue))
((eq? m 'insert-front!) (insert-front-queue! (car params)))
((eq? m 'insert-rear!) (insert-rear-queue! (car params)))
((eq? m 'delete-front!) (delete-front-queue!))
((eq? m 'delete-rear!) (delete-rear-queue!))
((eq? m 'print) (print-queue))
(else (error "错误操作" m))))
dispatch))
练习3.24
;; Exercise 3.24
;; 可自定义键比较函数的 table
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
;; table
(define (make-table same-key?)
(let ((local-table (list '*table*)))
;; 使用 same-key? 做 equal 判断的 assoc
(define (assoc key records)
(cond ((null? records) false)
((same-key? key (mcar (car records))) (car records))
(else (assoc key (cdr records)))))
;; 查找
(define (lookup key)
(let ((record (assoc key (cdr local-table))))
(if record
(mcdr record)
false)))
;; 插入
(define (insert! key value)
(let ((record (assoc key (cdr local-table))))
(if record
(set-mcdr! record value)
(set! local-table (cons (car local-table) (cons (mcons key value) (cdr local-table))))))
'ok)
;; dispatch
(define (dispatch m . params)
(cond ((eq? m 'lookup-proc) (lookup (car params)))
((eq? m 'insert-proc!) (insert! (car params) (cadr params)))
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;; 判断字符是否是同一个字母
(define (character-equal? val1 val2)
(eq? (char-upcase val1) (char-upcase val2)))
;; 测试
(define t1 (make-table character-equal?))
(t1 'insert-proc! #\a 1)
(t1 'insert-proc! #\b 2)
(t1 'lookup-proc #\A)
(t1 'lookup-proc #\B)
(t1 'insert-proc! #\A 0)
(t1 'lookup-proc #\a)
练习3.25
以一个一维表为基础，只不过表里面的value可以是值，也可以是另外一个一维表，这样就构成了一个多维表
;; Exercise 3.25
;; 多维 table
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
;; table
(define (make-table)
(let ((local-table (list '*table*)))
;; 在一维表中查找键对应的值
(define (assoc key records)
(if (pair? records)
(if (eq? key (mcar (car records)))
(car records)
(assoc key (cdr records)))
false))
;; 查找
(define (lookup keys)
;; 递归查找
(define (iter keys records)
;; keys已经全部匹配完毕，records就是查询结果
(if (null? keys)
records
;; 在records中查询第一个键对应的节点
(let ((record (assoc (car keys) records)))
(if record
;; 查询到节点，继续查找下一个键
(iter (cdr keys) (mcdr record))
;; 未查询到，返回false
false))))
(iter keys (cdr local-table)))
;; 插入
(define (insert! keys value)
;; 返回在records中插入新键值对后的新records
(define (iter keys value records)
(if (null? keys)
;; 到达插入值的位置
value
;; 在records查找第一个键
(let ((record (assoc (car keys) records)))
(if record
;; records存在第一个键对应的record，处理record并返回处理后的record
(begin
(set-mcdr! record (iter (cdr keys) value (mcdr record)))
records)
;; records中不存在第一个键对应的record，创建新键值对，插入records
(cons (mcons (car keys) (iter (cdr keys) value null)) records)))))
(set! local-table (cons (car local-table) (iter keys value (cdr local-table))))
'ok)
;; dispatch
(define (dispatch m . params)
(cond ((eq? m 'lookup-proc) (lookup (car params)))
((eq? m 'insert-proc!) (insert! (car params) (cadr params)))
(else (error "Unknown operation -- TABLE" m))))
dispatch))
;; 判断是否是二叉树，用于区分二叉树和值
(define (tree? t)
(procedure? t))写一段代码测试一下
;; 测试
(define t1 (make-table))
(display "测试插入任意多个键的值\n")
(display "插入(a,b)-1\n")
(t1 'insert-proc! (list 'a 'b) 1)
(display "插入(c)-2\n")
(t1 'insert-proc! (list 'c) 2)
(display "查询(a,b)\n")
(t1 'lookup-proc (list 'a 'b))
(display "查询(c)\n")
(t1 'lookup-proc (list 'c))
(display "测试插入分支\n")
(display "插入(a,d)-3\n")
(t1 'insert-proc! (list 'a 'd) 3)
(display "查询(a,b)\n")
(t1 'lookup-proc (list 'a 'b))
(display "查询(a,d)\n")
(t1 'lookup-proc (list 'a 'd))
(display "测试增加键个数\n")
(display "插入(d,e)-5\n")
(t1 'insert-proc! (list 'd 'e) 5)
(display "查询(d,e)\n")
(t1 'lookup-proc (list 'd 'e))
(display "插入(a,b,f,g)-7\n")
(t1 'insert-proc! (list 'a 'b 'f 'g) 7)
(display "查询(a,d)\n")
(t1 'lookup-proc (list 'a 'd))
(display "查询(a,b,f,g)\n")
(t1 'lookup-proc (list 'a 'b 'f 'g))
(display "测试减少键的个数\n")
(t1 'insert-proc! (list 'a 'b 'f) 10)
(t1 'lookup-proc (list 'a 'b 'f))
(t1 'lookup-proc (list 'a 'b 'f 'g))
练习3.26
原来一维表是用list实现的，现在要换成二叉树。在一维表里面插入节点也不能用cons，需要换成二叉树的插入函数
首先要构建一个二叉树，key就用整数，简单点，没啥好说的
;; 二叉树
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
(provide (all-defined-out))
;; 节点
(define (make-node key value left right)
;; dispatch
(define (dispatch m . params)
(cond ((eq? m 'key) key)
((eq? m 'value) value)
((eq? m 'left) left)
((eq? m 'right) right)
((eq? m 'set-value!) (set! value (car params)))
((eq? m 'set-left!) (set! left (car params)))
((eq? m 'set-right!) (set! right (car params)))
(else (error "错误节点操作" m))))
dispatch)
;; 二叉树
(define (make-tree)
;; 树里的键值是整数，用一个特大的整数做 dummy
(let ((dummy (make-node 1000000 '*tree* null null)))
;; 插入
(define (insert key value)
(define (iter current)
(if (null? current)
(make-node key value null null)
(let ((cur-key (current 'key)))
(cond ((< key cur-key) (current 'set-left! (iter (current 'left))))
((> key cur-key) (current 'set-right! (iter (current 'right))))
(else (current 'set-value! value)))
current)))
(set! dummy (iter dummy))
dispatch)
;; 查询
(define (lookup key)
(define (iter current)
(if (null? current)
false
(let ((cur-key (current 'key)))
(cond ((< key cur-key) (iter (current 'left)))
((> key cur-key) (iter (current 'right)))
(else (current 'value))))))
(iter dummy))
;; dispatch
(define (dispatch m . params)
(cond ((eq? m 'lookup) (lookup (car params)))
((eq? m 'insert) (insert (car params) (cadr params)))
(else (error "错误二叉树操作" m))))
dispatch))
;; 判断是否是二叉树，用于区分二叉树和值
(define (tree? t)
(procedure? t))再构造用二叉树作为一维表实现的多维表
;; Exercise 3.26
;; 使用二叉树的多维 table
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
(require "binary-tree.rkt")
;; table
(define (make-table)
(let ((local-table (make-tree)))
;; 在二叉树中查找键对应的值
(define (assoc key records)
(if (tree? records)
(records 'lookup key)
false))
;; 查找
(define (lookup keys)
;; 递归查找
(define (iter keys records)
;; keys已经全部匹配完毕，records就是查询结果
(if (null? keys)
records
;; 在records中查询第一个键对应的节点
(let ((record (assoc (car keys) records)))
(if record
;; 查询到节点，继续查找下一个键
(iter (cdr keys) record)
;; 未查询到，返回false
false))))
(iter keys local-table))
;; 插入
(define (insert! keys value)
;; 返回在records中插入新键值对后的新records
(define (iter keys value records)
(cond
;; 到达插入值的位置
((null? keys) value)
;; records是一个二叉树
((tree? records)
;; 在records查找第一个键
(let ((record (assoc (car keys) records)))
(if record
;; records存在第一个键对应的record，处理record并返回处理后的record
(records 'insert (car keys) (iter (cdr keys) value record))
;; records中不存在第一个键对应的record，创建新键值对，插入records
(records 'insert (car keys) (iter (cdr keys) value null)))))
;; records是一个普通的值
(else
((make-tree) 'insert (car keys) (iter (cdr keys) value null)))))
(set! local-table (iter keys value local-table))
'ok)
;; dispatch
(define (dispatch m . params)
(cond ((eq? m 'lookup-proc) (lookup (car params)))
((eq? m 'insert-proc!) (insert! (car params) (cadr params)))
(else (error "Unknown operation -- TABLE" m))))
dispatch))测试一下
;; 测试
(define t1 (make-table))
(display "测试插入任意多个键的值\n")
(display "插入(1,2)-a\n")
(t1 'insert-proc! (list 1 2) 'a)
(display "插入(3)-b\n")
(t1 'insert-proc! (list 3) 'b)
(display "查询(1,2)\n")
(t1 'lookup-proc (list 1 2))
(display "查询(3)\n")
(t1 'lookup-proc (list 3))
(display "测试插入分支\n")
(display "插入(1,4)-c\n")
(t1 'insert-proc! (list 1 4) 'c)
(display "查询(1,2)\n")
(t1 'lookup-proc (list 1 2))
(display "查询(1,4)\n")
(t1 'lookup-proc (list 1 4))
(display "测试增加键个数\n")
(display "插入(3 5)-d\n")
(t1 'insert-proc! (list 3 5) 'd)
(display "查询(3,5)\n")
(t1 'lookup-proc (list 3 5))
(display "插入(1,2,8,9)-e\n")
(t1 'insert-proc! (list 1 2 8 9) 'e)
(display "查询(1,4)\n")
(t1 'lookup-proc (list 1 4))
(display "查询(1,2,8,9)\n")
(t1 'lookup-proc (list 1 2 8 9))
(display "测试减少键的个数\n")
(t1 'insert-proc! (list 1 2 8) 's)
(t1 'lookup-proc (list 1 2 8))
(t1 'lookup-proc (list 1 2 8 9))
练习3.27
定义好memoize和memo-fib函数后的环境，table的dispatch函数体部分省略
求解(memo-fib 3)，从图里可以看到，用memoize可以避免对同一x的重复求解，所以求解fib n只需要把0~n每个数字求解一次就可以，所以复杂度为
不能直接用(memoize fib)，这样计算(memo-fib 3)的时候调用的是(fib 2)和(fib 1)，就不再经过memoize，仍然会有重复计算，复杂度是指数级的
练习3.28
需要执行仿真程序，需要把书后面几页的那些用于仿真的代码都敲下来
日程表的实现
;; 仿真
#lang racket
(provide (all-defined-out))
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
(require (file "../3.3.2 Representing Queues/queue.rkt"))
(require "wire.rkt")
;; 时间片，由时间点和动作队列组成
(define (make-time-segment time queue)
(cons time queue))
(define (segment-time s) (car s))
(define (segment-queue s) (cdr s))
;; 日程表，由当前时间点和时间序列组成
(define (make-agenda) (mlist 0))
(define (current-time agenda) (mcar agenda))
(define (set-current-time! agenda time)
(set-mcar! agenda time))
(define (segments agenda) (mcdr agenda))
(define (set-segments! agenda segments)
(set-mcdr! agenda segments))
(define (first-segment agenda) (mcar (segments agenda)))
(define (rest-segments agenda) (mcdr (segments agenda)))
(define (empty-agenda? agenda)
(null? (segments agenda)))
;; 向日程表中插入一个新动作
(define (add-to-agenda! time action agenda)
;; 判断插入时间是否在时间序列之前
(define (belongs-before? segments)
(or (null? segments)
(< time (segment-time (mcar segments)))))
;; 创建新时间序列
(define (make-new-time-segment time action)
(let ((q (make-queue)))
(insert-queue! q action)
(make-time-segment time q)))
;; 向时间序列中插入一个新动作
(define (add-to-segments! segments)
(if (= (segment-time (mcar segments)) time)
;; 找到与插入时间相同的时间片，把动作插入时间片的动作队列中
(insert-queue! (segment-queue (mcar segments))
action)
(let ((rest (mcdr segments)))
(if (belongs-before? rest)
;; 剩余的时间片时间都在插入时间之后，创建新时间片插入
(set-cdr!
segments
(mcons (make-new-time-segment time action)
(mcdr segments)))
;; 剩余的时间片时间在插入时间之前，继续检查下一个时间片
(add-to-segments! rest)))))
(let ((segments (segments agenda)))
(if (belongs-before? segments)
;; 如果插入时间点在所有时间片之前，创建新时间片插入
(set-segments!
agenda
(mcons (make-new-time-segment time action)
segments))
;; 如果插入时间点不在所有时间片之前，调用函数处理
(add-to-segments! segments))))
;; 移除日程表中第一个动作
(define (remove-first-agenda-item! agenda)
(let ((q (segment-queue (first-segment agenda))))
;; 删除动作队列中的第一个动作
(delete-queue! q)
;; 如果删除后动作队列为空，删除这个时间片
(cond ((empty-queue? q)
(set-segments! agenda (rest-segments agenda))))))
;; 获取日程表中的第一个动作
(define (first-agenda-item agenda)
(if (empty-agenda? agenda)
(error "Agenda is empty -- FIRST-AGENDA-ITEM")
(let ((first-seg (first-segment agenda)))
;; 设置当前时间为第一个时间片的时间，表示已经仿真到了这个时间
(set-current-time! agenda (segment-time first-seg))
(front-queue (segment-queue first-seg)))))
;; 新建日程表
(define the-agenda (make-agenda))
;; 在指定延迟时间后执行动作
(define (after-delay delay action)
(add-to-agenda! (+ delay (current-time the-agenda))
action
the-agenda))
;; 仿真
(define (propagate)
(if (empty-agenda? the-agenda)
'done
(let ((first-item (first-agenda-item the-agenda)))
(first-item)
(remove-first-agenda-item! the-agenda)
(propagate))))
;; 探针
(define (probe name wire)
;; 当导线电压变化，打印信息
(add-action! wire
(lambda ()
(newline)
(display name)
(display " 时间点")
(display (current-time the-agenda))
(display " New-value = ")
(display (get-signal wire)))))
然后是导线的实现
;; wire
#lang racket
(provide (all-defined-out))
;; 导线
(define (make-wire)
(let ((signal-value 0) (action-procedures '()))
;; 导线上信号变化，并调用驱动函数
(define (set-my-signal! new-value)
(if (not (= signal-value new-value))
(begin (set! signal-value new-value)
(call-each action-procedures))
'done))
;; 设置驱动函数并调用，导线信号变化后会调用驱动函数
(define (accept-action-procedure! proc)
(set! action-procedures (cons proc action-procedures))
(proc))
;; dispatch
(define (dispatch m)
(cond ((eq? m 'get-signal) signal-value)
((eq? m 'set-signal!) set-my-signal!)
((eq? m 'add-action!) accept-action-procedure!)
(else (error "Unknown operation -- WIRE" m))))
dispatch))
;; 调用列表中的所有函数
(define (call-each procedures)
(if (null? procedures)
'done
(begin
((car procedures))
(call-each (cdr procedures)))))
;; 导线操作
(define (get-signal wire)
(wire 'get-signal))
(define (set-signal! wire new-value)
((wire 'set-signal!) new-value))
(define (add-action! wire action-procedure)
((wire 'add-action!) action-procedure))或门的实现
;; 或门
(define (or-gate a1 a2 output)
;; 或操作
(define (or-action-procedure)
(let ((new-value (logical-or (get-signal a1) (get-signal a2))))
(after-delay or-delay
(lambda()
(set-signal! output new-value)))))
;; 或
(define (logical-or s1 s2)
(cond ((and (= s1 0) (= s2 0)) 0)
(else 1)))
;; 驱动
(add-action! a1 or-action-procedure)
(add-action! a2 or-action-procedure)
'ok)写个测试
;; 测试
(define input-1 (make-wire))
(define input-2 (make-wire))
(define out (make-wire))
(probe 'input-1 input-1)
(probe 'input-2 input-2)
(probe 'out out)
(or-gate input-1 input-2 out)
(propagate)
(display "上电后稳定，开始测试\n")
(set-signal! input-1 1)
(propagate)
(set-signal! input-1 0)
(propagate)
(set-signal! input-2 1)
(propagate)
练习3.29
众所周知，
;; 用与门 、非门实现或门
(define (or-gate-with-and-inv a1 a2 output)
(let ((w1 (make-wire))
(w2 (make-wire))
(w3 (make-wire)))
(inverter a1 w1)
(inverter a2 w2)
(and-gate w1 w2 w3)
(inverter w3 output))
'ok)delay就是2个反相器delay+1个与门delay
可以写个代码测试一下
;; 测试
(define input-1 (make-wire))
(define input-2 (make-wire))
(define out (make-wire))
(probe 'input-1 input-1)
(probe 'input-2 input-2)
(probe 'out out)
(or-gate-with-and-inv input-1 input-2 out)
(propagate)
(display "上电后稳定，开始测试\n")
(set-signal! input-1 1)
(propagate)
(set-signal! input-1 0)
(propagate)
(set-signal! input-2 1)
(propagate) 
练习3.30
输入的list是从低位到高位
;; Exercise 3.30
;; 加法器
#lang racket
(require "agenda.rkt")
(require "wire.rkt")
(require "gate.rkt")
;; 半加器
(define (half-adder a b s c)
(let ((d (make-wire)) (e (make-wire)))
(or-gate a b d)
(and-gate a b c)
(inverter c e)
(and-gate d e s)
'ok))
;; 全加器
(define (full-adder a b c-in sum c-out)
(let ((s (make-wire))
(c1 (make-wire))
(c2 (make-wire)))
(half-adder b c-in s c1)
(half-adder a s sum c2)
(or-gate c1 c2 c-out)
'ok))
;; 移位加法器
(define (ripple-carry-adder A B S n)
(define (iter remains-A remains-B remains-S C-in k)
(if (> k n)
'ok
(let ((C-out (make-wire)))
(full-adder (car remains-A) (car remains-B) C-in (car remains-S) C-out)
(iter (cdr remains-A) (cdr remains-B) (cdr remains-S) C-out (+ k 1)))))
(iter A B S (make-wire) 1))
练习3.31
去掉立即执行后，含有inverter的电路就会出现问题
因为导线上的驱动函数只有在导线的值改变时才会被调用，初始化的所有导线值都是0，一个inverter的输入是0，输出也是0，实际上的输出应该是1才对
;; 导线上信号变化，并调用驱动函数
(define (set-my-signal! new-value)
(if (not (= signal-value new-value))
(begin (set! signal-value new-value)
(call-each action-procedures))
'done))以半加器为例，一开始所有导线上的值都是0，包括a、b、c、d、e、s
现在把a置为1，驱动了or和and，d也会变为1，但是由于c仍然是0，没有调用invert-input，d永远不能变成1，e仍然为0，s的输出就是错误的0
如果是以前的代码呢，inverter连接了c后，就会立刻invert-input，2个时间周期后，e变为1，5个时间周期后，a的作用下d变为1，8个时间周期后的时候s变为1，就是正确的
;; 半加器
(define (half-adder a b s c)
(let ((d (make-wire)) (e (make-wire)))
(or-gate a b d)
(and-gate a b c)
(inverter c e)
(and-gate d e s)
'ok))其实去掉立即执行也不是不可以，修改一下导线的实现，让每次执行set-signal!的时候，不检查值是否有改变，而都call-each一次就可以，只不过这样会刷出肥肠肥肠多的电位跳转信息
练习3.32
最终的结果是没有区别的，只不过中间电平跳转有点区别
如果是先入先出，从1,0跳转到0,1，电路输出一直0，不会有变化
如果是先入后厨，从1,0跳转到0,1，3个时间周期后，电路输出先跳到1，再跳到0
练习3.33
需要把connector和constraint的相关代码都敲下来，我放在了constraint.rkt这个文件里
然后probe也敲下来
;; Exercise 3.33
;; 求平均值
#lang racket
(require "constraint.rkt")
(require "probe.rkt")
;; 平均值转换器
(define (average-converter a b c)
(let ((s (make-connector))
(v (make-connector)))
(adder a b s)
(constant 2 v)
(multiplier c v s)))
练习3.34
显然，在multiplier里面，只有两个connector被赋值才能计算出第三个值，只知道b的情况下是无法计算的
练习3.35
;; 平方根
(define (squarer a b)
;; 处理新值
(define (process-new-value)
(if (has-value? b)
(if (< (get-value b) 0)
(error "square less than 0 -- SQUARER" (get-value b))
(set-value! a (sqrt (get-value b)) me))
(set-value! b (* (get-value a) (get-value a)) me)))
;; 遗忘值
(define (process-forget-value)
(forget-value! a me)
(forget-value! b me)
(process-new-value))
;; dispatch
(define (me request)
(cond ((eq? request 'I-have-a-value)
(process-new-value))
((eq? request 'I-lost-my-value)
(process-forget-value))
(else
(error "Unknown request -- MULTIPLIER" request))))
(connect a me)
(connect b me)
me)
练习3.36
执行之前的环境，部分函数省略没画
执行后
练习3.37
;; Exercise 3.37
;; 简化的温度转换
#lang racket
(require "constraint.rkt")
(require "probe.rkt")
;; 温度转换器
(define (celsius-fahrenheit-converter x)
(c+ (c* (c/ (cv 9) (cv 5))
x)
(cv 32)))
;; 接口
(define (c+ x y)
(let ((z (make-connector)))
(adder x y z)
z))
(define (c* x y)
(let ((z (make-connector)))
(multiplier x y z)
z))
(define (c/ x y)
(let ((z (make-connector)))
(multiplier y z x)
z))
(define (cv v)
(let ((z (make-connector)))
(constant v z)
z))
练习3.38
a.
根据全排列一共有六种可能性，最后的结果可能是剩35、40、45、50
b.
题目没说列出所有可能性，可能性太多了，一个一个画图不现实
这题要注意的是Mary是要读两次balance的，这两次读到的balance可能不一样，比如下面的图最后结果是45
练习3.39
还是会产生错误的结果，关键在于必须保证从取到x到计算完毕再到给x设新值，这一整段时间内没有其他程序执行，仅仅保证计算过程中没有其他 程序执行是不行的
练习3.40
五种可能，100,1000,10000,100000,1000000
修改代码之后，只有一种可能，1000000
练习3.41
这种操作没必要，虽然加上了并不影响程序的正确性，仅仅对变量进行读操作，即使有其他程序在执行存或者取，读到的数据也都是正确的
练习3.42
这操作就更没必要，不影响正确性，但是完全破坏了并行的作用，本来不同的银行账户之间存取都可以并行，现在变成任何时刻只能有一个银行账户进行操作
练习3.43
这题一共问了四个问题啊
第一个问题，交换程序如果是串行执行的，三个账户里的钱是否永远是10、20、30的某种排列？串行执行没有问题，三个账户的钱会正常交换，无论交换的顺序如何，总是$10、$20、$30的三个账户
第二个问题，并行执行第一个版本的交换程序，三个账户里的钱是否永远是10、20、30的某种排列？如果并行执行，无serializer的话，会出现错误结果，例如下图
第三个问题，即使在并行执行第一个版本交换程序的情况下，三个账户里的钱总和永远是60？这个是的，无论何种情况，每次交换程序执行都有一个账户增加difference，另一个账户减少相同的difference，所以三个账户里的钱总和永远是60
第四个问题，如果每个账户内部的操作没有serializer，三个账户钱的总和还能保持60吗？显然不是，如下图
练习3.44
transfer不需要再加serializer控制，因为它和exchange有本质的区别，exchange需要根据两个账户里的balance，计算出difference，再进行存取操作，这一整个过程中两个账户里的balance如果有变化，结果就会错误，而transfer的两个操作都是原子性的
练习3.45
会发生死锁。首先serialized-exchange占用了锁，然后调用了withdraw操作，withdraw操作也需要占用锁才能进行，这个锁已经被serialized-exchange占用了，因此产生死锁
3.46
如图，这样两个程序都认为自己抢到了锁
练习3.47
a.
基于锁来实现信号量，首先把书上锁的代码敲下来
;; 锁
#lang racket
(provide (all-defined-out))
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
;; 锁
(define (make-mutex)
(let ((cell (mlist false)))
(define (the-mutex m)
(cond ((eq? m 'acquire)
(cond ((test-and-set! cell)
;; 获取锁失败，再次重新尝试获取锁
(the-mutex 'acquire))))
((eq? m 'release) (clear! cell))))
the-mutex))
(define (clear! cell)
(set-mcar! cell false))
;; 尝试获取锁
(define (test-and-set! cell)
(if (mcar cell)
true
(begin (set-mcar! cell true)
false)))用锁实现信号量
;; Exercise 3.47
;; 锁实现信号量
#lang racket
(require "mutex.rkt")
;; 信号量
(define (make-semaphore n)
;; 内部锁
(let ((the-mutex (make-mutex)))
;; dispatch
(define (the-semaphore m)
(cond ((eq? m 'acquire)
(begin
(the-mutex 'acquire)
(if (> n 0)
(begin
(set! n (- n 1))
(the-mutex 'release))
(begin
(the-mutex 'release)
(the-semaphore 'acquire)))))
((eq? m 'release)
(begin
(the-mutex 'acquire)
(set! n (+ n 1))
(the-mutex 'release)))
(else (error "Error Operation" m))))
the-semaphore))b.
用test-and-set!实现
;; Exercise 3.47
;; test-and-set!实现信号量
#lang racket
(require compatibility/mlist)
(require rnrs/mutable-pairs-6)
(require "mutex.rkt")
;; 信号量
(define (make-semaphore n)
(let ((cell (mlist false)))
;; dispatch
(define (the-semaphore m)
(cond ((eq? m 'acquire)
(if (test-and-set! cell)
(the-semaphore 'acquire)
(if (> n 0)
(begin
(set! n (- n 1))
(clear! cell))
(begin
(clear! cell)
(the-semaphore 'acquire)))))
((eq? m 'release)
(if (test-and-set! cell)
(the-semaphore 'release)
(begin
(set! n (+ n 1))
(clear! cell))))
(else (error "Error Operation" m))))
the-semaphore))
练习3.48
在交换账户程序里，只有两个线程同时抢占了两个账户的锁，才会发生死锁现象，如果每次线程都先尝试获取编号低的账户的锁，就不会发生分别抢占两个账户锁的现象
;; Exercise 3.48
;; 交换账户
#lang racket
(require "serializer.rkt")
;; 账户
(define (make-account-and-serializer balance number)
(define (withdraw amount)
(if (>= balance amount)
(begin (set! balance (- balance amount))
balance)
"Insufficient funds"))
(define (deposit amount)
(set! balance (+ balance amount))
balance)
(let ((balance-serializer (make-serializer)))
(define (dispatch m)
(cond ((eq? m 'withdraw) (balance-serializer withdraw))
((eq? m 'deposit) (balance-serializer deposit))
((eq? m 'balance) balance)
((eq? m 'number) number)
((eq? m 'serializer) balance-serializer)
(else (error "Unknown request -- MAKE-ACCOUNT"
m))))
dispatch))
;; 交换账户
(define (exchange account1 account2)
(let ((difference (- (account1 'balance)
(account2 'balance))))
((account1 'withdraw) difference)
((account2 'deposit) difference)))
;; 串行交换
(define (serialized-exchange account1 account2)
(if (> (account1 'number) (account2 'number))
(serialized-exchange account2 account1)
(let ((serializer1 (account1 'serializer))
(serializer2 (account2 'serializer)))
((serializer1 (serializer2 exchange))
account1
account2))))
练习3.49
比如一个程序指定了访问共享资源的顺序，就不能通过这种方法避免死锁，从账户1中取出10块钱给账户2，就需要先获取账户1的锁，检查账户1的余额是否足够，再获取账户2的锁。现在两个进程，分别尝试从账户A取10块钱给B，从账户B取10块钱给A，这种情况下就会产生死锁
练习3.50
racket的部分语法和scheme不一样
;; 多参数映射
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr argstreams))))))
练习3.51
逻辑上，执行define输出0，stream-map只对第一个输入执行了show，然后stream-ref执行，输出123455，再执行stream-ref，输出677
然而在我的racket里，第一句就输出了012345678910，然后输出5、7？？？震惊了很久才发现自己看书不仔细，书上明确写了cons-stream和if类似，是特殊的关键字，下面定义的cons-stream，在应用序解释器里面会把参数都evaluate一遍，就没有delay的效果了，同样也有delay，delay直接定义的话，参数exp就会被evaluate一遍
;; 错误的定义
(define (cons-stream a b)
(cons a (delay b)))所以后来用宏定义重新写了部分函数，就和scheme一致了
;; cons
(define-syntax-rule (cons-stream a b)
(cons a (delay b)))
;; delay
(define-syntax-rule (delay exp)
(memo-proc (lambda() exp)))
(define (memo-proc proc)
(let ((already-run? false) (result false))
(lambda ()
(if (not already-run?)
(begin (set! result (proc))
(set! already-run? true)
result)
result))))
练习3.52
(define seq (stream-map accum (stream-enumerate-interval 1 20))) sum为1，只累加了第一项
(define y (stream-filter even? seq)) sum为6，因为需要找到第一个偶数，累加流的值为1、3、6……
(define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq)) sum为10，第一个5倍数的是10
(stream-ref y 7) sum为136，第8个偶数项是136
(display-stream z) sum为210，为累加流的最后一项
如果去掉了memo-proc，每次调用累加流的时候，都要执行accum
(define seq (stream-map accum (stream-enumerate-interval 1 20))) sum为1，只累加了第一项
(define y (stream-filter even? seq)) sum为6，seq从第二项开始重新计算，依然是3、6，第一个偶数是6
(define z (stream-filter (lambda (x) (= (remainder x 5) 0)) seq)) sum为15，seq从第二项开始重新计算，依次是8、11、15
(stream-ref y 7) sum为162，y调用的seq刚才在第二步计算完成了前三项1、3、6，接下来依次是15+4=19、24、30、37、45、54、64、75、87、100、114、129、145、162，第8个偶数项是162，输出是162
(display-stream z) sum为362，z的seq在第三步计算完成了前四项1、8、11、15，接下来依次是162+5=167、173、180、188、197、207、218、230、243、257、272、288、305、323、342、362，输出是15、180、230、305
练习3.53
2的幂，1、2、4、8……
练习3.54
;; 阶乘
(define factorials (cons-stream 1 (mul-streams integers factorials)))
练习3.55
两种写法
;; 部分和
(define (partial-sums s)
(define ss (cons-stream (stream-car s) ss))
(cons-stream (stream-car s) (add-streams ss (partial-sums (stream-cdr s)))))或者
;; 部分和
(define (partial-sums s)
(cons-stream (stream-car s) (add-streams (partial-sums s) (stream-cdr s))))这种写法其实是不好的，递归调用partial-sums相当于每次都要创建新流，不能利用memo-proc
正确的写法如下
;; 部分和
(define (partial-sums s)
(define res (cons-stream (stream-car s) (add-streams res (stream-cdr s))))
res)
练习3.56
;; Hamming
(define S (cons-stream 1 (merge (scale-stream S 2)
(merge (scale-stream S 3) (scale-stream S 5)))))
练习3.57
从计算裴波那契数列的程序可以看出
计算第n项需要的加法次数 = 计算第n-1项需要的加法次数 + 计算第n-2项需要的加法次数 + 1
这是一个类似裴波那契数列的增长速度，远大于指数级
练习3.58
计算num/dem的浮点数结果，radix是放大比例
练习3.59
a.
;; 系数
(define (integrate-series a)
(stream-map / a integers))b.
不得不说这种程序十分精妙
;; 泰勒展开
(define exp-series
(cons-stream 1 (integrate-series exp-series)))
(define cosine-series
(cons-stream 1 (scale-stream (integrate-series sine-series) -1)))
(define sine-series
(cons-stream 0 (integrate-series cosine-series)))
练习3.60
;; 序列乘
(define (mul-series s1 s2)
(cons-stream (* (stream-car s1) (stream-car s2))
(add-streams (mul-series (stream-cdr s1) s2)
(scale-stream (stream-cdr s2) (stream-car s1)))))
练习3.61
;; 逆序列
(define (invert-unit-series s)
(define res (cons-stream 1 (scale-stream
(mul-series
(stream-cdr s)
(invert-unit-series s))
-1)))
res)
练习3.62
;; 序列除
(define (div-series s1 s2)
(if (= (stream-car s2) 0)
(error "zero denominator")
(mul-series s1 (invert-unit-series s2))))
(define tanh-series
(div-series sine-series cosine-series))
练习3.63
因为在sqrt-stream里递归调用sqrt-stream，每次调用都会创建一个新流，就不能通过memo-proc提升性能
练习3.64
;; 收敛值
(define (stream-limit s tolerance)
(let ((first-item (stream-car s))
(second-item (stream-car (stream-cdr s))))
(if (< (abs (- first-item second-item)) tolerance)
second-item
(stream-limit (stream-cdr s) tolerance))))
练习3.65
收敛速度颇慢
;; log2
(define (ln2-item n sgn)
(cons-stream (/ sgn n) (ln2-item (+ n 1) (- sgn))))
(define ln2-stream (partial-sums (ln2-item 1 1.0)))
(stream-limit ln2-stream 0.000001)
练习3.66
如图，整数对被分成三个部分，首先是左上角的第一部分，然后右上角的一行和右下角的一块，依次排列，由此我们可以确定两个顺序：第一个顺序，右上角的一行，分别是第2、4、6、8、10……项，间隔为2；第二个顺序，最左侧呈三角形的三个项是第1、2、3项，间隔为1
用excel来列几个看看，红字表示顺序，第一行（说第几行都不包括第一项）的间隔为2，第二行的间隔为4，第三行的间隔为8，同时第一个三角形的间隔为1（1,2,3），第二个三角形的间隔为2（3,5,7），第三个三角形的间隔为4（7,11,15）
这是因为每次右上角的行和右下角的块都依次排列，右下角块的第一行又和剩余部分依次排列，所以间隔不断乘2
有了上述规律，就可以得到下面的公式（索引从1开始）
对于(n,n)这种项，他们的次序是
对于(n,n+1)，与(n,n)差一个间隔，所以次序是
对于(n,m)且m>n+1的，次序是
第2、3个公式可以合并，对于(n,m)且n不等于m，次序是
所以(1,100)是第198项，(99,100)是第950737950171172051122527404033项,(100,100)是第1267650600228229401496703205375项
练习3.67
修改一下interleave，支持三个流的合并
;; 全整数对
(define (pairs-without-limit s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave-3
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(stream-map (lambda (x) (list x (stream-car t)))
(stream-cdr s))
(pairs (stream-cdr s) (stream-cdr t)))))
;; 三流归并
(define (interleave-3 s1 s2 s3)
(cons-stream (stream-car s1)
(interleave-3 s2 s3 (stream-cdr s1))))
练习3.68
程序会死循环，interleave的两个参数都要先完成eval，所以会造成pairs的死循环调用
练习3.69
;; 三整数对
(define (triple s t k)
(cons-stream (list (stream-car s) (stream-car t) (stream-car k))
(interleave
(stream-map (lambda (x) (cons (stream-car s) x))
(stream-cdr (pairs t k)))
(triple (stream-cdr s) (stream-cdr t) (stream-cdr k)))))
;; 毕氏三元数
(define Pythagorean-triples (stream-filter (lambda(l)
(let ((x (car l))
(y (cadr l))
(z (caddr l)))
(= (* z z)
(+ (* x x) (* y y)))))
(triple integers integers integers)))前六个是(3 4 5) (6 8 10) (5 12 13) (9 12 15) (8 15 17) (12 16 20)，之后的项出来的速度非常慢，跑了一个多小时还出不来
练习3.70
a.
;; 带权重归并
(define (merge-weighted s1 s2 weight)
(let ((car1 (stream-car s1))
(car2 (stream-car s2)))
(if (< (weight car1) (weight car2))
(cons-stream car1 (merge-weighted (stream-cdr s1) s2 weight))
(cons-stream car2 (merge-weighted s1 (stream-cdr s2) weight)))))
;; 有序整数对
(define (weighted-pairs s1 s2 weight)
(cons-stream (list (stream-car s1) (stream-car s2))
(merge-weighted
(stream-map (lambda (x) (list (stream-car s1) x))
(stream-cdr s2))
(weighted-pairs (stream-cdr s1) (stream-cdr s2) weight)
weight)))按照i+j的大小排列的整数对
(weighted-pairs integers integers (lambda (x) (+ (car x) (cadr x))))b.
这个稍微复杂些，要求去掉可以被2、3、5整除的整数是套一层stream-filter
(define integers-without-235 (stream-filter (lambda (x)
(not (or (= 0 (remainder x 2))
(= 0 (remainder x 3))
(= 0 (remainder x 5)))))
integers))
(weighted-pairs integers-without-235
integers-without-235
(lambda (x)
(+ (* 2 (car x))
(* 3 (cadr x))
(* 5 (car x) (cadr x)))))
练习3.71
这段代码没有考虑重复数字的情况（例如三个整数对的立方和都是相同的），不过我跑了一下，没有重复的
;; 拉马努金数字
(define (Ramanujan-numbers)
(define (cube-sum x)
(+ (* (car x) (car x) (car x))
(* (cadr x) (cadr x) (cadr x))))
(let ((cube
(stream-map cube-sum
(weighted-pairs integers integers cube-sum))))
(define (iter s pre)
(if (= (stream-car s) pre)
(cons-stream (stream-car s) (iter (stream-cdr s) (stream-car s)))
(iter (stream-cdr s) (stream-car s))))
(iter cube 0)))前20个是1729 4104 13832 20683 32832 39312 40033 46683 64232 65728 110656 110808 134379 149389 165464 171288 195841 216027 216125 262656
练习3.72
;; 可以写成3种平方和的整数
(define (square-sum-numbers)
(define (square-sum x)
(+ (* (car x) (car x))
(* (cadr x) (cadr x))))
(let ((square (weighted-pairs integers integers square-sum)))
(define (iter s first second)
(let ((current-sum (square-sum (stream-car s)))
(first-sum (square-sum first))
(second-sum (square-sum second)))
(if (and (= current-sum first-sum) (= current-sum second-sum))
(cons-stream (list current-sum first second (stream-car s)) (iter (stream-cdr s) second (stream-car s)))
(iter (stream-cdr s) second (stream-car s)))))
(iter (stream-cdr (stream-cdr square)) (stream-car square) (stream-car (stream-cdr square)))))
练习3.73
;; RC
(define (RC R C dt)
(lambda (initial-voltage current)
(add-streams (scale-stream current R)
(integral current
initial-voltage
(* (/ 1 C) dt)))))
练习3.74
与第一个信号值检测对比的是0，之后的信号值对比前一个信号值
(cons-stream 0 sense-data)
练习3.75
bug在于，last-value和last-avpt要用两个变量表示，这段代码里这两个混用了
(define (make-zero-crossings input-stream last-value last-avpt)
(let ((avpt (/ (+ (stream-car input-stream) last-value) 2)))
(cons-stream (sign-change-detector avpt last-avpt)
(make-zero-crossings (stream-cdr input-stream)
(stream-car input-stream)
avpt))))
练习3.76
;; 信号平滑处理
(define (smooth input-stream)
(stream-map (lambda(x y)
(/ (+ x y) 2))
input-stream
(cons-stream 0 input-stream)))
;; 模块化过零检测
(define (modular-make-zero-crossings input-stream last-value)
(let ((smooth-stream (smooth input-stream)))
(stream-map sign-change-detector smooth-stream (cons-stream 0 smooth-stream))))
352
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
