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

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

#! /usr/bin/guile -s
!#

(define atom?
    (lambda (a)
        (and (not (null? a)) (not (pair? a)))))


(define rember-f
    (lambda (test? a l)
        (cond
            ((null? l) '())
            ((test? (car l) a) (cdr l))
            (else (cons (car l) (rember-f test? a (cdr l)))))))


(define rember-f2
    (lambda (test?)
        (lambda (a l)
            (cond
                ((null? l) '())
                ((test? (car l) a) (cdr l))
                (else (cons (car l) ((rember-f2 test?) a (cdr l))))))))

;rewrite insertL to insertL-f
(define insertL-f
    (lambda (test?)
        (lambda (new old l)
            (cond
                ((null? l) '())
                ((test? (car l) old) (cons new (cons old (cdr l))))
                (else (cons (car l) ((insertL-f test?) new old (cdr l))))))))


;rewrite insertR to insertR-f
(define insertR-f
    (lambda (test?)
        (lambda (new old l)
            (cond
                ((null? l) '())
                ((test? (car l) old) (cons old (cons new (cdr l))))
                (else (cons (car l) ((insertR-f test?) new old (cdr l))))))))

;write a function insert-g insert either at the left or at the rigth?
(define seqL
    (lambda (new old l)
        (cons new (cons old l))))

(define seqR
    (lambda (new old l)
        (cons old (cons new l))))

(define insert-g
    (lambda (seq)
        (lambda (new old l)
            (cond
                ((null? l) '())
                ((eq? (car l) old) (seq new old (cdr l)))
                (else (cons (car l) ((insert-g seq) new old (cdr l))))))))


; redefine insertL
(define insertL (insert-g seqL))

(define insertL2
    (insert-g
        (lambda (new old l)
            (cons new (cons old l)))))

; rdefine insertR
(define insertR (insert-g seqR))

(define insertR2
    (insert-g
        (lambda (new old l)
            (cons old (cons new l)))))

(define seqS
    (lambda (new old l)
        (cons new l)))

;susbtitue
(define subst-f (insert-g seqS))

;rember
(define seqrem (lambda (new old l) l))

(define rember-f3
    (lambda (a l)
        ((insert-g seqrem) #f a l)))

; get 3 from '(+ 3 4)
(define fst-sub-exp
    (lambda (aexp)
        (car (cdr aexp))))

; get 4 from '(+ 3 2)
(define sec-sub-exp
    (lambda (aexp)
        (car (cdr (cdr aexp)))))

;get operator
(define operator
    (lambda (aexp)
        (car aexp)))

(define atom-to-function
    (lambda (x)
        (cond
            ((eq? x '+ ) +)
            ((eq? x '* ) *)
            ((eq? x '- ) -)
            (else / ))))

(define value
    (lambda (nexp)
        (cond
            ((atom? nexp) nexp)
            (else ((atom-to-function (operator nexp)) (value (fst-sub-exp nexp))
                (value (sec-sub-exp nexp)))))))

(define multirember-f
    (lambda (test?)
        (lambda (a lat)
            (cond
                ((null? lat) '())
                ((test? a (car lat)) ((multirember-f test?) a (cdr lat)))
                (else (cons (car lat) ((multirember-f test?) a (cdr lat))))))))

(define eq?-c
    (lambda (a)
        (lambda (x)
            (eq? x a))))

(define eq?-tuna
    (eq?-c 'tuna ))

(define multiremberT
    (lambda (test? lat)
        (cond
            ((null? lat) '())
            ((test? (car lat)) (multiremberT test? (cdr lat)))
            (else (cons (car lat) (multiremberT test? (cdr lat)))))))


;
(define a-friend
    (lambda (x y)
        (null? y)))


(define multirember-co
    (lambda (a lat col)
        (cond
            ((null? lat) (col '() '()))
            ((eq? (car lat) a) (multirember-co a (cdr lat) (lambda (newlat seen)
                (col newlat (cons (car lat) seen)))))
            (else
                (multirember-co a (cdr lat) (lambda (newlat seen)
                    (col (cons (car lat) newlat) seen)))))))

#! /usr/bin/guile -s
!#

;; define function pick, pick the nst atom in the list
(define pick
    (lambda (n lat)
        (cond
            ((or (zero? n) (null? lat)) '())
            ((zero? (- n 1)) (car lat))
            (else (pick (- n 1) (cdr lat))))))

(define looking
    (lambda (a lat)
        (keep-looking a (pick 1 lat) lat)))

(define keep-looking
    (lambda (a sorn lat)
        (cond
            ((number? sorn) (keep-looking a (pick sorn lat) lat))
            (else (eq? sorn a )))))

;======================================
(define first
    (lambda (p)
        (cond
            (else (car p)))))

(define second
    (lambda (p)
        (cond
            (else (car (cdr p))))))

(define build
    (lambda (a1 a2)
        (cond
            (else (cons a1 (cons a2 '()))))))

(define shift
    (lambda (pair)
        (build (first (first pair))
        (build (second (first pair)) (second pair)))))


;===============
;length
(define length*
    (lambda (para)
        (cond
            ((atom? para ) 1)
            (else (+ (length* (first para)) (length* (second para)))))))

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

#! /usr/bin/guile -s
!#

(define (sqrt-iter guess x)
    (if (good-enough? guess x)
        guess
        (sqrt-iter (improve guess x) x)))

(define (improve guess x)
    (average guess (/ x guess)))

(define (average x y)
    (/ (+ x y) 2))

(define (good-enough? guess x)
    (< (abs (- (square guess) x)) 0.001))

(define (square x)
    (* x x))

(define (mysqrt x)
    (sqrt-iter 1.0 x))


(define (new-if predicate then-clause else-clause)
    (cond
        (predicate then-clause)
        (else else-clause)))

;never stop
(define (sqrt-iter2 guess x)
    (new-if (good-enough? guess x)
        guess
        (sqrt-iter2 (improve guess x) x )))

(define (mysqrt2 x)
    (sqrt-iter2 1.0 x))


;another approach to define good-enough3? , this function works very well
; for smalle numbers
(define (good-enough3? guess prev-guess)
    (< (abs (- guess prev-guess)) (* 0.001 guess)))

(define (sqrt-iter3 guess prev-guess x)
    (if (good-enough3? guess prev-guess)
        guess
        (sqrt-iter3 (improve guess x) guess x)))


(define (mysqrt3 n)
    (sqrt-iter3 1 0 n))