Little schemer in clojure

littleschemer.clj

(defn atom? [x]
  (not (list? x)))

(def car first)
(def cdr next)
(def add1 inc)
(def sub1 dec)

(defn lat? [lst]
  (every? atom? lst))

(defn lat2? [lst]
  (cond
   (nil? lst) true
   (atom? (car lst)) (lat2? (cdr lst))
   :else false))

(defn member? [a lat]
  (if (nil? lat)
    false
    (or (= a (car lat))
        (member? a (cdr lat)))))

(defn rember [a lat]
  (cond
   (empty? lat) '()
   (= a (car lat)) (cdr lat)
   :else (cons (car lat) (rember a (cdr lat)))))

(defn firsts [lst]
  (if (nil? lst)
    nil
    (cons (car (car lst))
          (firsts (cdr lst)))))

(defn insertR [new old lat]
  (cond
   (empty? lat) '()
   (= old (car lat)) (cons old
                           (cons new
                                 (cdr lat)))
   :else (cons (car lat)
               (insertR new old (cdr lat)))))

(defn insertL [new old lat]
  (cond
   (empty? lat) '()
   (= old (car lat)) (cons new lat)
   :else (cons (car lat)
               (insertL new old (cdr lat)))))

(defn subst [new old lat]
  (cond
   (empty? lat) '()
   (= (car lat) old) (cons new (cdr lat))
   :else (cons (car lat)
               (subst new old (cdr lat)))))

(defn subst2 [new old1 old2 lat]
  (cond
   (empty? lat) '()
   (or (= (car lat) old1) (= (car lat) old2)) (cons new (cdr lat))
   :else (cons (car lat)
               (subst2 new old1 old2 (cdr lat)))))

(defn multirember [a lat]
  (cond
   (empty? lat) '()
   (= a (car lat)) (multirember a (cdr lat))
   :else (cons (car lat)
               (multirember a (cdr lat)))))

(defn multiinsertR [new old lat]
  (cond
   (empty? lat) '()
   (= old (car lat)) (cons old
                           (cons new
                                 (multiinsertR new old (cdr lat))))
   :else (cons (car lat)
               (multiinsertR new old (cdr lat)))))

(defn multiinsertL [new old lat]
  (cond
   (empty? lat) '()
   (= old (car lat)) (cons new
                           (cons old
                                 (multiinsertL new old (cdr lat))))
   :else (cons (car lat)
               (multiinsertL new old (cdr lat)))))

(defn multisubst [new old lat]
  (cond
   (empty? lat) '()
   (= old (car lat)) (cons new
                           (multisubst new old (cdr lat)))
   :else (cons (car lat)
               (multisubst new old (cdr lat)))))

(defn o+ [n m]
  (cond
   (zero? m) n
   :else (add1 (o+ n (sub1 m)))))

(defn o- [n m]
  (cond
   (zero? m) n
   :else (sub1 (o- n (sub1 m)))))

(defn addtup [tup]
  (cond
   (empty? tup) 0
   :else (+ (car tup)
            (addtup (cdr tup)))))

(defn x [n m]
  (cond
   (zero? m) 0
   :else (+ n (x n (sub1 m)))))

(defn tup+ [tup1 tup2]
  (cond
   (empty? tup1) tup2
   (empty? tup2) tup1
   :else (cons (+ (car tup1)
                  (car tup2))
               (tup+ (cdr tup1)
                     (cdr tup2)))))

(defn o> [n m]
  (cond
   (zero? n) false
   (zero? m) true
   :else (o> (sub1 n) (sub1 m))))

(defn o< [n m]
  (cond
   (zero? m) false
   (zero? n) true
   :else (o< (sub1 n) (sub1 m))))

(defn o= [n m]
  (cond
   (< n m) false
   (> n m) false
   :else true))

(defn exp [n m]
  (cond
   (zero? m) 1
   :else (x n (exp n (sub1 m)))))

(defn div [n m]
  (cond
   (< n m) 0
   :else (add1 (div (- n m) m))))

(defn length* [lat]
  (cond
   (empty? lat) 0
   :else (add1 (length* (cdr lat)))))

