Racket code for the little schemer

gistfile1.rkt

#lang racket

;; Code for the little schemer

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

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

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

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

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

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

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

(define (o--old n m)
  (cond ((zero? m) n)
        (else (sub1 (o--old n (sub1 m))))))

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

(define (o*-old n m)
  (cond ((zero? m) 0)
        (else (+ n (o*-old n (sub1 m))))))


(define (tup+ tup1 tup2)
  (cond ((and (null? tup1) (null? tup2)) (quote ()))
        ((null? tup1) tup2)
        ((null? tup2) tup1)
        (else (cons (+ (car tup1) (car tup2))
                    (tup+ (cdr tup1) (cdr tup2))))))

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

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

(define (o=-old n m)
  (cond ((zero? m) (zero? n))
        ((zero? n) #f)
        (else (o=-old (sub1 n) (sub1 m)))))

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

(define (expt n m)
  (cond ((zero? m) 1)
        (else (o*-old n (expt n (sub1 m))))))

(define (quotient n m)
  (cond ((o<-old n m) 0)
        (else (add1 (quotient (o--old n m) m)))))

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

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

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

(define (no-nums lat)
  (cond ((null? lat) (quote ()))
        (else (cond ((number? (car lat)) (no-nums (cdr lat)))
                    (else (cons (car lat)
                                (no-nums (cdr lat))))))))

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

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

(define (occur a lat)
  (cond ((null? lat) 0)
        (else (cond ((eqan? a (car lat)) (o+-old 1 (occur a (cdr lat))))
                    (else (occur a (cdr lat)))))))

(define (one? n)
  (zero? (sub1 n)))

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

(define (rember* a l)
  (cond ((null? l) (quote ()))
        ((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))))))

(define (insertR* new old l)
  (cond ((null? l) (quote ()))
        ((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))))))

(define (occur* a l)
  (cond ((null? l) 0)
        ((atom? (car l)) (eq? a (car l)))
        (else (o+-old (occur* a (car l))
                      (occur* a (cdr l))))))

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

(define (insertL* new old l)
  (cond ((null? l) (quote ()))
        ((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))))))

(define (member* 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 l)
  (cond ((atom? (car l)) (car l))
        (else (leftmost (car l)))))

