The little scheme 书上的部分scheme代码（Guile 实现）- 3

看到第9章了，开始真是看的头大了，所以little scheme就到这里吧。

点击(此处)折叠或打开

1. #! /usr/bin/guile -s
   
2. !#
   
3. 
   
4. (define atom?
   
5.     (lambda (a)
   
6.         (and (not (null? a)) (not (pair? a)))))
   
7. 
   
8. 
   
9. (define rember-f
   
10.     (lambda (test? a l)
    
11.         (cond
    
12.             ((null? l) '())
    
13.             ((test? (car l) a) (cdr l))
    
14.             (else (cons (car l) (rember-f test? a (cdr l)))))))
    
15. 
    
16. 
    
17. (define rember-f2
    
18.     (lambda (test?)
    
19.         (lambda (a l)
    
20.             (cond
    
21.                 ((null? l) '())
    
22.                 ((test? (car l) a) (cdr l))
    
23.                 (else (cons (car l) ((rember-f2 test?) a (cdr l))))))))
    
24. 
    
25. ;rewrite insertL to insertL-f
    
26. (define insertL-f
    
27.     (lambda (test?)
    
28.         (lambda (new old l)
    
29.             (cond
    
30.                 ((null? l) '())
    
31.                 ((test? (car l) old) (cons new (cons old (cdr l))))
    
32.                 (else (cons (car l) ((insertL-f test?) new old (cdr l))))))))
    
33. 
    
34. 
    
35. ;rewrite insertR to insertR-f
    
36. (define insertR-f
    
37.     (lambda (test?)
    
38.         (lambda (new old l)
    
39.             (cond
    
40.                 ((null? l) '())
    
41.                 ((test? (car l) old) (cons old (cons new (cdr l))))
    
42.                 (else (cons (car l) ((insertR-f test?) new old (cdr l))))))))
    
43. 
    
44. ;write a function insert-g insert either at the left or at the rigth?
    
45. (define seqL
    
46.     (lambda (new old l)
    
47.         (cons new (cons old l))))
    
48. 
    
49. (define seqR
    
50.     (lambda (new old l)
    
51.         (cons old (cons new l))))
    
52. 
    
53. (define insert-g
    
54.     (lambda (seq)
    
55.         (lambda (new old l)
    
56.             (cond
    
57.                 ((null? l) '())
    
58.                 ((eq? (car l) old) (seq new old (cdr l)))
    
59.                 (else (cons (car l) ((insert-g seq) new old (cdr l))))))))
    
60. 
    
61. 
    
62. ; redefine insertL
    
63. (define insertL (insert-g seqL))
    
64. 
    
65. (define insertL2
    
66.     (insert-g
    
67.         (lambda (new old l)
    
68.             (cons new (cons old l)))))
    
69. 
    
70. ; rdefine insertR
    
71. (define insertR (insert-g seqR))
    
72. 
    
73. (define insertR2
    
74.     (insert-g
    
75.         (lambda (new old l)
    
76.             (cons old (cons new l)))))
    
77. 
    
78. (define seqS
    
79.     (lambda (new old l)
    
80.         (cons new l)))
    
81. 
    
82. ;susbtitue
    
83. (define subst-f (insert-g seqS))
    
84. 
    
85. ;rember
    
86. (define seqrem (lambda (new old l) l))
    
87. 
    
88. (define rember-f3
    
89.     (lambda (a l)
    
90.         ((insert-g seqrem) #f a l)))
    
91. 
    
92. ; get 3 from '(+ 3 4)
    
93. (define fst-sub-exp
    
94.     (lambda (aexp)
    
95.         (car (cdr aexp))))
    
96. 
    
97. ; get 4 from '(+ 3 2)
    
98. (define sec-sub-exp
    
99.     (lambda (aexp)
    
100.         (car (cdr (cdr aexp)))))
     
101. 
     
102. ;get operator
     
103. (define operator
     
104.     (lambda (aexp)
     
105.         (car aexp)))
     
106. 
     
107. (define atom-to-function
     
108.     (lambda (x)
     
109.         (cond
     
110.             ((eq? x '+ ) +)
     
111.             ((eq? x '* ) *)
     
112.             ((eq? x '- ) -)
     
113.             (else / ))))
     
114. 
     
115. (define value
     
116.     (lambda (nexp)
     
117.         (cond
     
118.             ((atom? nexp) nexp)
     
119.             (else ((atom-to-function (operator nexp)) (value (fst-sub-exp nexp))
     
120.                 (value (sec-sub-exp nexp)))))))
     
121. 
     
122. (define multirember-f
     
123.     (lambda (test?)
     
124.         (lambda (a lat)
     
125.             (cond
     
126.                 ((null? lat) '())
     
127.                 ((test? a (car lat)) ((multirember-f test?) a (cdr lat)))
     
128.                 (else (cons (car lat) ((multirember-f test?) a (cdr lat))))))))
     
129. 
     
130. (define eq?-c
     
131.     (lambda (a)
     
132.         (lambda (x)
     
133.             (eq? x a))))
     
134. 
     
135. (define eq?-tuna
     
136.     (eq?-c 'tuna ))
     
137. 
     
138. (define multiremberT
     
139.     (lambda (test? lat)
     
140.         (cond
     
141.             ((null? lat) '())
     
142.             ((test? (car lat)) (multiremberT test? (cdr lat)))
     
143.             (else (cons (car lat) (multiremberT test? (cdr lat)))))))
     
144. 
     
145. 
     
146. ;
     
147. (define a-friend
     
148.     (lambda (x y)
     
149.         (null? y)))
     
150. 
     
151. 
     
152. (define multirember-co
     
153.     (lambda (a lat col)
     
154.         (cond
     
155.             ((null? lat) (col '() '()))
     
156.             ((eq? (car lat) a) (multirember-co a (cdr lat) (lambda (newlat seen)
     
157.                 (col newlat (cons (car lat) seen)))))
     
158.             (else
     
159.                 (multirember-co a (cdr lat) (lambda (newlat seen)
     
160.                     (col (cons (car lat) newlat) seen)))))))

点击(此处)折叠或打开

1. #! /usr/bin/guile -s
   
2. !#
   
3. 
   
4. ;; define function pick, pick the nst atom in the list
   
5. (define pick
   
6.     (lambda (n lat)
   
7.         (cond
   
8.             ((or (zero? n) (null? lat)) '())
   
9.             ((zero? (- n 1)) (car lat))
   
10.             (else (pick (- n 1) (cdr lat))))))
    
11. 
    
12. (define looking
    
13.     (lambda (a lat)
    
14.         (keep-looking a (pick 1 lat) lat)))
    
15. 
    
16. (define keep-looking
    
17.     (lambda (a sorn lat)
    
18.         (cond
    
19.             ((number? sorn) (keep-looking a (pick sorn lat) lat))
    
20.             (else (eq? sorn a )))))
    
21. 
    
22. ;======================================
    
23. (define first
    
24.     (lambda (p)
    
25.         (cond
    
26.             (else (car p)))))
    
27. 
    
28. (define second
    
29.     (lambda (p)
    
30.         (cond
    
31.             (else (car (cdr p))))))
    
32. 
    
33. (define build
    
34.     (lambda (a1 a2)
    
35.         (cond
    
36.             (else (cons a1 (cons a2 '()))))))
    
37. 
    
38. (define shift
    
39.     (lambda (pair)
    
40.         (build (first (first pair))
    
41.         (build (second (first pair)) (second pair)))))
    
42. 
    
43. 
    
44. ;===============
    
45. ;length
    
46. (define length*
    
47.     (lambda (para)
    
48.         (cond
    
49.             ((atom? para ) 1)
    
50.             (else (+ (length* (first para)) (length* (second para)))))))

开始翻了翻SICP， 听说前4章对于初学者是有用的，但是感觉对于数学的要求很高。
对我这个文科生，自学计算机的真够难啊。
计算一个数x的平方根的函数sqrt().
假设先猜测x的平方根y ,初始值是y。 则可以通过 (y+x/y)/2 求得一个更好的y值。

点击(此处)折叠或打开

1. #! /usr/bin/guile -s
   
2. !#
   
3. 
   
4. (define (sqrt-iter guess x)
   
5.     (if (good-enough? guess x)
   
6.         guess
   
7.         (sqrt-iter (improve guess x) x)))
   
8. 
   
9. (define (improve guess x)
   
10.     (average guess (/ x guess)))
    
11. 
    
12. (define (average x y)
    
13.     (/ (+ x y) 2))
    
14. 
    
15. (define (good-enough? guess x)
    
16.     (< (abs (- (square guess) x)) 0.001))
    
17. 
    
18. (define (square x)
    
19.     (* x x))
    
20. 
    
21. (define (mysqrt x)
    
22.     (sqrt-iter 1.0 x))
    
23. 
    
24. 
    
25. (define (new-if predicate then-clause else-clause)
    
26.     (cond
    
27.         (predicate then-clause)
    
28.         (else else-clause)))
    
29. 
    
30. ;never stop
    
31. (define (sqrt-iter2 guess x)
    
32.     (new-if (good-enough? guess x)
    
33.         guess
    
34.         (sqrt-iter2 (improve guess x) x )))
    
35. 
    
36. (define (mysqrt2 x)
    
37.     (sqrt-iter2 1.0 x))
    
38. 
    
39. 
    
40. ;another approach to define good-enough3? , this function works very well
    
41. ; for smalle numbers
    
42. (define (good-enough3? guess prev-guess)
    
43.     (< (abs (- guess prev-guess)) (* 0.001 guess)))
    
44. 
    
45. (define (sqrt-iter3 guess prev-guess x)
    
46.     (if (good-enough3? guess prev-guess)
    
47.         guess
    
48.         (sqrt-iter3 (improve guess x) guess x)))
    
49. 
    
50. 
    
51. (define (mysqrt3 n)
    
52.     (sqrt-iter3 1 0 n))