加入 Gitee
与超过 1200万 开发者一起发现、参与优秀开源项目,私有仓库也完全免费 :)
免费加入
文件
该仓库未声明开源许可证文件(LICENSE),使用请关注具体项目描述及其代码上游依赖。
克隆/下载
sicp-2.3.3.scm 3.74 KB
一键复制 编辑 原始数据 按行查看 历史
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 2.3.3
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (element-of-set? x set)
(cond ((null? set) #f)
((equal? x (car set)) #t)
(else (element-of-set? x (cdr set)))))
(define (adjoin-set x set)
(if (element-of-set? x set)
set
(cons x set)))
(define (intersection-set set1 set2)
(cond ((or (null? set1) (null? set2)) '())
((element-of-set? (car set1) set2)
(cons (car set1)
(intersection-set (cdr set1) set2)))
(else (intersection-set (cdr set1) set2))))
(define (union-set set1 set2)
(cond ((null? set1) set2)
((null? set2) set1)
((element-of-set? (car set1) set2)
(union-set (cdr set1) set2))
(else (cons (car set1) (union-set (cdr set1) set2)))))
(define (entry tree) (car tree))
(define (left-branch tree) (cadr tree))
(define (right-branch tree) (caddr tree))
(define (make-tree entry left right)
(list entry left right))
(define (element-of-set? x set)
(cond ((null? set) #f)
((= x (entry set)) #t)
((< x (entry set))
(element-of-set? x (left-branch set)))
((> x (entry set))
(element-of-set? x (right-branch set)))))
(define (adjoin-set x set)
(cond ((null? set) (make-tree x '() '()))
((= x (entry set)) set)
((< x (entry set))
(make-tree (entry set)
(adjoin-set x (left-branch set))
(right-branch set)))
((> x (entry set))
(make-tree (entry set)
(left-branch set)
(adjoin-set x (right-branch set))))))
(define (tree->list-1 tree)
(if (null? tree)
'()
(append (tree->list-1 (left-branch tree))
(cons (entry tree)
(tree->list-1 (right-branch tree))))))
(define (list->tree elements)
(car (partial-tree elements (length elements))))
(define (partial-tree elts n)
(if (= n 0)
(cons '() elts)
(let ((left-size (quotient (- n 1) 2)))
(let ((left-result (partial-tree elts left-size)))
(let ((left-tree (car left-result))
(non-left-elts (cdr left-result))
(right-size (- n (+ left-size 1))))
(let ((this-entry (car non-left-elts))
(right-result (partial-tree (cdr non-left-elts)
right-size)))
(let ((right-tree (car right-result))
(remaining-elts (cdr right-result)))
(cons (make-tree this-entry left-tree right-tree)
remaining-elts))))))))
(define (union-ordered-set set1 set2)
(cond ((null? set1) set2)
((null? set2) set1)
(else
(let ((x1 (car set1))
(x2 (car set2)))
(cond ((= x1 x2)
(cons x1 (union-ordered-set (cdr set1) (cdr set2))))
((< x1 x2)
(cons x1 (union-ordered-set (cdr set1) set2)))
((> x1 x2)
(cons x2 (union-ordered-set set1 (cdr set2)))))))))
(define (adjoin-ordered-set x set)
(if (null? set)
(cons x set)
(let ((x1 (car set)))
(cond ((= x x1) set)
((< x x1) (cons x set))
(else
(cons x1 (adjoin-ordered-set x (cdr set))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 2.66
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (lookup given-key set-of-records)
(if (null? set-of-records)
#f
(let ((this-key (key (entry set-of-records))))
(cond ((= given-key this-key) (entry set-of-records))
((< given-key this-key)
(lookup given-key (left-branch set-of-records)))
((> given-key this-key)
(lookup given-key (right-branch (set-of-records))))))))
马建仓 AI 助手
尝试更多
代码解读
代码找茬
代码优化