(define (equal? s1 s2)
  (cond ((and (atom? s1) (atom? s2)) (eqan? s1 s2))
        ((or (atom? s1) (atom? s2)) #f)
        (else (eqlist? s1 s2))))

(define (eqlist? 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-2 s l)
  (cond ((null? l) (quote ()))
        (else (cond ((equal? (car l) s) (cdr l))
                    (else (cons (car l) (rember-2 s (cdr l))))))))

(define (rember-3 s l)
  (cond ((null? l) (quote ()))
        ((equal? (car l) s) (cdr l))
        (else (cons (car l) (rember-3 s (cdr l))))))

(define (numbered? aexp)
  (cond ((atom? aexp) (number? aexp))
        ((eq? (car (cdr aexp)) (quote x)) (and (numbered? (car aexp))
                                               (numbered? (car (cdr (cdr aexp))))))
        ((eq? (car (cdr aexp)) (quote +)) (and (numbered? (car aexp))
                                               (numbered? (car (cdr (cdr aexp))))))
        ((eq? (car (cdr aexp)) (quote ^)) (and (numbered? (car aexp))
                                               (numbered? (car (cdr (cdr aexp))))))))

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

(define (value-in nexp)
  (cond ((atom? nexp) nexp)
        ((eq? (car (cdr nexp)) (quote x))
         (* (car nexp) (value (car (cdr (cdr nexp))))))
        ((eq? (car (cdr nexp)) (quote +))
         (+ (car nexp) (value (car (cdr (cdr nexp))))))
        (else
         (expt (car nexp) (value (car (cdr (cdr nexp))))))))

(define (value-verbose nexp)
  (cond ((atom? nexp) nexp)
        ((eq? (car nexp) (quote x))
         (* (value (car (cdr nexp))) (value (car (cdr nexp)))))
        ((eq? (car nexp) (quote +))
         (+ (value (car (cdr nexp))) (value (car (cdr nexp)))))
        ((eq? (car nexp) (quote ^))
         (expt (value (car (cdr nexp))) (value (car (cdr nexp)))))))

(define (value-1 nexp)
  (cond ((atom? nexp) nexp)
        ((eq? (operator nexp) (quote x))
         (* (1st-sub-exp nexp)
            (2nd-sub-exp nexp)))
        ((eq? (operator nexp) (quote +))
         (+ (1st-sub-exp nexp)
            (2nd-sub-exp nexp)))
        (else
         (expt (1st-sub-exp nexp)
               (2nd-sub-exp nexp)))))

(define (operator aexp)
  (car aexp))

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

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

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

(define (edd1 n)
  (cons (quote ()) n))

(define (zub1 n)
  (cdr n))

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

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

(define (makeset lat)
  (cond ((null? lat) (quote ()))
        (else (cond ((member? (car lat) (cdr lat)) (makeset (cdr lat)))
                    (else (cons (car lat) (makeset (cdr lat))))))))

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

(define (intersect? set1 set2)
  (cond ((null? set1) #f)
        (else (or (member? (car set1) set2)
                  (intersect? (cdr set1) set2)))))

(define (tls-intersect set1 set2)
  (cond ((null? set1) (quote ()))
        ((member? (car set1) set2)
         (cons (car set1)
               (tls-intersect (cdr set1) set2)))
        (else
         (tls-intersect (cdr set1) set2))))

(define (tls-union set1 set2)
  (cond ((null? set1) set2)
        ((member? (car set1) set2) (tls-union (cdr set1) set2))
        (else (cons (car set1)
                    (tls-union (cdr set1) set2)))))

(define (intersect-all l-set)
  (cond ((null? (cdr l-set)) (car l-set))
        (else (tls-intersect (car l-set)
                             (intersect-all (cdr l-set))))))

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

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

(define (tls-first p)
  (car p))

(define (tls-second p)
  (car (cdr p)))

(define (build s1 s2)
  (cons s1 (cons s2 (quote ()))))

(define (fun? rel)
  (tls-set? (firsts rel)))

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

(define (fullfun? fun)
  (tls-set? (seconds fun)))

(define (seconds fun)
  (cond ((null? fun) (quote ()))
        (else (cons (car (cdr (car fun)))
                    (seconds (cdr fun))))))

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

(define (rember-f1 test? a l)
  (cond ((null? l) (quote ()))
        (else (cond ((test? (car l) a) (cdr l))
                    (else (cons (car l)
                                (rember-f1 test? a (cdr l))))))))

(define (rember-f2 test? a l)
  (cond ((null? l) (quote ()))
        ((test? (car l) a) (cdr l))
        (else (cons (car l)
                    (rember-f2 test? a (cdr l))))))

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

(define (insertL-f1 test?)
  (lambda (new old l)
    (cond ((null? l) (quote ()))
          ((test? (car l) old)
           (cons new (cons old (cdr l))))
          (else (cons (car l)
                      ((insertL-f1 test?) new old (cdr l)))))))

(define (insertR-f1 test?)
  (lambda (new old l)
    (cond ((null? l) (quote ()))
          ((test? (car l) old)
           (cons old (cons new (cdr l))))
          (else (cons (car l)
                      ((insertR-f1 test?) new old (cdr l)))))))

(define (seqL new old l)
  (cons new (cons old l)))

(define (seqR new old l)
  (cons old (cons new l)))

(define (insert-g seq)
  (lambda (new old l)
    (cond ((null? l) (quote ()))
          ((eq? (car l) old)
           (seq new old (cdr l)))
          (else (cons (car l)
                      ((insert-g seq) new old (cdr l)))))))

(define (atom-to-function x)
  (cond ((eq? x (quote +)) o+-old)
        ((eq? x (quote x)) o*-old)
        (else expt)))

(define (value nexp)
  (cond ((atom? nexp) nexp)
        (else
         ((atom-to-function (operator nexp))
          (value (1st-sub-exp nexp))
          (value (2nd-sub-exp nexp))))))

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

(define (multirember-and-co a lat col)
  (cond ((null? lat)
         (col (quote ()) (quote ())))
        ((eq? (car lat) a)
         (multirember-and-co
          a (cdr lat) (lambda (newlat seen)
                        (col newlat
                             (cons (car lat) seen)))))
        (else
         (multirember-and-co
          a (cdr lat) (lambda (newlat seen)
                        (col (cons (car lat) newlat)
                             seen))))))

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

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

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

(define (C n)
  (cond ((one? n) 1)
        (else
         (cond ((even? n) (C (/ n 2)))
               (else (C (add1 (* 3 n))))))))

(define (A n m)
  (cond ((zero? n) (add1 m))
        ((zero? m) (A (sub1 n) 1))
        (else (A (sub1 n)
                 (A n (sub1 m))))))

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

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

(define extend-table cons)

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

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

(define (atom-to-action 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 e)
  (cond ((atom? (car e))
         (cond ((eq? (car e) (quote quote))
                *quote)
               ((eq? (car e) (quote lambda))
                *lambda)
               ((eq? (car e) (quote cond))
                *cond)
               (else *application)))
        (else *application)))

(define (value e)
  (meaning e '()))

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

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

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

(define text-of second)

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

(define (initial-table name)
  (car '()))

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

(define table-of first)

(define formals-of second)

(define body-of third)

(define (evcon 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? x)
  (cond ((atom? x) (eq? x 'else))
        (else #f)))

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

(define cond-lines-of cdr)

rember has a bug. Should be:

(define (rember a lat)
  (cond [(null? lat) null]
        [(eq? (car lat) a) (cdr lat)]
        [else (cons (car lat)
                  (rember a (cdr lat)))]))

Currently takes car a instead of car lat