;;; TAK

(defun tak (x y z)
  (if (not (< y x))
      z
    (tak (tak (1- x) y z)
         (tak (1- y) z x)
         (tak (1- z) x y))))

;;; STAK

(defvar x)

(defvar y)

(defvar z)

(defun stak (x y z)
  (stak-aux))

(defun stak-aux ()
  (if (not (< y x))
      z
    (let ((x (let ((x (1- x))
                   (y y)
                   (z z))
               (stak-aux)))
          (y (let ((x (1- y))
                   (y z)
                   (z x))
               (stak-aux)))
          (z (let ((x (1- z))
                   (y x)
                   (z y))
               (stak-aux))))
      (stak-aux))))

;;; CTAK

(defun ctak (x y z)
  (catch 'ctak (ctak-aux x y z)))

(defun ctak-aux (x y z)
  (cond ((not (< y x))
         (throw 'ctak z))
        (t (ctak-aux
            (catch 'ctak
              (ctak-aux (1- x)
                        y
                        z))
            (catch 'ctak
              (ctak-aux (1- y)
                        z
                        x))
            (catch 'ctak
              (ctak-aux (1- z)
                        x
                        y))))))

;;; TAKL

(defun listn (n)
  (if (not (= 0 n))
      (cons n (listn (1- n)))))

(defvar 18l (listn 18))

(defvar 12l (listn 12))

(defvar 6l (listn 6))

(defun mas (x y z)
  (if (not (shorterp y x))
      z
    (mas (mas (cdr x)
              y z)
         (mas (cdr y)
              z x)
         (mas (cdr z)
              x y))))

(defun shorterp (x y)
  (and y (or (null x)
             (shorterp (cdr x)
                       (cdr y)))))

;;; BOYER

(defvar unify-subst)
(defvar temp-temp)
(defun add-lemma (term)
  (cond ((and (not (atom term))
              (eq (car term)
                  (quote equal))
              (not (atom (cadr term))))
         (setf (get (car (cadr term)) (quote lemmas))
               (cons term (get (car (cadr term))
                               (quote lemmas)))))
        (t (error "~%ADD-LEMMA did not like term: ~a" term))))
(defun add-lemma-lst (lst)
  (cond ((null lst)
         t)
        (t (add-lemma (car lst))
           (add-lemma-lst (cdr lst)))))
(defun apply-subst (alist term)
  (cond ((atom term)
         (cond ((setq temp-temp (assq term alist))
                (cdr temp-temp))
               (t term)))
        (t (cons (car term)
                 (apply-subst-lst alist (cdr term))))))
(defun apply-subst-lst (alist lst)
  (cond ((null lst)
         nil)
        (t (cons (apply-subst alist (car lst))
                 (apply-subst-lst alist (cdr lst))))))
(defun falsep (x lst)
  (or (equal x (quote (f)))
      (member x lst)))
(defun one-way-unify (term1 term2)
  (progn (setq unify-subst nil)
         (one-way-unify1 term1 term2)))
(defun one-way-unify1 (term1 term2)
  (cond ((atom term2)
         (cond ((setq temp-temp (assq term2 unify-subst))
                (equal term1 (cdr temp-temp)))
               (t (setq unify-subst (cons (cons term2 term1)
                                          unify-subst))
                  t)))
        ((atom term1)
         nil)
        ((eq (car term1)
             (car term2))
         (one-way-unify1-lst (cdr term1)
                             (cdr term2)))
        (t nil)))
(defun one-way-unify1-lst (lst1 lst2)
  (cond ((null lst1)
         t)
        ((one-way-unify1 (car lst1)
                         (car lst2))
         (one-way-unify1-lst (cdr lst1)
                             (cdr lst2)))
        (t nil)))
(defun rewrite (term)
  (cond ((atom term)
         term)
        (t (rewrite-with-lemmas
            (cons (car term)
                  (rewrite-args (cdr term)))
            (get (car term)
                 (quote lemmas))))))
(defun rewrite-args (lst)
  (cond ((null lst)
         nil)
        (t (cons (rewrite (car lst))
                 (rewrite-args (cdr lst))))))
(defun rewrite-with-lemmas (term lst)
  (cond ((null lst)
         term)
        ((one-way-unify term (cadr (car lst)))
         (rewrite
          (apply-subst unify-subst (caddr (car lst)))))
        (t (rewrite-with-lemmas term (cdr lst)))))
(defun setup ()
  (add-lemma-lst
   (quote ((equal (compile form)
                  (reverse (codegen (optimize form)
                                    (nil))))
           (equal (eqp x y)
                  (equal (fix x)
                         (fix y)))
           (equal (greaterp x y)
                  (lessp y x))
           (equal (lesseqp x y)
                  (not (lessp y x)))
           (equal (greatereqp x y)
                  (not (lessp x y)))
           (equal (boolean x)
                  (or (equal x (t))
                      (equal x (f))))
           (equal (iff x y)
                  (and (implies x y)
                       (implies y x)))
           (equal (even1 x)
                  (if (zerop x)
                      (t)
                    (odd (1- x))))
           (equal (countps- l pred)
                  (countps-loop l pred (zero)))
           (equal (fact- i)
                  (fact-loop i 1))
           (equal (reverse- x)
                  (reverse-loop x (nil)))
           (equal (divides x y)
                  (zerop (remainder y x)))
           (equal (assume-true var alist)
                  (cons (cons var (t))
                        alist))
           (equal (assume-false var alist)
                  (cons (cons var (f))
                        alist))
           (equal (tautology-checker x)
                  (tautologyp (normalize x)
                              (nil)))
           (equal (falsify x)
                  (falsify1 (normalize x)
                            (nil)))
           (equal (prime x)
                  (and (not (zerop x))
                       (not (equal x (add1 (zero))))
                       (prime1 x (1- x))))
           (equal (and p q)
                  (if p (if q (t)
                          (f))
                    (f)))
           (equal (or p q)
                  (if p (t)
                    (if q (t)
                      (f))
                    (f)))
           (equal (not p)
                  (if p (f)
                    (t)))
           (equal (implies p q)
                  (if p (if q (t)
                          (f))
                    (t)))
           (equal (fix x)
                  (if (numberp x)
                      x
                    (zero)))
           (equal (if (if a b c)
                      d e)
                  (if a (if b d e)
                    (if c d e)))
           (equal (zerop x)
                  (or (equal x (zero))
                      (not (numberp x))))
           (equal (plus (plus x y)
                        z)
                  (plus x (plus y z)))
           (equal (equal (plus a b)
                         (zero))
                  (and (zerop a)
                       (zerop b)))
           (equal (difference x x)
                  (zero))
           (equal (equal (plus a b)
                         (plus a c))
                  (equal (fix b)
                         (fix c)))
           (equal (equal (zero)
                         (difference x y))
                  (not (lessp y x)))
           (equal (equal x (difference x y))
                  (and (numberp x)
                       (or (equal x (zero))
                           (zerop y))))
           (equal (meaning (plus-tree (append x y))
                           a)
                  (plus (meaning (plus-tree x)
                                 a)
                        (meaning (plus-tree y)
                                 a)))
           (equal (meaning (plus-tree (plus-fringe x))
                           a)
                  (fix (meaning x a)))
           (equal (append (append x y)
                          z)
                  (append x (append y z)))
           (equal (reverse (append a b))
                  (append (reverse b)
                          (reverse a)))
           (equal (times x (plus y z))
                  (plus (times x y)
                        (times x z)))
           (equal (times (times x y)
                         z)
                  (times x (times y z)))
           (equal (equal (times x y)
                         (zero))
                  (or (zerop x)
                      (zerop y)))
           (equal (exec (append x y)
                        pds envrn)
                  (exec y (exec x pds envrn)
                        envrn))
           (equal (mc-flatten x y)
                  (append (flatten x)
                          y))
           (equal (member x (append a b))
                  (or (member x a)
                      (member x b)))
           (equal (member x (reverse y))
                  (member x y))
           (equal (length (reverse x))
                  (length x))
           (equal (member a (intersect b c))
                  (and (member a b)
                       (member a c)))
           (equal (nth (zero)
                       i)
                  (zero))
           (equal (exp i (plus j k))
                  (times (exp i j)
                         (exp i k)))
           (equal (exp i (times j k))
                  (exp (exp i j)
                       k))
           (equal (reverse-loop x y)
                  (append (reverse x)
                          y))
           (equal (reverse-loop x (nil))
                  (reverse x))
           (equal (count-list z (sort-lp x y))
                  (plus (count-list z x)
                        (count-list z y)))
           (equal (equal (append a b)
                         (append a c))
                  (equal b c))
           (equal (plus (remainder x y)
                        (times y (quotient x y)))
                  (fix x))
           (equal (power-eval (big-plus1 l i base)
                              base)
                  (plus (power-eval l base)
                        i))
           (equal (power-eval (big-plus x y i base)
                              base)
                  (plus i (plus (power-eval x base)
                                (power-eval y base))))
           (equal (remainder y 1)
                  (zero))
           (equal (lessp (remainder x y)
                         y)
                  (not (zerop y)))
           (equal (remainder x x)
                  (zero))
           (equal (lessp (quotient i j)
                         i)
                  (and (not (zerop i))
                       (or (zerop j)
                           (not (equal j 1)))))
           (equal (lessp (remainder x y)
                         x)
                  (and (not (zerop y))
                       (not (zerop x))
                       (not (lessp x y))))
           (equal (power-eval (power-rep i base)
                              base)
                  (fix i))
           (equal (power-eval (big-plus (power-rep i base)
                                        (power-rep j base)
                                        (zero)
                                        base)
                              base)
                  (plus i j))
           (equal (gcd x y)
                  (gcd y x))
           (equal (nth (append a b)
                       i)
                  (append (nth a i)
                          (nth b (difference i (length a)))))
           (equal (difference (plus x y)
                              x)
                  (fix y))
           (equal (difference (plus y x)
                              x)
                  (fix y))
           (equal (difference (plus x y)
                              (plus x z))
                  (difference y z))
           (equal (times x (difference c w))
                  (difference (times c x)
                              (times w x)))
           (equal (remainder (times x z)
                             z)
                  (zero))
           (equal (difference (plus b (plus a c))
                              a)
                  (plus b c))
           (equal (difference (add1 (plus y z))
                              z)
                  (add1 y))
           (equal (lessp (plus x y)
                         (plus x z))
                  (lessp y z))
           (equal (lessp (times x z)
                         (times y z))
                  (and (not (zerop z))
                       (lessp x y)))
           (equal (lessp y (plus x y))
                  (not (zerop x)))
           (equal (gcd (times x z)
                       (times y z))
                  (times z (gcd x y)))
           (equal (value (normalize x)
                         a)
                  (value x a))
           (equal (equal (flatten x)
                         (cons y (nil)))
                  (and (nlistp x)
                       (equal x y)))
           (equal (listp (gopher x))
                  (listp x))
           (equal (samefringe x y)
                  (equal (flatten x)
                         (flatten y)))
           (equal (equal (greatest-factor x y)
                         (zero))
                  (and (or (zerop y)
                           (equal y 1))
                       (equal x (zero))))
           (equal (equal (greatest-factor x y)
                         1)
                  (equal x 1))
           (equal (numberp (greatest-factor x y))
                  (not (and (or (zerop y)
                                (equal y 1))
                            (not (numberp x)))))
           (equal (times-list (append x y))
                  (times (times-list x)
                         (times-list y)))
           (equal (prime-list (append x y))
                  (and (prime-list x)
                       (prime-list y)))
           (equal (equal z (times w z))
                  (and (numberp z)
                       (or (equal z (zero))
                           (equal w 1))))
           (equal (greatereqpr x y)
                  (not (lessp x y)))
           (equal (equal x (times x y))
                  (or (equal x (zero))
                      (and (numberp x)
                           (equal y 1))))
           (equal (remainder (times y x)
                             y)
                  (zero))
           (equal (equal (times a b)
                         1)
                  (and (not (equal a (zero)))
                       (not (equal b (zero)))
                       (numberp a)
                       (numberp b)
                       (equal (1- a)
                              (zero))
                       (equal (1- b)
                              (zero))))
           (equal (lessp (length (delete x l))
                         (length l))
                  (member x l))
           (equal (sort2 (delete x l))
                  (delete x (sort2 l)))
           (equal (dsort x)
                  (sort2 x))
           (equal (length
                   (cons
                    x1
                    (cons
                     x2
                     (cons
                      x3
                      (cons
                       x4
                       (cons
                        x5
                        (cons x6 x7)))))))
                  (plus 6 (length x7)))
           (equal (difference (add1 (add1 x))
                              2)
                  (fix x))
           (equal (quotient (plus x (plus x y))
                            2)
                  (plus x (quotient y 2)))
           (equal (sigma (zero)
                         i)
                  (quotient (times i (add1 i))
                            2))
           (equal (plus x (add1 y))
                  (if (numberp y)
                      (add1 (plus x y))
                    (add1 x)))
           (equal (equal (difference x y)
                         (difference z y))
                  (if (lessp x y)
                      (not (lessp y z))
                    (if (lessp z y)
                        (not (lessp y x))
                      (equal (fix x)
                             (fix z)))))
           (equal (meaning (plus-tree (delete x y))
                           a)
                  (if (member x y)
                      (difference (meaning (plus-tree y)
                                           a)
                                  (meaning x a))
                    (meaning (plus-tree y)
                             a)))
           (equal (times x (add1 y))
                  (if (numberp y)
                      (plus x (times x y))
                    (fix x)))
           (equal (nth (nil)
                       i)
                  (if (zerop i)
                      (nil)
                    (zero)))
           (equal (last (append a b))
                  (if (listp b)
                      (last b)
                    (if (listp a)
                        (cons (car (last a))
                              b)
                      b)))
           (equal (equal (lessp x y)
                         z)
                  (if (lessp x y)
                      (equal t z)
                    (equal f z)))
           (equal (assignment x (append a b))
                  (if (assignedp x a)
                      (assignment x a)
                    (assignment x b)))
           (equal (car (gopher x))
                  (if (listp x)
                      (car (flatten x))
                    (zero)))
           (equal (flatten (cdr (gopher x)))
                  (if (listp x)
                      (cdr (flatten x))
                    (cons (zero)
                          (nil))))
           (equal (quotient (times y x)
                            y)
                  (if (zerop y)
                      (zero)
                    (fix x)))
           (equal (get j (set i val mem))
                  (if (eqp j i)
                      val
                    (get j mem)))))))
(defun tautologyp (x true-lst false-lst)
  (cond ((truep x true-lst)
         t)
        ((falsep x false-lst)
         nil)
        ((atom x)
         nil)
        ((eq (car x)
             (quote if))
         (cond ((truep (cadr x)
                       true-lst)
                (tautologyp (caddr x)
                            true-lst false-lst))
               ((falsep (cadr x)
                        false-lst)
                (tautologyp (cadddr x)
                            true-lst false-lst))
               (t (and (tautologyp (caddr x)
                                   (cons (cadr x)
                                         true-lst)
                                   false-lst)
                       (tautologyp (cadddr x)
                                   true-lst
                                   (cons (cadr x)
                                         false-lst))))))
        (t nil)))
(defun tautp (x)
  (tautologyp (rewrite x)
              nil nil))
(defun test ()
  (let (ans term)
    (setq term
          (apply-subst
           (quote ((x f (plus (plus a b)
                              (plus c (zero))))
                   (y f (times (times a b)
                               (plus c d)))
                   (z f (reverse (append (append a b)
                                         (nil))))
                   (u equal (plus a b)
                      (difference x y))
                   (w lessp (remainder a b)
                      (member a (length b)))))
           (quote (implies (and (implies x y)
                                (and (implies y z)
                                     (and (implies z u)
                                          (implies u w))))
                           (implies x w)))))
    (setq ans (tautp term))))
(defun trans-of-implies (n)
  (list (quote implies)
        (trans-of-implies1 n)
        (list (quote implies)
              0 n)))
(defun trans-of-implies1 (n)
  (cond ((eql n 1)
         (list (quote implies)
               0 1))
        (t (list (quote and)
                 (list (quote implies)
                       (1- n)
                       n)
                 (trans-of-implies1 (1- n))))))
(defun truep (x lst)
  (or (equal x (quote (t)))
      (member x lst)))
(eval-when (compile load eval)
  (setup))
;;; make sure you've run (setup) then call: (test)

;;; BROWSE

;;; BROWSE -- Benchmark to create and browse through
;;; an AI-like data base of units.
;;; n is # of symbols
;;; m is maximum amount of stuff on the plist
;;; npats is the number of basic patterns on the unit
;;; ipats is the instantiated copies of the patterns
(defvar rand 21)
(defmacro char1 (x) `(aref (symbol-name ,x) 0))
(defun init (n m npats ipats)
  (let ((ipats (copy-tree ipats)))
    (do ((p ipats (cdr p)))
        ((null (cdr p)) (rplacd p ipats)))
    (do ((n n (1- n))
         (i m (cond ((= i 0) m)
                    (t (1- i))))
         (name (gensym) (gensym))
         (a ()))
        ((= n 0) a)
      (push name a)
      (do ((i i (1- i)))
          ((= i 0))
        (setf (get name (gensym)) nil))
      (setf (get name 'pattern)
            (do ((i npats (1- i))
                 (ipats ipats (cdr ipats))
                 (a ()))
                ((= i 0) a)
              (push (car ipats) a)))
      (do ((j (- m i) (1- j)))
          ((= j 0))
        (setf (get name (gensym)) nil)))))
(defun browse-random ()
  (setq rand (mod (* rand 17) 251)))
(defun randomize (l)
  (do ((a ()))
      ((null l) a)
    (let ((n (mod (browse-random) (length l))))
      (cond ((= n 0)
             (push (car l) a)
             (setq l (cdr l)))
            (t
             (do ((n n (1- n))
                  (x l (cdr x)))
                 ((= n 1)
                  (push (cadr x) a)
                  (rplacd x (cddr x)))))))))
(defun match (pat dat alist)
  (cond ((null pat)
         (null dat))
        ((null dat) ())
        ((or (eq (car pat) '\?)
             (eq (car pat)
                 (car dat)))
         (match (cdr pat) (cdr dat) alist))
        ((eq (car pat) '*)
         (or (match (cdr pat) dat alist)
             (match (cdr pat) (cdr dat) alist)
             (match pat (cdr dat) alist)))
        (t (cond
            ((atom (car pat))
             (cond
              ((eq (char1 (car pat)) ??)
               (let ((val (assoc (car pat) alist)))
                 (cond (val (match
                             (cons (cdr val)
                                   (cdr pat))
                             dat
                             alist))
                       (t (match
                           (cdr pat)
                           (cdr dat)
                           (cons (cons (car pat)
                                       (car dat))
                                 alist))))))
              ((eq (char1 (car pat)) ?*)
               (let ((val (assoc (car pat) alist)))
                 (cond (val (match
                             (append (cdr val)
                                     (cdr pat))
                             dat
                             alist))
                       (t
                        (do ((l () (nconc l (cons (car d) nil)))
                             (e (cons () dat) (cdr e))
                             (d dat (cdr d)))
                            ((null e) ())
                          (cond ((match
                                  (cdr pat)
                                  d
                                  (cons (cons (car pat) l)
                                        alist))
                                 (return t))))))))))
            (t (and
                (not (atom (car dat)))
                (match (car pat)
                       (car dat) alist)
                (match (cdr pat)
                       (cdr dat) alist)))))))
(defun browse ()
  (investigate (randomize
                (init
                 100
                 10
                 4
                 '((a a a b b b b a a a a a b b a a a)
                   (a a b b b b a a
                      (a a)(b b))
                   (a a a b (b a) b a b a))))
               '((*a \?b *b \?b a *a a *b *a)
                 (*a *b *b *a (*a) (*b))
                 (\? \? * (b a) * \? \?))))
(defun investigate (units pats)
  (do ((units units (cdr units)))
      ((null units))
    (do ((pats pats (cdr pats)))
        ((null pats))
      (do ((p (get (car units) 'pattern)
              (cdr p)))
          ((null p))
        (match (car pats) (car p) ())))))
;;; call: (browse)

;;; DESTRUCTIVE

;;; DESTRU -- Destructive operation benchmark
(defun destructive (n m)
  (let ((l (do ((i 10 (1- i))
                (a () (push () a)))
               ((= i 0) a))))
    (do ((i n (1- i)))
        ((= i 0))
      (cond ((null (car l))
             (do ((l l (cdr l)))
                 ((null l))
               (or (car l)
                   (rplaca l (cons () ())))
               (nconc (car l)
                      (do ((j m (1- j))
                           (a () (push () a)))
                          ((= j 0) a)))))
            (t
             (do ((l1 l (cdr l1))
                  (l2 (cdr l) (cdr l2)))
                 ((null l2))
               (rplacd (do ((j (floor (length (car l2)) 2)
                               (1- j))
                            (a (car l2) (cdr a)))
                           ((zerop j) a)
                         (rplaca a i))
                       (let ((n (floor (length (car l1)) 2)))
                         (cond ((= n 0) (rplaca l1 ())
                                (car l1))
                               (t
                                (do ((j n (1- j))
                                     (a (car l1) (cdr a)))
                                    ((= j 1)
                                     (prog1 (cdr a)
                                       (rplacd a ())))
                                  (rplaca a i))))))))))))
;;; call: (destructive 600. 50.)

;;; TRAVERSE

;;; TRAVERSE -- Benchmark that creates and traverses
;;;              a tree structure.
(defstruct node
  (parents ())
  (sons ())
  (sn (snb))
  (entry1 ())
  (entry2 ())
  (entry3 ())
  (entry4 ())
  (entry5 ())
  (entry6 ())
  (mark ()))
(defvar *sn* 0)
(defvar *rand* 21)
(defvar *count* 0)
(defvar *marker* nil)
(defvar *root*)
(defun snb ()
  (setq *sn* (1+ *sn*)))
(defun seed ()
  (setq *rand* 21))
(defun traverse-random () (setq *rand* (mod (* *rand* 17)
                                            251)))
(defun traverse-remove (n q)
  (cond ((eq (cdr (car q)) (car q))
         (prog2 () (caar q) (rplaca q ())))
        ((= n 0)
         (prog2 () (caar q)
           (do ((p (car q) (cdr p)))
               ((eq (cdr p) (car q))
                (rplaca q
                        (rplacd p (cdr (car q))))))))
        (t (do ((n n (1- n))
                (q (car q) (cdr q))
                (p (cdr (car q)) (cdr p)))
               ((= n 0) (prog2 () (car q) (rplacd q p)))))))
(defun traverse-select (n q)
  (do ((n n (1- n))
       (q (car q) (cdr q)))
      ((= n 0) (car q))))
(defun add (a q)
  (cond ((null q)
         `(,(let ((x `(,a)))
              (rplacd x x) x)))
        ((null (car q))
         (let ((x `(,a)))
           (rplacd x x)
           (rplaca q x)))
        (t (rplaca q
                   (rplacd (car q) `(,a . ,(cdr (car q))))))))
(defun create-structure (n)
  (let ((a `(,(make-node))))
    (do ((m (1- n) (1- m))
         (p a))
        ((= m 0) (setq a `(,(rplacd p a)))
         (do ((unused a)
              (used (add (traverse-remove 0 a) ()))
              (x) (y))
             ((null (car unused))
              (find-root (traverse-select 0 used) n))
           (setq x (traverse-remove
                    (mod (traverse-random) n)
                    unused))
           (setq y (traverse-select
                    (mod (traverse-random) n)
                    used))
           (add x used)
           (setf (node-sons y) `(,x . ,(node-sons y)))
           (setf (node-parents x) `(,y . ,(node-parents x))) ))
      (push (make-node) a))))
(defun find-root (node n)
  (do ((n n (1- n)))
      ((= n 0) node)
    (cond ((null (node-parents node))
           (return node))
          (t (setq node (car (node-parents node)))))))
(defun travers (node mark)
  (cond ((eq (node-mark node) mark) ())
        (t (setf (node-mark node) mark)
           (setq *count* (1+ *count*))
           (setf (node-entry1 node) (not (node-entry1 node)))
           (setf (node-entry2 node) (not (node-entry2 node)))
           (setf (node-entry3 node) (not (node-entry3 node)))
           (setf (node-entry4 node) (not (node-entry4 node)))
           (setf (node-entry5 node) (not (node-entry5 node)))
           (setf (node-entry6 node) (not (node-entry6 node)))
           (do ((sons (node-sons node) (cdr sons)))
               ((null sons) ())
             (travers (car sons) mark)))))
(defun traverse (root)
  (let ((*count* 0))
    (travers root (setq *marker* (not *marker*)))
    *count*))
(defmacro init-traverse ()
  (prog2 (setq *root* (create-structure 100)) ()))
(defmacro run-traverse ()
  (do ((i 50 (1- i)))
      ((= i 0))
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)))
;;; to initialize, call: (init-traverse)
;;; to run traverse, call: (run-traverse)
;;; N.B. max-lisp-eval-depth needs to be 1000 or so

;;; DERIV

;;; DERIV -- This is the Common Lisp version of a symbolic
;;; derivative benchmark written by Vaughan Pratt.
;;; It uses a simple subset of Lisp and does a lot of
;;; CONSing.
(defun deriv-aux (a) (list '/ (deriv a) a))
(defun deriv (a)
  (cond
   ((atom a)
    (cond ((eq a 'x) 1) (t 0)))
   ((eq (car a) '+)
    (cons '+ (mapcar #'deriv (cdr a))))
   ((eq (car a) '-)
    (cons '- (mapcar #'deriv
                     (cdr a))))
   ((eq (car a) '*)
    (list '*
          a
          (cons '+ (mapcar #'deriv-aux (cdr a)))))
   ((eq (car a) '/)
    (list '-
          (list '/
                (deriv (cadr a))
                (caddr a))
          (list '/
                (cadr a)
                (list '*
                      (caddr a)
                      (caddr a)
                      (deriv (caddr a))))))
   (t 'error)))
(defun run ()
  (declare (fixnum i)) ;improves the  code a little
  (do ((i 0 (1+ i)))
      ((= i 1000))     ;runs it 5000 times
    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (deriv '(+ (* 3 x x) (* a x x) (* b x) 5))))
;;; call:  (run)

;;; DDERIV

;;; DDERIV -- The Common Lisp version of a
;;; symbolic derivative benchmark, written by Vaughan Pratt.
;;;
;;; This benchmark is a variant of the simple symbolic
;;; derivative program (DERIV). The main change is that it is
;;; `table-driven.' Instead of using a large COND that branches
;;; on the CAR of the expression, this program finds the code
;;; that will take the derivative on the property list of the
;;; atom in the CAR position. So, when the expression is (+ .
;;; <rest>), the code stored under the atom '+ with indicator
;;; DERIV will take <rest> and return the derivative for '+. The
;;; way that MacLisp does this is with the special form: (DEFUN
;;; (FOO BAR) ...). This is exactly like DEFUN with an atomic
;;; name in that it expects an argument list and the compiler
;;; compiles code, but the name of the function with that code
;;; is stored on the property list of FOO under the indicator
;;; BAR, in this case.
(defun dderiv-aux (a)
  (list '/ (dderiv a) a))
(defun +dderiv (a)
  (cons '+ (mapcar 'dderiv a)))
(defun -dderiv (a)
  (cons '- (mapcar 'dderiv a)))
(defun *dderiv (a)
  (list '* (cons '* a)
        (cons '+ (mapcar 'dderiv-aux a))))
(defun /dderiv (a)
  (list '-
        (list '/
              (dderiv (car a))
              (cadr a))
        (list '/
              (car a)
              (list '*
                    (cadr a)
                    (cadr a)
                    (dderiv (cadr a))))))
(mapc
 #'(lambda (x)
     (setf
      (get (car x) 'dderiv)
      (symbol-function (cadr x))))
 '((+ +dderiv)(- -dderiv)(* *dderiv)(/ /dderiv)))
(defun dderiv (a)
  (cond
   ((atom a)
    (cond ((eq a 'x) 1) (t 0)))
   (t (let ((dderiv (get (car a) 'dderiv)))
        (cond (dderiv (funcall dderiv (cdr a)))
              (t 'error))))))
(defun run ()
  (declare (fixnum i))
  (do ((i 0 (1+ i)))
      ((= i 1000))
    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
    (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))))
;;; call:  (run)

;;; DIV2

;;; DIV2 -- Benchmark that divides by 2 using lists of n NIL's.
;;; This file contains a recursive as well as an iterative test.
(defun create-n (n)
  (do ((n n (1- n))
       (a () (push () a)))
      ((= n 0) a)))
(defvar ll (create-n 200))
(defun iterative-div2 (l)
  (do ((l l (cddr l))
       (a () (push (car l) a)))
      ((null l) a)))
(defun recursive-div2 (l)
  (cond ((null l) ())
        (t (cons (car l) (recursive-div2 (cddr l))))))
(defun test-1 (l)
  (do ((i 300 (1- i)))
      ((= i 0))
    (iterative-div2 l)
    (iterative-div2 l)
    (iterative-div2 l)
    (iterative-div2 l)))
(defun test-2 (l)
  (do ((i 300 (1- i)))
      ((= i 0))
    (recursive-div2 l)
    (recursive-div2 l)
    (recursive-div2 l)
    (recursive-div2 l)))
;;; for the iterative test call: (test-1 ll)
;;; for the recursive test call: (test-2 ll)

;;; FFT skipped due to lack of PROG.
;;; PUZZLE, TRIANGLE, FPRINT, FREAD, TPRINT, FRPOLY remain.