Definitions written while working through The Little Schemer code on DrRacket

schemer.rkt

#lang racket

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

; list of atoms?
(define lat?
  (lambda (x)
    (or (null? x)
        (and (not (atom? x))
             (atom? (car x))
             (lat? (cdr x))))))

; this implementation fails if anything
; other than a list is supplied as argument
;(define lat?
;  (lambda (l)
;    (cond
;      ((null? l) #t)
;      ((atom? (car l)) (lat? (cdr l)))
;      (else #f))))

;(define member?
;  (lambda (a l)
;    (cond
;      ((null? l) #f)
;      ((eq? a (car l)) #t)  ; unnecessary truth value required
;      (else (member? a (cdr l))))))

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

; insert to right
(define insertR
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((eq? old (car l))
       (cons (car l) (cons new (cdr l))))
      (else
       (cons (car l)
        (insertR new old (cdr l)))))))

; insert to left
(define insertL
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((eq? old (car l)) (cons new l))
      (else
       (cons (car l)
        (insertL new old (cdr l)))))))

; substitute
(define subst
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((eq? old (car l))
       (cons new (cdr l)))
      (else
       (cons (car l)
        (subst new old (cdr l)))))))

(define subst2
  (lambda (new o1 o2 l)
    (cond
      ((null? l) `())
      ((or (eq? o1 (car l)) (eq? o2 (car l)))
       (cons new (cdr l)))
      (else
       (cons (car l)
        (subst2 new o1 o2 (cdr l)))))))

(define multiinsertR
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((eq? old (car l))
       (cons old (cons new (multiinsertR new old (cdr l)))))
      (else
       (cons (car l)
        (multiinsertR new old (cdr l)))))))

(define multiinsertL
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((eq? old (car l))
       (cons new (cons old (multiinsertL new old (cdr l)))))
      (else
       (cons (car l)
        (multiinsertL new old (cdr l)))))))

(define multisubst
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((eq? old (car l))
       (cons new (multisubst new old (cdr l))))
      (else
       (cons (car l)
        (multisubst new old (cdr l)))))))

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

(define sub1
  (lambda (n)
    (- n 1)))

(define o+
  (lambda (x y)
    (cond
      ((zero? y) x)
      (else
       (o+ (add1 x) (sub1 y))))))

(define o-
  (lambda (x y)
    (cond
      ((zero? y) x)
      (else
       (o- (sub1 x) (sub1 y))))))

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

(define X
  (lambda (n m)
    (cond
      ((zero? m) 0)
      (else
       (o+ n (X n (sub1 m)))))))

(define tup+
  (lambda (t1 t2)
    (cond
      ;((and (null? t1) (null? t2)) `())
      ((null? t1) t2)
      ((null? t2) t1)
      (else
       (cons (o+ (car t1) (car t2))
             (tup+ (cdr t1) (cdr t2)))))))

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

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

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

(define ^
  (lambda (n m)
    (cond
      ((zero? m) 1)
      (else
       (X n (^ n (sub1 m)))))))

(define o/
  (lambda (n m)
    (cond
      ((o< n m) 0)
      (else (add1 (o/ (o- n m) m))))))

(define length
  (lambda (lat)
    (cond
      ((null? lat) 0)
      (else (add1 (length (cdr lat)))))))

(define pick
  (lambda (n lat)
    (cond
      ((zero? (sub1 n)) (car lat))
      (else (pick (sub1 n) (cdr lat))))))

;(define rempick
;  (lambda (n lat)
;    (cond
;      ((zero? (sub1 n)) (cdr lat))
;      (else (cons (car lat)
;                  (rempick (sub1 n) (cdr lat)))))))

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

(define all-nums
  (lambda (lat)
    (cond
      ((null? lat) `())
      (else (cond
         ((not (number? (car lat)))
          (all-nums (cdr lat)))
         (else (cons (car lat)
                     (all-nums (cdr lat)))))))))

(define eqan?
  (lambda (a1 a2)
    (cond
      ((and (number? a1) (number? a2)) (o= a1 a2))
      (else (eq? a1 a2)))))

(define occur
  (lambda (a lat)
    (cond
      ((null? lat) 0)
      (else (cond
              ((eqan? a (car lat))
               (add1 (occur a (cdr lat))))
              (else (occur a (cdr lat))))))))

(define one?
  (lambda (n)
    (o= n 1)))

(define rempick
  (lambda (n lat)
    (cond
      ((one? n) (cdr lat))
      (else (cons (car lat)
                  (rempick (sub1 n) (cdr lat)))))))

(define rember*
  (lambda (a l)
    (cond
      ((null? l) `())
      ((atom? (car l))
       (cond
         ((eq? 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)))))))

(define insertR*
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((atom? (car l))
       (cond
         ((eq? 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)))))))

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

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

