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

下面这些给我留下了很深的印象
always ask null? as the first question in expressing any function.
when building a list, describe the first typical element, then cons it onto the natural recursion.
always change at least one argument when use recurring.it must be changed to be closer to termination.
The changing argument must be tested in the termination condition. when using cdr, test termination
with null?.
when recurring on a list of atomes, lat , use (cdr lat).
when recurring on a number, n, use (sub1 n),

when recurring on a list of Scheme-expressions, l, ask three questions.
(null? l)
(atom? (car l))
and else.
use (car l) and (cdr l) if neither (null? l) nor (atom? (car l)) are true.

#! /usr/bin/guile -s
!#
(define atom?
    (lambda (x)
        (and (not (pair? x)) (not (null? x)))))


;; remove all the atom a from a list
(define rember*
    (lambda (a l)
        (cond
            ((null? l) '())
            ((atom? (car l))
            (cond
                ((eq? (car l) a) (rember* a (cdr l)))
                (else (cons (car l) (rember* a (cdr l))))))
            (else (cons (rember* a (car l)) (rember* a (cdr l)))))))



;; insertR*
(define insertR*
    (lambda (new old l)
        (cond
            ((null? l) '())
            ((atom? (car l))
            (cond
                ((eq? (car l) old) (cons old (cons new (insertR* new old (cdr l)))))
                (else (cons (car l) (insertR* new old (cdr l))))))
            (else (cons (insertR* new old (car l)) (insertR* new old (cdr l)))))))

;; occur*
(define occur*
    (lambda (a l)
        (cond
            ((null? l) 0)
            ((atom? (car l))
            (cond
                ((eq? (car l) a) (+ 1 (occur* a (cdr l))))
                (else (occur* a (cdr l)))))
            (else
                (+ (occur* a (car l)) (occur* a (cdr l)))))))

;; subst*

(define subst*
    (lambda (new old l)
        (cond
            ((null? l) '())
            ((atom? (car l))
            (cond
                ((eq? (car l) old) (cons new (subst* new old (cdr l))))
                (else (cons (car l) (subst* new old (cdr l))))))
            (else
                (cons (subst* new old (car l)) (subst* new old (cdr l)))))))

;; insertL*
(define insertL*
    (lambda (new old l)
        (cond
            ((null? l) '())
            ((atom? (car l))
            (cond
                ((eq? (car l) old) (cons new l))
                (else (cons (car l) (insertL* new old (cdr l))))))
            (else
                (cons (insertL* new old (car l)) (insertL* new old (cdr l)))))))


;; member*
(define member*
    (lambda (a l)
        (cond
            ((null? l) #f)
            ((atom? (car l)) (or (eq? (car l) a) (member* a (cdr l))))
            (else
                (or (member* a (car l)) (member* a (cdr l)))))))



;; leftmost
(define leftmost
    (lambda (l)
        (cond
            ((null? l) #f)
            ((atom? (car l)) (car l))
            (else
                (leftmost (car l))))))



;; compare two atom
(define eqan?
    (lambda (a b)
        (cond
            ((and (number? a) (number? b)) (= a b))
            ((or (number? a) (number? b)) #f)
            (else (eq? a b)))))


;; eqlist3?
(define eqlist3?
    (lambda (l1 l2)
        (cond
            ((and (null? l1) (null? l2)) #t)
            ((and (null? l1) (atom? (car l2))) #f)
            ((null? l1) #f)
            ((and (atom? (car l1)) (null? l2)) #f)
            ((and (atom? (car l1)) (atom? (car l2)))
             (and (eqan? (car l1) (car l2)) (eqlist3? (cdr l1) (cdr l2))))
            ((atom? (car l1)) #f)
            ((null? l2) #f)
            ((atom? (car l2)) #f)
            (else
                (and (eqlist? (car l1) (car l2)) (eqlist3? (cdr l1)(cdr l2)))))))



(define eqlist2?
    (lambda (l1 l2)
        (cond
        ((and (null? l1) (null? l2)) #t)
        ((or (null? l1) (null? l2)) #f)
        ((and (atom? (car l1)) (atom? (car l2)))
         (and (eqan? (car l1) (car l2)) (eqlist2? (cdr l1) (cdr l2))))
        ((or (atom? (car l1)) (atom? (car l2))) #f)
        (else (and (eqlist2? (car l1) (car l2)) (eqlist2? (cdr l1) (cdr l2)))))))

;; eq_s_exp
(define eq_s_exp?
    (lambda (s1 s2)
        (cond
            ((and (atom? s1) (atom? s2)) (eqan? s1 s2))
            ((or (atom? s1) (atom? s2)) #f)
            (else (eqlist? s1 s2)))))


(define eqlist?
    (lambda (l1 l2)
        (cond
            ((and (null? l1) (null? l2)) #t)
            (( or (null? l1) (null? l2)) #f)
            (else
                (and (eq_s_exp? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2)))))))

; remove s-expression from a list
(define rember
    (lambda (s l)
        (cond
            ((null? l) '())
            ((equal? (car l) s) (rember s (cdr l)))
            (else (cons (car l) (rember s (cdr l)))))))


; numbered?
(define numbered?
    (lambda (aexp)
        (cond
            ((atom? aexp) (number? aexp))
            (else (and (numbered? (car aexp)) (numbered? (car (cdr (cdr aexp)))))))))

; compute '(3 + 4)
(define value
    (lambda (nexp)
        (cond
            ((atom? nexp) nexp)
            ((eq? (car (cdr nexp)) '+ ) (+ (value (car nexp)) (value (car (cdr (cdr nexp))))))
            ((eq? (car (cdr nexp)) '- ) (- (value (car nexp)) (value (car (cdr (cdr nexp))))))
            ((eq? (car (cdr nexp)) '* ) (* (value (car nexp)) (value (car (cdr (cdr nexp))))))
            (else
            (/ (value (car nexp)) (value (car (cdr (cdr nexp)))))))))


; 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)))

; compute '(+ 3 4)
(define value1
    (lambda (nexp)
        (cond
            ((atom? nexp) nexp)
            ((eq? (operator nexp) '+) (+ (value1 (fst-sub-exp nexp)) (value1 (sec-sub-exp nexp))))
            ((eq? (operator nexp) '-) (- (value1 (fst-sub-exp nexp)) (value1 (sec-sub-exp nexp))))
            ((eq? (operator nexp) '*) (* (value1 (fst-sub-exp nexp)) (value1 (sec-sub-exp nexp))))
            (else
            (/ (value1 (fst-sub-exp nexp)) (value1 (sec-sub-exp nexp)))))))


; member
(define member?
    (lambda (s lat)
        (cond
            ((null? lat) #f)
            (else (or (eq_s_exp? (car lat) s) (member? s (cdr lat)))))))

; set? whether a lat is a set
(define set?
    (lambda (lat)
        (cond
            ((null? lat) #t)
            ((member? (car lat) (cdr lat)) #f)
            (else (set? (cdr lat))))))

;makeset
(define makeset
    (lambda (lat)
        (cond
            ((null? lat) '())
            ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
            (else (cons (car lat) (makeset (cdr lat)))))))

;; multiple remove a atom from a list
(define multirember
    (lambda (a lat)
        (cond
            ((null? lat) '())
            ( (eq? (car lat) a)
                (multirember a (cdr lat)))
            (else (cons (car lat) (multirember a (cdr lat)))))))


;;rewrite makeset with multirember
(define makeset2
    (lambda (lat)
        (cond
            ((null? lat) '())
            (else (cons (car lat) (makeset2 (multirember (car lat) (cdr lat))))))))


;check whether each atom in set 1 is also in set2;subset
(define subset?
    (lambda (set1 set2)
        (cond
            ((null? set1) #t)
            (else (cond
                    ((member? (car set1 ) set2) (subset? (cdr set1) set2))
                    (else #f))))))

(define subset2?
    (lambda (set1 set2)
        (cond
            ((null? set1) #t)
            ((member? (car set1) set2) (subset? (cdr set1) set2))
            (else #f))))

; two set are equal
(define eqset?
    (lambda (set1 set2)
        (and (subset? set1 set2) (subset? set2 set1))))

(define eqset2?
    (lambda (set1 set2)
        (cond
            ((subset? set1 set2) (subset? set2 set1))
            (else #f))))

;intersect?
(define intersect?
    (lambda (set1 set2)
        (cond
            ((null? set1) #f)
            ((member? (car set1) set2) #t)
            (else (intersect? (cdr set1) set2)))))


(define intersect
    (lambda (set1 set2)
        (cond
            ((null? set1) '())
            ((member? (car set1) set2) (cons (car set1) (intersect (cdr set1) set2)))
            (else (intersect (cdr set1) set2)))))

;union
(define union
    (lambda (set1 set2)
        (cond
            ((null? set1) set2)
            ((member? (car set1) set2) (union (cdr set1) set2))
            (else (cons (car set1) (union (cdr set1) set2))))))


;set difference
(define difference
    (lambda (set1 set2)
        (cond
            ((null? set1) '())
            ((member? (car set1) set2) (difference (cdr set1) set2))
            (else (cons (car set1) (difference (cdr set1) set2))))))

;intersectall l-set: list of sets
(define intersectall
    (lambda (l-set)
        (cond
            ((null? (cdr l-set)) (car l-set))
            (else (intersect (car l-set) (intersectall (cdr l-set)))))))

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

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



(define a-pair?
    (lambda (x)
        (cond
            ((null? x) #f)
            ((atom? x) #f)
            ((null? (cdr x)) #f)
            ((null? (cdr (cdr x))) #t)
            (else #f))))


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

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

(define revpair
    (lambda (p)
        (build (second p) (first p))))


(define build
    (lambda (s1 s2)
        (cond
            (else (cons s1 (cons s2 '()))))))

(define third
    (lambda (l)
        (car (cdr (cdr l)))))

;; check an atom whether a member of a list
(define member?
    (lambda (a lat)
        (cond
            ((null? lat) #f)
            (else (or (eq? (car lat) a)
                    (member? a (cdr lat)))))))

; set? whether a lat is a set
(define set?
    (lambda (lat)
        (cond
            ((null? lat) #t)
            ((member? (car lat) (cdr lat)) #f)
            (else (set? (cdr lat))))))

;; get all the car of the list
(define firsts
    (lambda (lat)
        (cond
            ((null? lat) '())
            (else (cons (car (car lat)) (firsts(cdr lat)))))))

;;get all the second of the list
(define seconds
    (lambda (lat)
        (cond
            ((null? lat) '())
            (else
                (cons (car (cdr (car lat))) (seconds (cdr lat)))))))


; rel: relation, list of pairs and set of pairs
(define fun?
    (lambda (rel)
        (set? (firsts rel))))


(define revrel
    (lambda (rel)
        (cond
            ((null? rel) '())
            (else
                (cons (build (second (car rel)) (first (car rel)))
                    (revrel (cdr rel)))))))

(define revrel1
    (lambda (rel)
        (cond
            ((null? rel) '())
            (else
                (cons (revpair (car rel)) (revrel1 (cdr rel)))))))

(define fullfun?
    (lambda (fun)
        (set? (seconds fun))))


(define one-to-one?
    (lambda (fun)
        (fun? (revrel fun))))

#
eq? tests just for the same object (essentially a pointer comparison). This is fast, and can be used when searching for a particular object, or when working with symbols or keywords (which are always unique objects).
eqv? extends eq? to look at the value of numbers and characters. It can for instance be used somewhat like = (see Comparison) but without an error if one operand isn’t a number.
equal? goes further, it looks (recursively) into the contents of lists, vectors, etc. This is good for instance on lists that have been read or calculated in various places and are the same, just not made up of the same pairs. Such lists look the same (when printed), and equal? will consider them the same.
Generally eqv? below should be used when comparing numbers or characters.