(defn pick [n lat]
  (cond
   (o< n 1) nil
   (o= n 1) (car lat)
   :else (pick (sub1 n) (cdr lat))))

(defn rempick [n lat]
  (cond
   (o< n 1) lat
   (o= n 1) (cdr lat)
   :else (cons (car lat)
               (rempick (sub1 n)
                        (cdr lat)))))

(defn no-nums [lat]
  (cond
   (empty? lat) '()
   (number? (car lat)) (no-nums (cdr lat))
   :else (cons (car lat)
               (no-nums (cdr lat)))))

(defn all-nums [lat]
  (cond
   (empty? lat) '()
   (number? (car lat)) (cons (car lat)
                             (all-nums (cdr lat)))
   :else (all-nums (cdr lat))))

(defn eqan? [a1 a2]
  (cond
   (and (number? a1) (number? a2)) (o= a1 a2)
   (or (number? a1) (number? a2)) false
   :else (= a1 a2)))

(defn occur [a lat]
  (cond
   (empty? lat) 0
   (eqan? a (car lat)) (add1 (occur a (cdr lat)))
   :else (occur a (cdr lat))))

(defn one? [n]
  (= 1 n))

(defn rempick2 [n lat]
  (cond
   (o< n 1) lat
   (one? n) (cdr lat)
   :else (cons (car lat)
               (rempick2 (sub1 n)
                         (cdr lat)))))

(defn rember* [a l]
  (cond
   (empty? l) '()
   (atom? (car l)) (cond
                    (= a (car l)) (rember* a (cdr l))
                    :else (cons (car l)
                                (rember* a (cdr l))))
   :else (cons (rember* a (car l))
               (rember* a (cdr l)))))

(defn insertR* [new old l]
  (cond
   (empty? l) '()
   (atom? (car l)) (cond
                    (= old (car l)) (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)))))

(defn occur* [a l]
  (cond
   (empty? l) 0
   (atom? (car l)) (cond
                    (= a (car l)) (add1 (occur* a (cdr l)))
                    :else (occur* a (cdr l)))
   :else (+ (occur* a (car l))
            (occur* a (cdr l)))))

(defn subst* [new old l]
  (cond
   (empty? l) '()
   (atom? (car l)) (cond
                    (= old (car l)) (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)))))

(defn insertL* [new old l]
  (cond
   (empty? l) '()
   (atom? (car l)) (cond
                    (= old (car l)) (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)))))

(defn member* [a l]
  (cond
   (empty? l) false
   (atom? (car l)) (or
                    (= a (car l))
                    (member* a (cdr l)))
   :else (or (member* a (car l))
             (member* a (cdr l)))))

(defn leftmost [l]
  (cond
   (atom? (car l)) (car l)
   :else (leftmost (car l))))

(defn eqlist? [l1 l2]
  (cond
   (and (empty? l1) (empty? l2)) true
   (or (empty? l1) (empty? l2)) false
   (and (atom? (car l1)) (atom? (car l2))) (and (eqan? (car l1) (car l2))
                                                (eqlist? (cdr l1) (cdr l2)))
   (or (atom? (car l1)) (atom? (car l2))) false
   :else (and (eqlist? (car l1) (car l2))
              (eqlist? (cdr l1) (cdr l2)))))

(declare eqlist2?)

(defn equal2? [s1 s2]
  (cond
   (and (atom? s1) (atom? s2)) (and (eqan? s1 s2))
   (or (atom? s1) (atom? s2)) false
   :else (eqlist2? s1 s2)))

(defn eqlist2? [l1 l2]
  (cond
   (and (empty? l1) (empty? l2)) true
   (or (empty? l1) (empty? l2)) false
   :else (and (equal2? (car l1) (car l2))
              (equal2? (cdr l1) (cdr l2)))))

(defn numbered? [aexp]
  (cond
   (atom? aexp) (number? aexp)
   :else (and (numbered? (car aexp))
              (numbered? (car (cdr (cdr aexp)))))))