(define insertL*
  (lambda (new old l)
    (cond
      ((null? l) `())
      ((atom? (car l))
       (cond
         ((eq? 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)))))))

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

(define leftmost
  (lambda (l)
    (cond
      ((atom? (car l)) (car l))
      (else (leftmost (car l))))))

;(define eqlist?
;  (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))
;         (eqlist? (cdr l1) (cdr l2))))
;      ((or (atom? (car l1)) (atom? (car l2))) #f)
;      (else (and
;             (eqlist? (car l1) (car l2))
;             (eqlist? (cdr l1) (cdr l2)))))))

(define equal?
  (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
             (equal? (car l1) (car l2))
             (eqlist? (cdr l1) (cdr l2)))))))

; remove a member
;(define rember
;  (lambda (a lat)
;    (cond
;      ((null? lat) `())
;      ((eq? a (car lat)) (cdr lat))
;      (else (cons 
;             (car lat)
;             (rember a (cdr lat)))))))

(define rember
  (lambda (s l)
    (cond
      ((null? l) `())
      ((equal? (car l) s) (cdr l))
      (else (cons (car l)
                  (rember s (cdr l)))))))

(define numbered?
  (lambda (aexp)
    (cond
      ((atom? aexp) (number? aexp))
      ((eq? (car (cdr aexp)) `+)
       (and (numbered? (car aexp))
            (numbered? (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) `*)
       (and (numbered? (car aexp))
            (numbered? (car (cdr (cdr aexp))))))
      ((eq? (car (cdr aexp)) `^)
       (and (numbered? (car aexp))
            (numbered? (car (cdr (cdr aexp))))))
      (else #f))))

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

(define 2nd-sub-exp
  (lambda (aexp)
    (car (cdr (cdr aexp)))))

(define operator
  (lambda (aexp)
    (car aexp)))

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

(define edd1
  (lambda (n)
    (cons `() n)))

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

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

(define member?
  (lambda (a l)
    (cond
      ((null? l) #f)
      (else
       (or 
        (equal? a (car l))
        (member? a (cdr l)))))))

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

(define multirember
  (lambda (a l)
    (cond
      ((null? l) `())
      ((equal? a (car l)) (multirember a (cdr l)))
      (else (cons 
             (car l)
             (multirember a (cdr l)))))))

(define makeset
  (lambda (lat)
    (cond
      ((null? lat) `())
      (else (cons (car lat)
                  (makeset
                   (multirember
                    (car lat) (cdr lat))))))))

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

(define eqset?
  (lambda (set1 set2)
    (and (subset? set1 set2)
         (subset? set2 set1))))

(define intersect?
  (lambda (set1 set2)
    (cond
      ((null? set1) #f)
      (else
       (or (member? (car set1) set2)
            (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)))))
(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))))))

(define intersectall
  (lambda (l-set)
    (cond
      ((null? (cdr l-set)) (car l-set))
      (else (intersect
             (car l-set)
             (intersectall (cdr l-set)))))))

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

(define fun?
  (lambda (rel)
    (set? (firsts rel))))

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

(define revrel
  (lambda (rel)
    (cond
      ((null? rel) `())
      (else (cons (revpair (car rel))
                  (revrel (cdr rel)))))))

;(define seconds
;  (lambda (rel)
;    (firsts (revrel rel))))

(define seconds
  (lambda (l)
    (cond
      ((null? l) `())
      (else (cons
             (car (cdr (car l)))
             (seconds (cdr l)))))))

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

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

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

(define rember-f
  (lambda (test?)
    (lambda (a l)
      (cond
        ((null? l) `())
        ((test? a (car l)) (cdr l))
        (else
         (cons (car l)
               ((rember-f test?) a (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 (test?)
      (lambda (new old l)
        (cond
          ((null? l) `())
          ((test? old (car l))
           (seq new old (cdr l)))
          (else
           (cons (car l)
                 (((insert-g seq) test?)
                  new old (cdr l)))))))))

(define insertL-f (insert-g seqL))

(define insertR-f (insert-g seqR))

(define atom-to-function
  (lambda (x)
    (cond
      ((eq? x `o+) o+)
      ((eq? x `X) X)
      ((eq? x `^) ^))))

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

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

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

(define multiinsertLR
  (lambda (new oldL oldR lat)
    (cond
      ((null? lat) `())
      ((eq? oldL oldR) lat)
      ((eq? oldL (car lat))
       (cons new 
             (cons oldL
                   (multiinsertLR
                    new oldL oldR (cdr lat)))))
      ((eq? oldR (car lat))
       (cons oldR 
             (cons new
                   (multiinsertLR
                    new oldL oldR (cdr lat)))))
      (else
       (cons (car lat)
        (multiinsertLR new oldL oldR (cdr lat)))))))

(define multiinsertLR&co
  (lambda (new oldL oldR lat col)
    (cond
      ((null? lat) (col `() 0 0))
      ((eq? oldL (car lat))
       (multiinsertLR&co
        new oldL oldR (cdr lat)
        (lambda (newlat L R)
          (col (cons new (cons oldL newlat))
               (add1 L) R))))
      ((eq? oldR (car lat))
       (multiinsertLR&co
        new oldL oldR (cdr lat)
        (lambda (newlat L R)
          (col (cons oldR (cons new newlat))
               L (add1 R)))))
      (else (multiinsertLR&co
             new oldL oldR (cdr lat)
             (lambda (newlat L R)
               (col (cons (car lat) newlat) L R)))))))

(define even?
  (lambda (n)
    (= (X (o/ n 2) 2) n)))

(define evens-only*
  (lambda (l)
    (cond
      ((null? 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)))))))

(define evens-only*&co
  (lambda (l col)
    (cond
      ((null? l) (col `() 1 0))
      ((atom? (car l))
       (cond
         ((even? (car l))
          (evens-only*&co
           (cdr l) (lambda (newl P S)
                     (col (cons (car l) newl)
                          (X P (car l)) S))))
         (else (evens-only*&co
                (cdr l) (lambda (newl P S)
                          (col newl P (o+ S (car l))))))))
      (else (evens-only*&co
             (car l) (lambda (al ap as)
                       (evens-only*&co (cdr l)
                                       (lambda (dl dp ds)
                                         (col (cons al dl)
                                              (X ap dp)
                                              (o+ as ds))))))))))

(define the-last-friend
  (lambda (newl product sum)
    (cons sum
          (cons product newl))))

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

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

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

(define length*
  (lambda (pora)
    (cond
      ((atom? pora) 1)
      (else
       (o+ (length* (first pora))
           (length* (second pora)))))))

(define align
  (lambda (pora)
    (cond
      ((atom? pora) pora)
      ((a-pair? (first pora))
       (align (shift pora)))
      (else (build (first pora)
                   (align (second pora)))))))

(define weight*
  (lambda (pora)
    (cond
      ((atom? pora) 1)
      (else
       (o+ (X 2 (weight* (first pora)))
           (weight* (second pora)))))))

(define shuffle
  (lambda (pora)
    (cond
      ((atom? pora) pora)
      ((a-pair? (first pora))
       (shuffle (revpair pora)))
      (else
       (build (first pora)
              (shuffle (second pora)))))))

; Prepare for a complete mind-bender ahead

(define eternity
  (lambda (x)
    (eternity x)))

(lambda (l)
  (cond
    ((null? l) 0)
    (else (add1 (eternity (cdr l))))))

; length0
((lambda (length)
   (lambda (l)
     (cond
       ((null? l) 0)
       (else (add1 (length (cdr l)))))))
 eternity)

; length1
((lambda (f)
   (lambda (l)
     (cond
       ((null? l) 0)
       (else (add1 (f (cdr l)))))))
 ((lambda (g)
    (lambda (l)
      (cond
        ((null? l) 0)
        (else (add1 (g (cdr l)))))))
  eternity))

; length2
((lambda (length)
   (lambda (l)
     (cond
       ((null? l) 0)
       (else (add1 (length (cdr l)))))))
 ((lambda (length)
    (lambda (l)
      (cond
        ((null? l) 0)
        (else (add1 (length (cdr l)))))))
  ((lambda (length)
     (lambda (l)
       (cond
         ((null? l) 0)
         (else (add1 (length (cdr l)))))))
  eternity)))

; length0
((lambda (mk-length)
   (mk-length mk-length))
 (lambda (mk-length)
   (lambda (l)
     (cond
       ((null? l) 0)
       (else (add1
              (mk-length (cdr l))))))))

; length
((lambda (mk-length)
   (mk-length mk-length))
 (lambda (mk-length)
   (lambda (l)
     (cond
       ((null? l) 0)
       (else (add1
              ((mk-length mk-length)
               (cdr l))))))))

; length - fail
;((lambda (mk-length)
;   (mk-length mk-length))
; (lambda (mk-length)
;   ((lambda (length)
;      (lambda (l)
;        (cond
;          ((null? l) 0)
;          (else (add1
;                 (length (cdr l)))))))
;    (mk-length mk-length)))) ; alas! doesn't work :(

; length
((lambda (mk-length)
   (mk-length mk-length))
 (lambda (mk-length)
   ((lambda (length)
      (lambda (l)
        (cond
          ((null? l) 0)
          (else (add1
                 (length (cdr l)))))))
    (lambda (x)
      ((mk-length mk-length) x)))))

; length
((lambda (le)
   ((lambda (mk-length)
      (mk-length mk-length))
    (lambda (mk-length)
      (le (lambda (x)
            ((mk-length mk-length) x))))))
 (lambda (length)
      (lambda (l)
        (cond
          ((null? l) 0)
          (else (add1
                 (length (cdr l))))))))

; mk-length
(lambda (le)
  ((lambda (mk-length)
     (mk-length mk-length))
   (lambda (mk-length)
     (le (lambda (x)
           ((mk-length mk-length) x))))))

; applicative-order Y combinator
(define Y
  (lambda (le)
    ((lambda (f) (f f))
     (lambda (f)
       (le (lambda (x) ((f f) x)))))))

((Y (lambda (length)
      (lambda (l)
        (cond
          ((null? l) 0)
          (else (add1
                 (length (cdr l)))))))) `(3 4 4 5 ))

(define new-entry build)

(define lookup-in-entry
  (lambda (name entry entry-f)
    (lookup-in-entry-help name
                          (first entry)
                          (second entry)
                          entry-f)))

(define lookup-in-entry-help
  (lambda (name names values entry-f)
    (cond
      ((null? names) (entry-f name))
      ((eq? name (car names))
       (car values))
      (else (lookup-in-entry-help
             name (cdr names)
             (cdr values) entry-f)))))

(define extend-table cons)

(define lookup-in-table
  (lambda (name table table-f)
    (cond
      ((null? table) (table-f name))
      (else (lookup-in-entry name
                             (car table)
                             (lambda (name)
                               (lookup-in-table
                                name (cdr table)
                                table-f)))))))

(define expression-to-action
  (lambda (e)
    (cond
      ((atom? e) (atom-to-action e))
      (else (list-to-action e)))))

(define atom-to-action
  (lambda (e)
    (cond
      ((number? e) *const)
      ((eq? e #t) *const)
      ((eq? e #f) *const)
      ((eq? e `cons) *const)
      ((eq? e `car) *const)
      ((eq? e `cdr) *const)
      ((eq? e `null?) *const)
      ((eq? e `eq?) *const)
      ((eq? e `atom?) *const)
      ((eq? e `zero?) *const)
      ((eq? e `add1) *const)
      ((eq? e `sub1) *const)
      ((eq? e `number?) *const)
      (else *identifier))))

(define list-to-action
  (lambda (e)
    (cond
      ((atom? (car e))
       (cond
         ((eq? (car e) `quote) *quote)
         ((eq? (car e) `lambda) *lambda)
         ((eq? (car e) `cond) *cond)
         (else *application)))
       (else *application))))

(define value
  (lambda (e)
    (meaning e `())))

(define meaning
  (lambda (e table)
    ((expression-to-action e) e table)))

(define *const
  (lambda (e table)
    (cond
      ((number? e) e)
      ((eq? e #t) #t)
      ((eq? e #f) #f)
      (else (build `primitive e)))))

(define *quote
  (lambda (e table)
    (text-of e)))

(define text-of second)

(define *identifier
  (lambda (e table)
    (lookup-in-table e table initial-table)))

(define initial-table
  (lambda (name)
    `()))

(define *lambda
  (lambda (e table)
    (build `non-primitive
           (cons table (cdr e)))))

(define table-of first)
(define formals-of second)
(define body-of third)

(define evcon
  (lambda (lines table)
    (cond
      ((else? (question-of (car lines)))
       (meaning (answer-of (car lines)) table))
      ((meaning (question-of (car lines)) table)
       (meaning (answer-of (car lines)) table))
      (else (evcon (cdr lines) table)))))

(define else?
  (lambda (x)
    (cond
      ((atom? x) (eq? x `else))
      (else #f))))

(define question-of first)
(define answer-of second)

(define *cond
  (lambda (e table)
    (evcon (cond-lines-of e) table)))

(define cond-lines-of cdr)

(define evlis
  (lambda (args table)
    (cond
      ((null? args) `())
      (else (cons (meaning (car args) table)
                  (evlis (cdr args) table))))))

(define *application
  (lambda (e table)
    (apply
     (meaning (function-of e) table)
     (evlis (arguments-of e) table))))

(define function-of car)
(define arguments-of cdr)

(define primitive?
  (lambda (l)
    (eq? (first l) `primitive)))

(define non-primitive?
  (lambda (l)
    ((eq? (first l) `non-primitive))))

(define apply
  (lambda (fun vals)
    (cond
      ((primitive? fun)
       (apply-primitive
        (second fun) vals))
      ((non-primitive? fun)
       (apply-closure
        (second fun) vals)))))

(define apply-primitive
  (lambda (name vals)
    (cond
      ((eq? name `cons)
       (cons (first vals) (second vals)))
      ((eq? name `car)
       (car (first vals)))
      ((eq? name `cdr)
       (cdr (first vals)))
      ((eq? name `null?)
       (null? (first vals)))
      ((eq? name `eq?)
       (eq? (first vals) (second vals)))
      ((eq? name `atom?)
       (:atom? (first vals)))
      ((eq? name `zero?)
       (zero? (first vals)))
      ((eq? name `add1)
       (add1 (first vals)))
      ((eq? name `sub1)
       (sub1 (first vals)))
      ((eq? name `number?)
       (number? (first vals))))))

(define :atom?
  (lambda (x)
    (cond
      ((atom? x) #t)
      ((null? x) #f)
      ((eq? (car x) `primitive) #t)
      ((eq? (car x) `non-primitive) #t)
      (else #f))))

(define apply-closure
  (lambda (closure vals)
    (meaning (body-of closure)
             (extend-table
              (new-entry
               (formals-of closure)
               vals)
              (table-of closure)))))

(apply-closure
 `((((u v w)
     (1 2 3))
    ((x y z)
     (4 5 6)))
   (x y)
   (cons z x))
 `((a b c) (d e f)))