the little schemer practice

the-little-schemer.scm

;
(define (atom? x)
  (and (not (pair? x)) (not (null? x))))

; consist of atoms
(define (lat? l)
  (cond
    ((null? l) #f)
    ((atom? (car l)) (lat? (cdr l)))
    (else #f)))

;
(define (rember a l)
  (cond
    ((null? l) '())
    ((eq? a (car l)) (cdr l))
    (else 
     (cons (car l) (rember a (cdr l))))))

; argument is one list, with each as a list
(define firsts 
  (lambda (l)
    (cond
      ((null? l) '())
      (else (cons (car (car l)) (firsts (cdr l)))))))

; 
(define insertR 
  (lambda (new old lat)
    (cond
      ((null? lat) '())
      ((eq? old (car lat)) 
       (cons old (cons new (cdr lat))))
      (else 
       (cons (car lat) (insertR new old (cdr lat)))))))
;
(define insertL
  (lambda (new old lat)
    (cond
      ((null? lat) '())
      ((eq? old (car lat)) (cons new lat))
      (else
       (cons (car lat) (insertL new old (cdr lat)))))))
;
(define subst
  (lambda (new old lat)
    (cond 
      ((null? lat) '())
      ((eq? old (car lat)) (cons new (cdr lat)))
      (else
       (cons (car lat) (subst new old (cdr lat)))))))
;
(define subst2
  (lambda (new o1 o2 lat)
    (cond 
      ((null? lat) '())
      ; ((eq? o1 (car lat)) (cons new (cdr lat)))
      ; ((eq? o2 (car lat)) (cons new (cdr lat)))
      ((or (eq? o1 (car lat)) (eq? o2 (car lat)))
       (cons new (cdr lat)))
      (else 
       (cons (car lat) (subst2 new o1 o2 (cdr lat)))))))
;
(define multirember
  (lambda (a lat)
    (cond
      ((null? lat) '())
      ((eq? a (car lat)) (multirember a (cdr lat)))
      (else 
       (cons (car lat) (multirember a (cdr lat)))))))
;
(define multiinsertR
  (lambda (new old lat)
    (cond 
      ((null? lat) '())
      ((eq? old (car lat)) 
       (cons old (cons new (multiinsertR new old (cdr lat)))))
      (else 
       (cons (car lat) (multiinsertR new old (cdr lat)))))))
;
(define multiinsertL
  (lambda (new old lat)
    (cond
      ((null? lat) '())
      ((eq? old (car lat))
       (cons new (cons old (multiinsertL new old (cdr lat)))))
      (else 
       (cons (car lat) (multiinsertL new old (cdr lat)))))))
;
; 4th commandment
;
(define multisubst
  (lambda (new old lat)
    (cond 
      ((null? lat) '())
      ((eq? old (car lat)) 
       (cons new (multisubst new old (cdr lat))))
      (else 
       (cons (car lat) (multisubst new old (cdr lat)))))))
;

;;;; chapter 4 ;;;;
; non-negative integers
(define integer>=0?
  (lambda (x)
    (and (integer? x) (>= x 0))))
;
(define add1 (lambda (x) (+ x 1)))
(define (sub1 x) (- x 1))
;;;;
; define add, using zero?, add1, sub1
(define (o+ n m)
  (cond
    ((zero? m) n)
    (else (add1 (o+ n (sub1 m))))))
;
(define (o- n m)
  (cond 
    ((zero? m) n)
    (else (sub1 (o- n (sub1 m))))))
;
(define (tup? lat)
  (cond 
    ((null? lat) #t)
    (else (and (integer>=0? (car lat)) (tup? (cdr lat))))))
;
(define (addup t)
  (cond 
    ((null? t) 0)
    (else (+ (car t) (addup (cdr t))))))
;
(define (o* n m)
  (cond 
    ((zero? m) 0)
    (else (+ n (o* n (sub1 m))))))
;
(define (tup+ tup1 tup2)
  (cond
    ((and (null? tup1) (null? tup2)) '())
    ((null? tup1) tup2)
    ((null? tup2) tup1)
    (else 
     (cons (+ (car tup1) (car tup2)) 
           (tup+ (cdr tup1) (cdr tup2))))))
; 
(define (o>= n m) 
  (cond
    ((zero? m) #t)
    ((zero? n) #f)    
    (else (o>= (sub1 n) (sub1 m)))))
;
(define (o< n m) 
  (not (o>= n m)))
;
(define (o<= n m)
  (cond 
    ((zero? n) #t)
    ((zero? m) #f)
    (else (o<= (sub1 n) (sub1 m)))))
;
(define (o> n m) 
  (not (o<= n m)))
;
(define (o== n m)
  (if (and (o>= n m) (o<= n m)) #t #f))
;
(define (** m n)
  (if (o== n 1) m (o* m (** m (sub1 n)))))

;quotient
(define (division m n)
  (if (< m n) 0 (+ 1 (reminder (- m n) n))))

;length
(define (_length lat)
  (if (null? lat) 0 (+ 1 (length (cdr lat)))))

;(list-ref list k), k is zero-based
(define (pick n lat)
  (cond 
    ((zero? (- n 1)) (car lat))
    (else 
     (pick (- n 1) (cdr lat)))))
;
(define (rempick n lat)
  (if (zero? (- n 1)) 
      (cdr lat)
      (cons (car lat) (rempick (- n 1) (cdr lat)))))

; index is zero-based
(define (list-remove list n)
  (rempick (- n 1) list))

; number? is primitive, can not be implemented
;
(define (no-nums lat) 
  (cond 
    ((null? lat) '())
    ((number? (car lat)) (no-nums (cdr lat)))
    (else (cons (car lat) (no-nums (cdr lat))))))

;
(define (all-nums lat)
  (cond 
    ((null? lat) '())
    ((number? (car lat)) (cons (car lat) (all-nums (cdr lat))))
    (else (all-nums (cdr lat)))))

;
(define eqan?
  (lambda (a1 a2)
    (cond 
      ((and (number? a1) (number? a2)) (= a1 a2)) ; both number
      ((or (number? a1) (number? a2)) #f) ; only one is number
      (else (eq? a1 a2))))) ; neither is number
;
(define occur
  (lambda (a lat)
    (cond 
      ((null? lat) 0)
      ((eqan? (car lat) a) (+ 1 (occur a (cdr lat))))
      (else (occur a (cdr lat))))))
;
(define (one? x) (= x 1))
;
;;;; chapter 5: star
(define (rember* a l)
  (cond 
    ((null? l) '())
    ((not (atom? (car l))) 
     (cons (rember* a (car l)) (rember* a (cdr l))))
    (else 
     (if (eq? a (car l))         
         (rember* a (cdr l))
         (cons (car l) (rember* a (cdr l)))))))
;
(define (insertR* new old l)
  (cond 
    ((null? l) '())
    ((list? (car l))
     (cons (insertR* new old (car l))
           (insertR* new old (cdr l))))
    (else 
     (if (eq? old (car l)) 
         (cons old (cons new (insertR* new old (cdr l))))
         (cons (car l) (insertR* new old (cdr l)))))))
;
(define (occur* a l)
  (cond 
    ((null? l) 0)
    ((list? (car l)) 
     (+ (occur* a (car l)) (occur* a (cdr l))))
    (else 
     (if (eq? a (car l))
         (+ 1 (occur* a (cdr l)))
         (occur* a (cdr l))))))
;
(define (subst* new old l)
  (cond 
    ((null? l) '())
    ((list? (car l))
     (cons (subst* new old (car l)) (subst* new old (cdr l))))
    (else 
     (if (eq? old (car l))
         (cons new (subst* new old (cdr l)))
         (cons (car l) (subst* new old (cdr l)))))))
;
(define (insertL* new old l)
  (cond 
    ((null? l) '())
    ((list? (car l))
     (cons (insertL* new old (car l)) (insertL* new old (cdr l))))
    (else 
     (if (eq? old (car l))
         (cons new l)
         (cons (car l) (insertL* new old (cdr l)))))))
;
(define (member* a l)
  (cond 
    ((null? l) #f)
    ((list? (car l)) 
     (or (member* a (car l)) (member* a (cdr l))))
    (else 
     (if (eq? a (car l)) #t (member* a (cdr l))))))
;
(define (leftmost l)
  (cond 
    ((atom? (car l)) (car l))
    (else (leftmost (car l)))))
(define (leftmost1 l)
  (if (atom? (car l)) (car l) (leftmost (car l))))

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

; s-expression is either an atom or an (possibly empty) list of s-expression
(define (equalp s1 s2)
  (cond 
    ((and (atom? s1) (atom? s2)) (eqan? s1 s2))
    ((or (atom? s1) (atom? s2)) #f)
    (else (eqlist? s1 s2))))

; using equal?
(define (equlistp l1 l2)
  (cond 
    ((and (null? l1) (null? l2)) #t)
    ((or (null? l1) (null? l2)) #f)
    (else 
     (and (equal? (car l1) (car l2)) (equal? (cdr l1) (cdr l2))))))
; 
(define (rember* s l)
  (cond 
    ((null? l) '())
    ((equal s (car l)) (cdr l))
    (else (cons (car l) (rember* s (cdr l))))))
;
;;;; chapter 6