Exercises from "The Little Schemer". Taking a break before hacking again on chapters 8-10.

the_little_schemer.ss

#lang scheme

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

(define lat?
    (lambda (l)
        (cond
            ((null? l) #t)
            ((atom? (car l)) (lat? (cdr l)))
            (else #f))))

(define member?
    (lambda (a lat)
        (cond
            ((null? lat) #f)
            (else
                (or
                    (eq? a (car lat))
                    (member? a (cdr lat)))))))


(define rember
    (lambda (a lat)
        (cond
            ((null? lat) '())
            ((eq? (car lat) a) (cdr lat))
            (else
                (cons (car lat) (rember a (cdr lat)))))))
                    

(define firsts
    (lambda (l)
        (cond
            ((null? l) '())
            (else
                (cons (car (car l)) (firsts (cdr l)))))))

(define insertR
    (lambda (new old lat)
        (cond
            ((null? lat) '())
            (else
                (cond
                    ((eq? (car lat) old) (cons old (cons new (cdr lat))))
                    (else
                        (cons (car lat) (insertR new old (cdr lat)))))))))

(define add1
    (lambda (n)
        (+ n 1)))

(define sub1
    (lambda (n)
        (- n 1)))
        
(define o+
    (lambda (n m)
        (cond
            ((zero? m) n)
            (else
                (o+ (add1 n) (sub1 m))))))
                
(define o-
    (lambda (n m)
        (cond
            ((zero? m) n)
            (else
                (o- (sub1 n) (sub1 m))))))

(define addtup
    (lambda (tup)
        (cond
            ((null? tup) 0)
            (else (o+ (car tup) (addtup(cdr tup)))))))

; (addtup '(1 2 3 4 5 6 7 8 9))

(define o*
    (lambda (n m)
        (cond
            ((zero? m) 0)
            (else (o+ n (o* n (sub1 m)))))))
                
(define tup+
    (lambda (tup1 tup2)
        (cond
            ((null? tup1) tup2)
            ((null? tup2) tup1)
            (else
                (cons (o+ (car tup1) (car tup2)) (tup+ (cdr tup1) (cdr tup2)))))))

; (tup+ '(3 7) '(4 6 8 1))

(define >
    (lambda (n m)
        (cond
            ((zero? n) #f)
            ((zero? m) #t)
            (else
                (> (sub1 n) (sub1 m))))))

(define <
    (lambda (n m)
        (cond
            ((zero? m) #f)
            ((zero? n) #t)
            (else
                (< (sub1 n) (sub1 m))))))

(define =
    (lambda (n m)
        (cond
            ((< n m) #f)
            ((> n m) #f)
            (else #t))))

(define expt
    (lambda (n m)
        (cond
            ((zero? m) 1)
            (else
                (* n (expt n (sub1 m)))))))

(define quotient
    (lambda (n m)
        (cond
            ((> m n) 0)
            (else
                (add1 (quotient (- n m) m))))))

(define length
    (lambda (lat)
        (cond
            ((null? lat) 0)
            (else
                (add1 (length (cdr lat)))))))
                
; (length '(ham and cheese on rye))                

(define pick
    (lambda (n lat)
        (cond
            ((null? lat) "nada")
            ((zero? (sub1 n)) (car lat))
            (else
                (pick (sub1 n) (cdr lat))))))
                
; (pick 4 '(lasagna spaghetti ravioli macaroni meatball))                

;(define rempick
;    (lambda (n lat)
;        (cond
;            ((zero? (sub1 n)) (cdr lat))
;            ((null? lat) '())
;            (else
;                (cons (car lat) (rempick (sub1 n) (cdr lat)))))))
                
; (rempick 3 '(hotdogs with hot mustard))
                    
(define no-nums
    (lambda (lat)
        (cond
            ((null? lat) '())
            (else
                (cond
                    ((number? (car lat)) (no-nums (cdr lat)))
                    (else
                        (cons (car lat) (no-nums (cdr lat)))))))))
                        
; (no-nums '(5 pears 6 prunes 9 dates))                        

(define all-nums
    (lambda (lat)
        (cond
            ((null? lat) '())
            (else
                (cond
                    ((number? (car lat)) (cons (car lat) (all-nums (cdr lat))))
                    (else
                        (all-nums (cdr lat))))))))
                        
; (all-nums '(5 pears 6 prunes 9 dates))                        

(define equan?
    (lambda (a1 a2)
        (cond
            ((and (number? a1) (number? a2)) (= a1 a2))
            ((or (number? a1) (number? a2)) #f)
            (else
                (eq? a1 a2)))))

(define occur
    (lambda (a lat)
        (cond
            ((null? lat) 0)
            (else
                (cond
                    ((equan? (car lat) a) add1(occur a (cdr lat)))
                    (else 
                        (occur a (cdr lat))))))))
                        
(define one?
    (lambda (n)
            (= n 1)))
            
(define rempick
    (lambda (n lat)
        (cond
            ((one? n) (cdr lat))
            ((null? lat) '())
            (else
                (cons (car lat) (rempick (sub1 n) (cdr lat)))))))
                
; (rempick 3 '(hotdogs with hot mustard))

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

; (rember* 'cup (quote ((coffee) cup ((tea) cup) (and (hick)) cup)))

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

; (insertR* 'roast 'chuck (quote ((how much (wood)) could ((a (wood) chuck)) (((chuck))) (if (a) ((wood chuck))) could chuck wood)))

(define occur*
    (lambda (a l)
        (cond
            ((null? l) 0)
            ((atom? (car l)) 
                (cond
                    ((eq? (car l) a) (add1 (occur* a (cdr l))))
                    (else
                        (occur* a (cdr l)))))
            (else
                (o+ (occur* a (car l)) (occur* a (cdr l)))))))
            
; (occur* 'banana '((banana) (split ((((banana ice))) (cream (banana)) sherbet)) (banana) (bread (banana brandy))))

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

; (subst* 'orange 'banana '((banana) (split ((((banana ice))) (cream (banana)) sherbet)) (banana) (bread) (banana brandy)))

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

; (insertL* 'pecker 'chuck '((how much (wood)) could ((a (wood) chuck)) (((chuck))) (if (a) ((wood chuck))) could chuck wood))

(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)))))))
            
; (member* 'chips '((potato) (chips ((with) fish) (chips))))

(define leftmost
    (lambda (l)
        (cond
            ((atom? (car l)) (car l))
            (else
                (leftmost (car l))))))
                
; (leftmost '(((hot) (tuna (and))) cheese))                
; (leftmost '())

;(define eqlist?
;    (lambda (l1 l2)
;        (cond
;            ((null? l1)
;                (cond
;                    ((null? l2) #t)
;                    (else #f)))
;            ((atom? (car l1))
;                (cond
;                    ((atom? (car l2)) (and (equan? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2))))
;                    (else #f)))
;            (else
;                (cond
;                    ((null? l2) #f)
;                    (else
;                        (and (eqlist? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2)))))))))
            
; (eqlist? '(a b c) '(a b d))            

(define equal?
    (lambda (s1 s2)
        (cond
            ((and (atom? s1) (atom? s2)) (equan? s1 s2))
            ((or (atom? s1) (atom? s2)) #f)
            (else
                eqlist? s1 s2))))
                
; (equal? 'a '())                

(define eqlist?
    (lambda (l1 l2)
        (cond
            ((and (null? l1) (null? l2)) #t)
            ((or (null? l1) (null? l2)) #f)
            (else
                (and (equal? (car l1) (car l2)) (eqlist? (cdr l1) (cdr l2)))))))
                        
; (eqlist? '(a b c) '(a b c))            

(define REMBER
    (lambda (s l)
        (cond
            ((null? l) '())
            ((equal? (car l) s) (cdr l))
            (else
                (cons (car l) (REMBER s (cdr l)))))))
                
; (REMBER 'a '(b (a) c))                

; (eq? (quote a) 'a)

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

; (numbered? '(3 + b))

;(define value
;    (lambda (nexp)
;        (cond
;            ((atom? nexp) nexp)
;            ((eq? (car (cdr nexp)) (quote +)) (o+ (value (car nexp)) (value (car (cdr (cdr nexp))))))
;            ((eq? (car (cdr nexp)) (quote x)) (*  (value (car nexp)) (value (car (cdr (cdr nexp))))))
;            (else
;                (expt (value (car nexp) (value (car (cdr (cdr nexp))))))))))
                
; (value (quote (1 + (3 x 5))))                

(define 1st-sub-exp
    (lambda (aexp)
        (car (cdr aexp))))

; (1st-sub-exp '(+ (+ 2 4) (x 3 6)))

(define 2nd-sub-exp
    (lambda (aexp)
        (car (cdr (cdr aexp)))))
        
(define operator
    (lambda (aexp)
        (car aexp)))        
        
(define value
    (lambda (aexp)
        (cond
            ((atom? aexp) aexp)
            ((eq? (operator aexp) (quote +)) (o+ (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp))))
            ((eq? (operator aexp) (quote x)) (*  (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp))))
            (else
                (expt (value (1st-sub-exp aexp)) (value (2nd-sub-exp aexp)))))))
                
;(value '(+ (x 3 6) (^ 8 2)))

(define sero?
    (lambda (n)
        (null? n)))
        
; (sero? '())        

(define edd1
    (lambda (n)
        (cons '() n)))
        
; (edd1 (edd1 '()))

(define zub1
    (lambda (n)
        (cdr n)))

; (zub1 '(() () ()))

(define oo+
    (lambda (n m)
        (cond
            ((sero? m) n)
            (else
                (edd1 (oo+ n (zub1 m)))))))
                
; (oo+ '(()) '(() ()))                

; (lat? '(() ()))                

(define set?
    (lambda (lat)
        (cond
            ((null? lat) #t)
            ((member? (car lat) (cdr lat)) #f)
            (else
                (set? (cdr lat))))))
                        
; (set? '(a b c d))                            

(define makeset
    (lambda (lat)
        (cond
            ((null? lat) null)
            (else
                (cons (car lat) (makeset (rember* (car lat) (cdr lat))))))))
                
; (makeset '(apple peach pear peach plum apple lemon peach))                
            
(define subset?
    (lambda (set1 set2)
        (cond
            ((null? set1) #t)
            (else
                (and
                    (member? (car set1) set2)
                    (subset? (cdr set1) set2))))))

; (subset? '(a b c) '(a b d f r a c))      

; my "stupid way"
;(define eqset?
;    (lambda (set1 set2)
;        (cond
;            ((and (null? set1) (null? set2)) #t)
;            ((or  (null? set1) (null? set2)) #f)
;            (else
;                (eqset? (rember (car set1) set1) (rember (car set1) set2))))))
 
(define eqset?
    (lambda (set1 set2)
        (and
            (subset? set1 set2)
            (subset? set2 set1))))
               
; (eqset? '(a b c) '(a c b r))                      

(define intersect?
    (lambda (set1 set2)
        (cond
            ((null? set1) #f)
            (else (or
                (member? (car set1) set2)
                (intersect? (cdr set1) set2))))))
                
; (intersect? '(a b c) '(r f s e c))                

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

;(intersect '(r f s a e c) '(a b c))                

(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))))))
                
;(union '(r f s a e c) '(a b c))                

(define diff
    (lambda (set1 set2)
        (cond
            ((null? set1) null)
            ((member? (car set1) set2) (diff (cdr set1) set2))
            (else
                (cons (car set1) (diff (cdr set1) set2))))))
                
; (diff '(r f s a e c) '(a b c))                

; my less-elegant way
;(define intersectall
;    (lambda (l-set)
;        (cond
;            ((lat? l-set) l-set)
;            ((equan? (length l-set) 1) (car l-set))
;            (else
;                (intersect (car l-set) (intersectall (cdr l-set)))))))

(define intersectall
    (lambda (l-set)
        (cond
            ((null? (cdr l-set)) (car l-set))
            (else
                (intersect (car l-set) (intersectall (cdr l-set)))))))
                
; (intersectall '((a b c) (c a d e) (e f g h a b)))

(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)
        (car p)))
        
(define second
    (lambda (p)
        (car (cdr p))))        
        
(define build
    (lambda (s1 s2)
        (cons s1 (cons s2 null))))        
        
; (build 'a '(a a))        

(define third
    (lambda (l)
        (car (cdr (cdr l)))))
        
(define fun?
    (lambda (rel)
        (set? (firsts rel))))        
        
; my version is a bit different in style
(define revrel
    (lambda (rel)
        (cond
            ((null? rel) null)
            ((and (a-pair? rel) (lat? rel)) (build (second rel) (first rel)))
            (else
                (cons (revrel (car rel)) (revrel (cdr rel)))))))
                
; (revrel '((8 a) (pumpkin pie) ( got sick)))                

(define seconds
    (lambda (l)
        (cond
            ((null? l) null)
            (else
                (cons (second (car l)) (seconds (cdr l)))))))
                
(define fullfun?
    (lambda (fun)
        (set? (seconds fun))))
        
; ( fullfun? '((grape raisin) (plum prune) (stewed grape)))        

;(define rember-f
;    (lambda (test? a l)
;        (cond
;            ((null? l) null)
;            ((test? (car l) a) (cdr l))
;            (else
;                (cons (car l) (rember-f test? a (cdr l)))))))
                
; (rember-f = 5 '(6 2 5 3))                

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

;(eq?-salad 'salad)
;(eq?-salad 'tuna)
;((eq?-c 'salad) 'tuna)

(define rember-f
    (lambda (test?)
        (lambda (a l)
            (cond
                ((null? l) null)
                ((test? (car l) a) (cdr l))
                (else
                    (cons (car l) ((rember-f test?) a (cdr l))))))))
                    
                    
; ((rember-f eq?) 'tuna '(shrim salad and tuna salad))

(define insertL-f
    (lambda (test?)
        (lambda (new old l)
            (cond
                ((null? l) null)
                ((test? (car l) old) (cons new (cons old (cdr l))))
                (else
                    (cons (car l) ((insertL-f test?) new old (cdr l))))))))
                    
; ((insertL-f eq?) 'n 'o '(a b c o d)) 

(define insertR-f
    (lambda (test?)
        (lambda (new old l)
            (cond
                ((null? l) null)
                ((test? (car l) old) (cons old (cons new (cdr l))))
                (else
                    (cons (car l) ((insertR-f test?) new old (cdr l))))))))
                    
(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) null)
                ((eq? (car l) old) (seq new old (cdr l)))
                (else
                    (cons (car l) ((insert-g seq) new old (cdr l))))))))
                    
(define insertL (insert-g seqL))                    

;(define insertR (insert-g seqR))

;(define insertL (insert-g (lambda (new old l) (cons (new (cons old l))))))

(define seqS
    (lambda (new old l)
        (cons new l)))
        
(define subst (insert-g seqS))        

(define atom-to-function
    (lambda (x)
        (cond
            ((eq? x (quote +)) o+)
            ((eq? x (quote x)) *)
            (else
                exp))))
                
(define valueNEW
    (lambda (nexp)
        (cond
            ((atom? nexp) nexp)
            (else
                ((atom-to-function (operator nexp)) (valueNEW (1st-sub-exp nexp)) (valueNEW (2nd-sub-exp nexp)))))))
                
; (valueNEW '(x 3 4))                

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

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

(define multimemberT
    (lambda (test? lat)
        (cond
            ((null? lat) null)
            ((test? (car lat)) (multimemberT test? (cdr lat)))
            (else
                (cons (car lat) (multimemberT test? (cdr lat)))))))
                
; (multimemberT eq?-tuna '(shrimp salad tuna salad and tuna))                

(define a-frined
    (lambda (x y)
        (null? y)))
        
; TODO: come back to multiinsertLR&co

;(define even?
;    (lambda (n)
;        (= (* (/ n 2) 2) n)))

(define (even? x) (= (remainder x 2) 0))
        
(define evens-only*
    (lambda (l)
        (cond
            ((null? l) null)
            ((atom? (car l))
                (cond
                    ((even? (car l)) (cons (car l) (evens-only* (cdr l))))
                    (else
                        (evens-only* (cdr l)))))
            (else
                (cons (evens-only* (car l)) (evens-only* (cdr l)))))))
                
; not idea yet how it works
(define evens-only-new*
    (lambda (lat col)
        (cond
            ((null? lat) (col null 0))
            ((even? (car lat)) (evens-only-new* (cdr lat)  
                (lambda (newlat s)
                    (col (cons (car lat) newlat) (add1 s)))))
            (else
                (evens-only-new* (cdr lat)
                    (lambda (newlat s)
                        (col newlat s)))))))

(define col-new
    (lambda (l s)
        (build s l)))

;(evens-only-new* '(1 2 4 6 8 10 11) col-new)

; (pick 1 '(a b c d e f))

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

; (looking 'a '(2 4 b a d))

(define eternity
    (lambda (x)
        (eternity x)))
        
; (eternity 3)        

(define shift
    (lambda (pair)
        (build (first (first pair)) (build (second (first pair)) (second pair)))))
        
(shift '((a b) (c d)))