(defn value [nexp]
  (cond
   (atom? nexp) nexp
   (= '+ (car (cdr nexp))) (+ (value (car nexp)) (value (car (cdr (cdr nexp)))))
   (= '- (car (cdr nexp))) (- (value (car nexp)) (value (car (cdr (cdr nexp)))))
   :else (Math/pow (car nexp)
                   (car (cdr (cdr nexp))))))

(defn sero? [n]
  (empty? n))

(defn edd1 [n]
  (cons '() n))

(defn zub1 [n]
  (cdr n))

(defn pluz [n m]
  (cond
   (sero? m) n
   :else (edd1 (pluz n (zub1 m)))))

(defn latz? [l]
  (cond
   (empty? l) true
   (empty? (car l)) (latz? (cdr l))
   :else false))

(defn zet? [lat]
  (cond
   (empty? lat) true
   (member? (car lat) (cdr lat)) false
   :else (zet? (cdr lat))))

(defn makeset [lat]
  (cond
   (zet? lat) lat
   (member? (car lat) (cdr lat)) (makeset (cdr lat))
   :else (cons (car lat) (makeset (cdr lat)))))

(defn makeset2 [lat]
  (cond
   (empty? lat) '()
   :else (cons (car lat)
               (makeset (multirember (car lat) (cdr lat))))))

(defn subzet? [set1 set2]
  (cond
   (empty? set1) true
   (member? (car set1) set2) (subzet? (cdr set1) set2)
   :else false))

(defn eqset? [set1 set2]
  (and (subzet? set1 set2)
       (subzet? set2 set1)))

(defn intersect? [set1 set2]
  (cond
   (empty? set1) false
   (member? (car set1) set2) true
   :else (intersect? (cdr set1) set2)))

(defn intersect [set1 set2]
  (cond
   (empty? set1) '()
   (member? (car set1) set2) (cons (car set1) (intersect (cdr set1) set2))
   :else (intersect (cdr set1) set2)))

(defn unionz [set1 set2]
  (cond
   (empty? set1) set2
   (member? (car set1) set2) (unionz (cdr set1) set2)
   :else (cons (car set1)
               (unionz (cdr set1) set2))))

(defn intersectall [l-set]
  (cond
   (empty? (cdr l-set)) (car l-set)
   :else (intersect (car l-set)
                    (intersectall (cdr l-set)))))

(defn pair? [x]
  (= 2 (length* x)))

(defn frst [x]
  (car x))

(defn scnd [x]
  (car (cdr x)))

(defn build [s1 s2]
  (cons s1 (cons s2 '())))

(defn thrd [x]
  (car (cdr (cdr x))))

(defn fun? [rel]
  (set? (firsts rel)))

(defn revrel [rel]
  (cond
   (empty? rel) '()
   :else (cons
          (build (scnd (car rel))
                 (frst (car rel)))
          (revrel (cdr rel)))))

(defn revpair [x]
  (build (scnd x) (first x)))

(defn revrel2 [rel]
  (cond
   (empty? rel) '()
   :else (cons (revpair (car rel))
               (revrel2 (cdr rel)))))

(defn seconds [rel]
  (cond
   (empty? rel) '()
   :else (cons (scnd (car rel))
               (seconds (cdr rel)))))

(defn fullfun? [rel]
  (set? (seconds rel)))

;; chapter 8: lambda the ultimate

(defn rember-f [test? a l]
  (cond
   (empty? l) '()
   (test? a (car l)) (cdr l)
   :else (cons (frst l)
               (rember-f test? a (cdr l)))))

(defn rember-f2 [test?]
  (fn [a l]
    (cond
     (empty? l) '()
     (test? a (car l)) (cdr l)
     :else (cons (car l)
                 ((rember-f2 test?) a (cdr l))))))

(def rember= (rember-f2 =))

(defn insertL-f [test?]
  (fn [new old lat]
    (cond
     (empty? lat) '()
     (test? old (car lat)) (cons new lat)
     :else (cons (car lat)
                 ((insertL-f test?) new old (cdr lat))))))

(defn insertR-f [test?]
  (fn [new old lat]
    (cond
     (empty? lat) '()
     (test? old (car lat)) (cons old
                                 (cons new
                                       (cdr lat)))
     :else (cons (car lat)
                 ((insertR-f test?) new old (cdr lat))))))

(defn insert-g [conser]
  (fn [new old lat]
    (cond
     (empty? lat) '()
     (= old (car lat)) (conser new old lat)
     :else (cons (car lat)
                 ((insert-g conser) new old (cdr lat))))))

(defn seqL [new old lat]
  (cons new lat))

(defn seqR [new old lat]
  (cons old
        (cons new
              (cdr lat))))

(def insertL-2 (insert-g seqL))
(def insertR-2 (insert-g seqR))

(defn multirember-f [test?]
  (fn [a lat]
    (cond
     (empty? lat) '()
     (test? a (car lat)) ((multirember-f test?) a (cdr lat))
     :else (cons (car lat)
                 ((multirember-f test?) a (cdr lat))))))

(def multirember= (multirember-f =))

(defn multiremberT [test? lat]
  (cond
   (empty? lat) '()
   (test? (car lat)) (multiremberT test? (cdr lat))
   :else (cons (car lat)
               (multiremberT test? (cdr lat)))))

(defn multirember&co [a lat col]
  (cond
   (empty? lat) (col '() '())
   (= a (car lat)) (multirember&co a
                                   (cdr lat)
                                   (fn [newlat seen]
                                     (col newlat
                                          (cons (car lat) seen))))
   :else (multirember&co a
                         (cdr lat)
                         (fn [newlat seen]
                           (col (cons (car lat) newlat)
                                seen)))))

(defn multiinsertLR [new oldL oldR lat]
  (cond
   (empty? lat) '()
   (= oldL (car lat)) (cons new
                            (cons oldL
                                  (multiinsertLR new oldL oldR (cdr lat))))
   (= oldR (car lat)) (cons oldR
                            (cons new
                                  (multiinsertLR new oldL oldR (cdr lat))))
   :else (cons (car lat) (multiinsertLR new oldL oldR (cdr lat)))))

(defn multiinsertLR&co [new oldL oldR lat col]
  (cond
   (empty? lat) (col '() 0 0)
   (= oldL (car lat)) (multiinsertLR&co new oldL oldR
                                        (cdr lat)
                                        (fn [newlat L R]
                                          (col
                                           (cons new
                                                 (cons oldL newlat)) (add1 L) R)))
   (= oldR (car lat)) (multiinsertLR&co new oldL oldR
                                        (cdr lat)
                                        (fn [newlat L R]
                                          (col
                                           (cons oldR
                                                 (cons new
                                                       newlat)) L (add1 R))))
   :else (multiinsertLR&co new oldL oldR (cdr lat)
                           (fn [newlat L R]
                             (col (cons (car lat)
                                        newlat) L R)))))

(defn evens-only* [l]
  (cond
   (empty? l) '()
   (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)))))

(defn evens-only*&co [l col]
  (cond
   (empty? l) (col '() 1 0)
   (atom? (car l)) (cond
                    (even? (car l)) (evens-only*&co
                                     (cdr l)
                                     (fn [evens products sums]
                                       (col (cons (car l) evens)
                                            (* (car l) products)
                                            sums)))
                    :else (evens-only*&co (cdr l)
                                          (fn [evens products sums]
                                            (col evens
                                                 products
                                                 (+ (car l) sums)))))
   :else (evens-only*&co (car l)
                         (fn [evens products sums]
                           (evens-only*&co (cdr l)
                                           (fn [evens2 products2 sums2]
                                             (col (cons evens evens2)
                                                  (* products products2)
                                                  (+ sums sums2))))))))

;; chapter 9: and again, and again, and again...

(defn keep-looking [a n lat]
  (cond
   (number? n) (keep-looking a (pick n lat) lat)
   :else (= a n)))

(defn looking [a lat]
  (keep-looking a (pick 1 lat) lat))

(defn shift [pair]
  (build (first (first pair))
         (build (second (first pair))
                (second pair))))

(defn align [pora]
  (cond
   (atom? pora) pora
   (pair? (first pora)) (align (shift pora))
   :else (build (first pora)
                (align (second pora)))))

(defn shuffle [pora]
  (cond
   (atom? pora) pora
   (pair? (first pora)) (shuffle (revpair pora))
   :else (build (first pora)
                (shuffle (second pora)))))