;;; gabriel.lisp -- the Gabriel benchmarks, in Common Lisp
;;
;;
;; This file contains the common lisp version of the lisp performance
;; benchmarks from Stanford.  These were translated and tested using
;; Symbolics Common Lisp on a Symbolics 3600.  The benchmarks in this
;; file have not been "tuned" to any particular implementation.
;;
;; The benchmarks have been substantially cleaned up and made truly
;; Common Lisp at CMU by Rob Maclachlan and Skef Wholey.  Timing
;; functions for each benchmark have been added.  Declarations have
;; been added by David B. McDonald.  Declarations should only affect
;; performance on general purpose hardware.  Also, this reduces or
;; eliminates the error checking and may allow the system to be
;; corrupted if incorrect programs are run.
;;
;;
;; Modifications by Eric Marsden:
;;
;; - removed CMUCL-specific (proclaim start-block) stuff
;;
;; - removed some declarations that I considered abusive, such as
;;   (declare fixnum) for iteration variables in DO and DOLIST forms
;;
;; - fix bug in the Boyer benchmark as per Heny Baker's paper "The
;;   Boyer Benchmark Meets Linear Logic"
;;
;; - some renamings to be closer to standard CL style (eg global
;;   variable names with asterisk). Only partially done...



(in-package :cl-bench.gabriel)

;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; Fairly CONS intensive.

(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 (assoc term alist :test #'eq))
		(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 :test #'eq)))


(defun one-way-unify (term1 term2)
  (progn (setq unify-subst nil)
	 (one-way-unify1 term1 term2)))

;; this function is buggy -- see "The Boyer Benchmark Meets Linear
;; Logic" by Henry Baker. Corrected version below.

;; (defun one-way-unify1 (term1 term2)
;;   (cond ((atom term2)
;; 	 (cond ((setq temp-temp (assoc term2 unify-subst :test #'eq))
;; 		(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 (term1 term2)                                          ; With bug fixed.
  (cond ((atom term2)
         (cond ((setq temp-temp (assoc term2 unify-subst :test #'eq))
                (equal term1 (cdr temp-temp)))
               ;; this clause added
               ((numberp term2) (equal term1 term2))
               (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-boyer ()
  (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 boyer ()
  (let (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)))))
     (tautp term)))

(defun trans-of-implies (n)
  (list (quote implies)
	(trans-of-implies1 n)
	(list (quote implies)
	      0 n)))

(defun trans-of-implies1 (n)
  (declare (fixnum 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 :test #'eq)))

(eval-when (:load-toplevel :execute)
  (setup-boyer))


;;; 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 browse-rand 21.)

(defmacro char1 (x) `(aref (string ,x) 0))

(defun init-browse (n m npats ipats)
  (declare (fixnum n m npats))
  (let ((ipats (copy-tree ipats)))
    (do ((p ipats (cdr p)))
	((null (cdr p)) (rplacd p ipats)))
    (do ((n n (1- n))
	 (i m (cond ((= (the fixnum i) 0) m)
		    (t (1- i))))
	 (name (gentemp) (gentemp))
	 (a ()))
	((= (the fixnum n) 0) a)
      (push name a)
      (do ((i i (1- i)))
	  ((= (the fixnum i) 0))
	(setf (get name (gensym)) nil))
      (setf (get name 'pattern)
	    (do ((i npats (1- i))
		 (ipats ipats (cdr ipats))
		 (a ()))
		((= (the fixnum i) 0) a)
	      (push (car ipats) a)))
      (do ((j (- m i) (1- j)))
	  ((= (the fixnum j) 0))
	(setf (get name (gensym)) nil)))))

(defun browse-random ()
  (setq browse-rand (mod (the fixnum (* (the fixnum browse-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-browse 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) ())))))


;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility.

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

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

(defun run-ctak ()
  (ctak 22 12 8))


;;; DDERIV -- The Common Lisp version of a symbolic derivative benchmark, written
;;; by Vaughn 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)))
(setf (get '+ 'dderiv)  #'+-dderiv)

(defun --dderiv (a)
  (cons '- (mapcar #'dderiv a)))
(setf (get '- 'dderiv) #'--dderiv)

(defun *-dderiv (a)
  (list '* (cons '* a)
	(cons '+ (mapcar #'dderiv-aux a))))
(setf (get '* 'dderiv) #'*-dderiv)

(defun /-dderiv (a)
  (list '-
	(list '/
	      (dderiv (car a))
	      (cadr a))
	(list '/
	      (car a)
	      (list '*
		    (cadr a)
		    (cadr a)
		    (dderiv (cadr a))))))
(setf (get '/ '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 (the function dderiv) (cdr a)))
	       (t 'error))))))

(defun dderiv-run ()
  (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))))


;;; DERIV -- This is the Common Lisp version of a symbolic derivative benchmark
;;; written by Vaughn 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 deriv-run ()
  (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))))


;;; DESTRU -- Destructive operation benchmark

(defun destructive (n m)
  (declare (fixnum 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))))))))))))

;; entry point for destructive test
(defun run-destructive ()
  (destructive 600 50))


;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
;;; This file contains a recursive as well as an iterative test.

(defun create-n (n)
  (declare (fixnum n))
  (do ((n n (1- n))
       (a () (push () a)))
      ((zerop n) a)))

(defvar div2-l (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 div2-test-1 (l)
  (do ((i 300 (1- i)))
      ((zerop i))
    (iterative-div2 l)
    (iterative-div2 l)
    (iterative-div2 l)
    (iterative-div2 l)))

(defun div2-test-2 (l)
  (do ((i 300 (1- i)))
      ((zerop i))
    (recursive-div2 l)
    (recursive-div2 l)
    (recursive-div2 l)
    (recursive-div2 l)))

(defun run-div2-test1 ()
  (div2-test-1 div2-l))

(defun run-div2-test2 ()
  (div2-test-2 div2-l))



;;; FFT -- This is an FFT benchmark written by Harry Barrow.  It tests a
;;; variety of floating point operations, including array references.

(defvar re (make-array 1025 :element-type 'single-float :initial-element 0.0))
(defvar im (make-array 1025 :element-type 'single-float :initial-element 0.0))


;areal = real part
;aimag = imaginary part
(defun fft (areal aimag)
  (declare (type (simple-array single-float (1025)) areal aimag))
  (prog ((ar areal)
	 (ai aimag)
	 (i 0)
	 (j 0)
	 (k 0)
	 (m 0)
	 (n 0)
	 (le 0)
	 (le1 0)
	 (ip 0)
	 (nv2 0)
	 (ur 0.0)
	 (ui 0.0)
	 (wr 0.0)
	 (wi 0.0)
	 (tr 0.0)
	 (ti 0.0))
    (declare (fixnum i j k m n le le1 ip nv2)
	     (single-float ur ui wr wi tr ti))
    (setq n (array-dimension ar 0)
	  n (1- n)
	  nv2 (floor n 2)
	  m 0					;compute m = log(n)
	  i 1)
 l1 (cond ((< i n)
	   (setq m (1+ m)
		 i (+ i i))
	   (go l1)))
    (cond ((not (equal n (expt 2 m)))
	   (princ "error ... array size not a power of two.")
	   (read)
	   (return (terpri))))
    (setq j 1					;interchange elements
	  i 1)					;in bit-reversed order
 l3 (cond ((< i j)
	   (setq tr (aref ar j)
		 ti (aref ai j))
	   (setf (aref ar j) (aref ar i))
	   (setf (aref ai j) (aref ai i))
	   (setf (aref ar i) tr)
	   (setf (aref ai i) ti)))
    (setq k nv2)
 l6 (cond ((< k j)
	   (setq j (- j k)
		 k (/ k 2))
	   (go l6)))
    (setq j (+ j k)
	  i (1+ i))
    (cond ((< i n)
	   (go l3)))
    (do ((l 1 (1+ l)))
	((> l m))			;loop thru stages
      (setq le (expt 2 l)
	    le1 (floor le 2)
	    ur 1.0
	    ui 0.0
	    wr (cos (/ 3.14159265 le1))
	    wi (sin (/ 3.14159265 le1)))
      (do ((j 1 (1+ j)))
	  ((> j le1))		;loop thru butterflies
	(do ((i j (+ i le)))
	    ((> i n))		;do a butterfly
	  (setq ip (+ i le1)
		tr (- (* (aref ar ip) ur)
		      (* (aref ai ip) ui))
		ti (+ (* (aref ar ip) ui)
		      (* (aref ai ip) ur)))
	  (setf (aref ar ip) (- (aref ar i) tr))
	  (setf (aref ai ip) (- (aref ai i) ti))
	  (setf (aref ar i) (+ (aref ar i) tr))
	  (setf (aref ai i) (+ (aref ai i) ti))))
	(setq tr (- (* ur wr) (* ui wi))
	      ti (+ (* ur wi) (* ui wr))
	      ur tr
	      ui ti))
    (return t)))

(defun run-fft ()
  (dotimes (i 10)
    (fft re im)))



;;; FPRINT -- Benchmark to print to a file.

(defparameter +fread-temporary-pathname+ "/tmp/fprint.tst")

(defvar *fprint-test-atoms*
  '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
    mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
    wxyzab23 xyzabc34 123456ab 234567bc 345678cd
    456789de 567890ef 678901fg 789012gh 890123hi))

(defun fprint-init-aux (m n atoms)
  (declare (fixnum m n))
  (cond ((zerop m) (pop atoms))
	(t (do ((i n (- i 2))
		(a ()))
	       ((< i 1) a)
	     (push (pop atoms) a)
	     (push (fprint-init-aux (1- m) n atoms) a)))))

(defun fprint-init (m n atoms)
  (let ((atoms (subst () () atoms)))
    (do ((a atoms (cdr a)))
	((null (cdr a)) (rplacd a atoms)))
    (fprint-init-aux m n atoms)))

(defvar *fprint-test-pattern* (fprint-init 6. 6. *fprint-test-atoms*))

(defun fprint/ugly ()
  (with-open-file (sink +fread-temporary-pathname+
                        :direction :output
                        :if-exists :supersede)
    (let ((*print-pretty* nil)
          (*print-circle* nil)
          (*print-escape* nil)
          (*print-level* nil)
          (*print-readably* nil)
          (*print-base* 10))
      (print *fprint-test-pattern* sink))))

(defun fprint/pretty ()
  (with-open-file (sink +fread-temporary-pathname+
                        :direction :output
                        :if-exists :supersede)
    (let ((*print-pretty* t)
          (*print-circle* t)
          (*print-escape* t)
          (*print-level* 100)
          (*print-readably* t)
          (*print-base* 10))
      (pprint *fprint-test-pattern* sink))))



;;; FREAD -- Benchmark to read from a file.
;;; Pronounced "FRED".  Requires the existance of FPRINT.TST which is created
;;; by FPRINT.

(defun fread ()
  (with-open-file (source +fread-temporary-pathname+ :direction :input)
    (read source)))

;;; TPRINT -- Benchmark to print and read to the terminal.

(defvar *tprint-test-atoms*
  '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9
    stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d
    567d 678e 789f 890g))

(defun tprint-init (m n atoms)
  (let ((atoms (subst () () atoms)))
    (do ((a atoms (cdr a)))
	((null (cdr a)) (rplacd a atoms)))
    (tprint-init-aux m n atoms)))

(defun tprint-init-aux (m n atoms)
  (declare (fixnum m n))
  (cond ((zerop m) (pop atoms))
	(t (do ((i n (- i 2))
		(a ()))
	       ((< i 1) a)
	     (push (pop atoms) a)
	     (push (tprint-init-aux (1- m) n atoms) a)))))

(defvar *tprint-test-pattern* (tprint-init 6. 6. *tprint-test-atoms*))



;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic.
;; Originally writen in Franz Lisp by Richard Fateman.

(defvar *frpoly-v*)
(defvar *x*)
(defvar *alpha*)
(defvar *a*)
(defvar *b*)
(defvar *chk)
(defvar *l)
(defvar *p)
(defvar q*)
(defvar u*)
(defvar *var)
(defvar *y*)
(defparameter *frpoly-r* nil)
(defparameter *frpoly-r2* nil)
(defparameter *frpoly-r3* nil)

;; dummy definition -- doesn't get called at runtime
(defmacro pdiffer1 (a b) `(cons ,a ,b))

(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
(defmacro pcoefp (e) `(atom ,e))

(defmacro pzerop (x)
  `(if (numberp ,x) 					; no signp in CL
       (zerop ,x)))
(defmacro pzero () 0)
(defmacro cplus (x y) `(+ ,x ,y))
(defmacro ctimes (x y) `(* ,x ,y))

(defun pcoefadd (e c x)
  (if (pzerop c)
      x
      (cons e (cons c x))))

(defun pcplus (c p)
  (if (pcoefp p)
      (cplus p c)
      (psimp (car p) (pcplus1 c (cdr p)))))

(defun pcplus1 (c x)
  (cond ((null x)
	 (if (pzerop c)
	     nil
	     (cons 0 (cons c nil))))
	((pzerop (car x))
	 (pcoefadd 0 (pplus c (cadr x)) nil))
	(t
	 (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))

(defun pctimes (c p)
  (if (pcoefp p)
      (ctimes c p)
      (psimp (car p) (pctimes1 c (cdr p)))))

(defun pctimes1 (c x)
  (if (null x)
      nil
      (pcoefadd (car x)
		(ptimes c (cadr x))
		(pctimes1 c (cddr x)))))

(defun pplus (x y)
  (cond ((pcoefp x)
	 (pcplus x y))
	((pcoefp y)
	 (pcplus y x))
	((eq (car x) (car y))
	 (psimp (car x) (pplus1 (cdr y) (cdr x))))
	((pointergp (car x) (car y))
	 (psimp (car x) (pcplus1 y (cdr x))))
	(t
	 (psimp (car y) (pcplus1 x (cdr y))))))

(defun pplus1 (x y)
  (cond ((null x) y)
	((null y) x)
	((= (car x) (car y))
	 (pcoefadd (car x)
		   (pplus (cadr x) (cadr y))
		   (pplus1 (cddr x) (cddr y))))
	((> (car x) (car y))
	 (cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
	(t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))

(defun psimp (var x)
  (cond ((null x) 0)
	((atom x) x)
	((zerop (car x))
	 (cadr x))
	(t
	 (cons var x))))

(defun ptimes (x y)
  (cond ((or (pzerop x) (pzerop y))
	 (pzero))
	((pcoefp x)
	 (pctimes x y))
	((pcoefp y)
	 (pctimes y x))
	((eq (car x) (car y))
	 (psimp (car x) (ptimes1 (cdr x) (cdr y))))
	((pointergp (car x) (car y))
	 (psimp (car x) (pctimes1 y (cdr x))))
	(t
	 (psimp (car y) (pctimes1 x (cdr y))))))

(defun ptimes1 (*x* y)
  (prog (u* *frpoly-v*)
	(setq *frpoly-v* (setq u* (ptimes2 y)))
     a
	(setq *x* (cddr *x*))
	(if (null *x*)
	    (return u*))
	(ptimes3 y)
	(go a)))

(defun ptimes2 (y)
  (if (null y)
      nil
      (pcoefadd (+ (car *x*) (car y))
		(ptimes (cadr *x*) (cadr y))
		(ptimes2 (cddr y)))))

(defun ptimes3 (y)
  (prog (e u c)
     a1	(if (null y)
	    (return nil))
	(setq e (+ (car *x*) (car y))
	      c (ptimes (cadr y) (cadr *x*) ))
	(cond ((pzerop c)
	       (setq y (cddr y))
	       (go a1))
	      ((or (null *frpoly-v*) (> e (car *frpoly-v*)))
	       (setq u* (setq *frpoly-v* (pplus1 u* (list e c))))
	       (setq y (cddr y))
	       (go a1))
	      ((= e (car *frpoly-v*))
	       (setq c (pplus c (cadr *frpoly-v*)))
	       (if (pzerop c) 			; never true, evidently
		   (setq u* (setq *frpoly-v* (pdiffer1 u* (list (car *frpoly-v*) (cadr *frpoly-v*)))))
		   (rplaca (cdr *frpoly-v*) c))
	       (setq y (cddr y))
	       (go a1)))
     a  (cond ((and (cddr *frpoly-v*) (> (caddr *frpoly-v*) e))
	       (setq *frpoly-v* (cddr *frpoly-v*))
	       (go a)))
	(setq u (cdr *frpoly-v*))
     b  (if (or (null (cdr u)) (< (cadr u) e))
	    (rplacd u (cons e (cons c (cdr u)))) (go e))
	(cond ((pzerop (setq c (pplus (caddr u) c)))
	       (rplacd u (cdddr u))
	       (go d))
	      (t
	       (rplaca (cddr u) c)))
     e  (setq u (cddr u))
     d  (setq y (cddr y))
	(if (null y)
	    (return nil))
	(setq e (+ (car *x*) (car y))
	      c (ptimes (cadr y) (cadr *x*)))
     c  (cond ((and (cdr u) (> (cadr u) e))
	       (setq u (cddr u))
	       (go c)))
	(go b)))

(defun pexptsq (p n)
  (do ((n (floor n 2) (floor n 2))
       (s (if (oddp n) p 1)))
      ((zerop n) s)
    (setq p (ptimes p p))
    (and (oddp n) (setq s (ptimes s p)))))

(eval-when (:load-toplevel :execute)
  (setf (get 'x 'order) 1)
  (setf (get 'y 'order) 2)
  (setf (get 'z 'order) 3))


;; r = x+y+z+1
;; r2 = 100000 * r
;; r3 = r with floating point coefficients
(defparameter *frpoly-r* (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))))
(defparameter *frpoly-r2* (ptimes *frpoly-r* 100000))
(defparameter *frpoly-r3* (ptimes *frpoly-r* 1.0))


(defun run-frpoly/fixnum ()
  (dolist (exp '(2 5 10 15))
    (pexptsq *frpoly-r* exp)))

(defun run-frpoly/bignum ()
  (dolist (exp '(2 5 10 15))
    (pexptsq *frpoly-r2* exp)))

(defun run-frpoly/float ()
  (dolist (exp '(2 5 10 15))
    (pexptsq *frpoly-r3* exp)))


;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in
;; Pascal. Solves a combinatorial puzzle by exploring the search
;; space, using arrays to represent state.
;;
;; Comments from Henry Baker: Puzzle solves a 3-dimensional packing
;; problem by attempting to pack pieces of 4 different types into a
;; 5x5x5 cube. The class of such packing problems is closely related
;; to the "bin-packing" and "knapsack" problems of complexity theory,
;; which are known to be NP-complete.
;;
;; The standard Gabriel code for Puzzle solves the problem by
;; "pre-rotating" all of the different puzzle pieces, so that these
;; rotations do not have to be performed during the actual
;; combinatorial search. Thus, each piece "class" has a number of
;; different piece "types" which result from different rotations of
;; the pieces. For example, the 4x2x1 piece has 6 distinct rotations,
;; while the 2x2x2 piece has only 1. The 5x5x5 puzzle cube itself is
;; represented as a section of an 8x8x8 cube of Boolean values, while
;; the various piece types (rotations) are represented as a vector of
;; Boolean values which is in correspondence with the representation
;; of the puzzle itself. By embedding a 5x5x5 cube within an 8x8x8
;; cube, a "border" is created which makes sure that the pieces stay
;; within the 5x5x5 boundaries.
;;
;; After initialization, the standard Puzzle code linearly searches
;; the puzzle representation for the smallest-numbered empty location.
;; It then tries all of the remaining pieces to see if they can be fit
;; into the puzzle in such a way that this empty location will be
;; filled. If a piece can be fitted, then the code performs a
;; depth-first search for the next empty location and the next piece
;; to be fitted. In many instances, the code will find that it has
;; pieces which cannot be fitted, and initiates a backtrack to remove
;; previously fitted pieces.
;; 
;; The standard code investigates 2,005 placements of the 18 pieces.
;; The speed of the standard code is highly dependent upon the
;; ordering of the pieces, which affects the ordering of the search; a
;; different ordering investigated 10 times as many placements, for
;; example. Interestingly enough, of the 2,005 partially-completed
;; puzzles investigated, 1,565 of them are distinct, meaning that
;; there is little hope of speedup from the "memoization" techniques
;; which have been found effective for other puzzles and games
;; [Bird80] [Baker92]. (The standard implementation of Puzzle
;; investigates surprisingly few configurations, making the ordering
;; of the puzzle pieces appear to have been tampered with to produce
;; shorter searches. See [Beeler84] for deeper analysis of the puzzle
;; itself.)
;; 
;; The standard Gabriel code for Puzzle does not have any errors, but
;; it does show evidence of a hasty conversion from a non-Lisp
;; language. It cannot decide, for example, whether to consistently
;; use 0-origin or 1-origin indexing. The standard code prefers to use
;; the more complex do instead of the simpler dotimes, and does not
;; utilize macros like incf and decf. None of these stylistic issues
;; should affect performance, however.
;; 
;; The one obvious stylistic change which could significantly improve
;; performance occurs at the end of the place routine where the puzzle
;; is searched for the smallest-numbered empty location. The Common
;; Lisp position "sequence" function could be used for this purpose,
;; and it could conceivably improve performance due to its presumably
;; high level of optimization.
;;
;; <URL:http://home.pipeline.com/~hbaker1/PuzzleB.html>

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +puzzle-size+ 511)
  (defconstant +puzzle-classmax+ 3)
  (defconstant +puzzle-dee+ 8)
  (defconstant +puzzle-typemax+ 12))

(defvar *iii* 0)
(defvar *kount* 0)

(declaim (type fixnum +puzzle-size+ +puzzle-classmax+ +puzzle-typemax+
               *iii* *kount* +puzzle-dee+))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (deftype class-vector () `(simple-vector ,(1+ +puzzle-classmax+)))
  (deftype type-vector () `(simple-vector ,(1+ +puzzle-typemax+)))
  (deftype size-vector () `(simple-vector ,(1+ +puzzle-size+)))
  (deftype p-array () `(simple-array t (,(1+ +puzzle-typemax+) ,(1+ +puzzle-size+)))))

(defvar *piece-count* (make-array (1+ +puzzle-classmax+) :initial-element 0))
(defvar *class* (make-array (1+ +puzzle-typemax+) :initial-element 0))
(defvar *piecemax* (make-array (1+ +puzzle-typemax+) :initial-element 0))
(defvar *puzzle* (make-array (1+ +puzzle-size+)))
(defvar *puzzle-p* (make-array (list (1+ +puzzle-typemax+) (1+ +puzzle-size+))))

(declaim (type type-vector *class* *piecemax*))
(declaim (type class-vector *piece-count*))
(declaim (type size-vector *puzzle*))
(declaim (type p-array *puzzle-p*))

(defun fit (i j)
  (declare (fixnum i j))
  (dotimes (k (svref *piecemax* i))
    (and (aref *puzzle-p* i k)
         (svref *puzzle* (+ j k))
         (return nil)))
  t)

(defun place (i j)
  (declare (fixnum i j))
  (let ((end (svref *piecemax* i)))
    (declare (fixnum end))
    (dotimes (k end)
      (when (aref *puzzle-p* i k)
        (setf (svref *puzzle* (+ j k)) t)))
    (setf (svref *piece-count* (svref *class* i))
	  (the fixnum (- (the fixnum (svref *piece-count* (svref *class* i))) 1)))
    (do ((k j (1+ k)))
	((> k +puzzle-size+)
;	 (terpri)
;	 (princ "Puzzle filled")
	 0)
      (unless (svref *puzzle* k)
        (return k)))))

(defun puzzle-remove (i j)
  (declare (fixnum i j))
  (let ((end (svref *piecemax* i)))
    (declare (fixnum end))
    (do ((k 0 (1+ k)))
	((> k end))
      (when (aref *puzzle-p* i k)
        (setf (svref *puzzle* (+ j k))  nil))
      (setf (svref *piece-count* (svref *class* i))
	    (the fixnum (+ (the fixnum (svref *piece-count* (svref *class* i)))
			   1))))))

(defun trial (j)
  (declare (fixnum j))
  (let ((k 0))
    (declare (fixnum k))
    (do ((i 0 (1+ i)))
	((> i +puzzle-typemax+)
         (incf *kount*)
	 nil)
      (unless (eql (svref *piece-count* (svref *class* i)) 0)
        (when (fit i j)
          (setq k (place i j))
          (cond ((or (trial k)
                     (= k 0))
                 ;; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
                 (incf *kount*)
                 (return t))
                (t (puzzle-remove i j))))))))

(defun definepiece (iclass ii jj kk)
  (declare (fixnum ii jj kk))
  (let ((index 0))
    (declare (fixnum index))
    (do ((i 0 (1+ i)))
	((> i ii))
      (do ((j 0 (1+ j)))
	  ((> j jj))
	(do ((k 0 (1+ k)))
	    ((> k kk))
	  (setq index  (+ i (the fixnum
                              (* +puzzle-dee+ (the fixnum
                                                (+ j (the fixnum (* +puzzle-dee+ k))))))))
	  (setf (aref *puzzle-p* *iii* index)  t))))
    (setf (svref *class* *iii*) iclass)
    (setf (svref *piecemax* *iii*) index)
    (unless (= *iii* +puzzle-typemax+)
      (incf *iii*))))

(defun run-puzzle ()
  (do ((m 0 (1+ m)))
      ((> m +puzzle-size+))
    (setf (svref *puzzle* m) t))
  (do ((i 1 (1+ i)))
      ((> i 5))
    (do ((j 1 (1+ j)))
	((> j 5))
      (do ((k 1 (1+ k)))
	  ((> k 5))
	(setf (svref *puzzle*
		     (+ i
			(the fixnum
			     (* +puzzle-dee+ (the fixnum
					 (+ j (the fixnum (* +puzzle-dee+ k))))))))
	      nil))))
  (do ((i 0 (1+ i)))
      ((> i +puzzle-typemax+))
    (do ((m 0 (1+ m)))
	((> m +puzzle-size+))
      (setf (aref *puzzle-p* i m)  nil)))
  (setq *iii* 0)
  (definePiece 0 3 1 0)
  (definePiece 0 1 0 3)
  (definePiece 0 0 3 1)
  (definePiece 0 1 3 0)
  (definePiece 0 3 0 1)
  (definePiece 0 0 1 3)

  (definePiece 1 2 0 0)
  (definePiece 1 0 2 0)
  (definePiece 1 0 0 2)

  (definePiece 2 1 1 0)
  (definePiece 2 1 0 1)
  (definePiece 2 0 1 1)

  (definePiece 3 1 1 1)

  (setf (svref *piece-count* 0) 13.)
  (setf (svref *piece-count* 1) 3)
  (setf (svref *piece-count* 2) 1)
  (setf (svref *piece-count* 3) 1)
  (let ((m (1+ (* +puzzle-dee+ (1+ +puzzle-dee+))))
	(n 0)
	(*kount* 0))
    (declare (fixnum m n))
    (cond ((fit 0 m) (setq n (place 0 m)))
	  (t (format t "~%Error.")))
    (cond ((trial n)
	   ;; (format t "~%Success in ~4D trials." kount)
           )
	  (t (format t "~%Failure.")))))



;;; TAK -- A vanilla version of the TAKeuchi function and one with tail recursion
;;; removed.

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

(defun run-tak ()
  (tak 18 12 6))


(defun trtak (x y z)
  (declare (fixnum x y z))
  (prog ()
    tak
    (if (not (< y x))
	(return z)
	(let ((a (tak (1- x) y z))
	      (b (tak (1- y) z x)))
	  (setq z (tak (1- z) x y)
		x a
		y b)
	  (go tak)))))

(defun run-trtak ()
   (trtak 18 12 6))



;;; TAKL -- The TAKeuchi function using lists as counters.

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

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

(defun mas (x y z)
  (declare (list 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 run-takl ()
  (let ((l18 (listn 18.))
        (l12 (listn 12.))
        (l6 (listn 6.)))
    (mas l18 l12 l6)))


;;; STAK -- The TAKeuchi function with special variables instead of parameter
;;; passing.

(defvar *stak-x*)
(defvar *stak-y*)
(defvar *stak-z*)

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

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

(defun run-stak ()
  (stak 18 12 6))


;;; TRAVERSE --  Benchmark which 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* )


(declaim (fixnum *sn* *rand*count))

(defun snb ()
  (setq *sn* (the fixnum (1+ (the fixnum *sn*)))))

(defun seed ()
  (setq *rand* 21.))

(defun traverse-random ()
  (setq *rand* (rem (the fixnum (* (the fixnum *rand*) 17.)) 251.)))

(defun traverse-remove (n q)
  (cond ((eq (cdr (car q)) (car q))
	 (prog2 () (caar q) (rplaca q ())))
	((= (the fixnum 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 (the fixnum (1- n)))
		(q (car q) (cdr q))
		(p (cdr (car q)) (cdr p)))
	       ((= (the fixnum n) 0) (prog2 () (car q) (rplacd q p)))))))

(defun traverse-select (n q)
  (do ((n n (the fixnum (1- n)))
       (q (car q) (cdr q)))
      ((= (the fixnum 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)
  (declare (fixnum n))
  (let ((a `(,(make-node))))
    (do ((m (the fixnum (1- n)) (the fixnum (1- m)))
	 (p a))
	((= (the fixnum 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 (rem (traverse-random) n) unused))
	   (setq y (traverse-select (rem (traverse-random) n) used))
	   (add x used)
	   (setf (node-sons y) `(,x .,(node-sons y)))
	   (setf (node-parents x) `(,y .,(node-parents x))) ))
      (declare (fixnum m))
      (push (make-node) a))))

(defun find-root (node n)
  (declare (fixnum n))
  (do ((n n (the fixnum (1- n))))
      ((= (the fixnum 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* (the fixnum (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*))

(defun run-traverse ()
  (setq *root* (create-structure 100.))
  (do ((i 50. (the fixnum (1- i))))
      ((= (the fixnum i) 0))
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)
    (traverse *root*)))



;;; TRIANG -- Board game benchmark.

(defvar board (make-array 16. :initial-element 1))
(setf (aref board 5) 0)

(defvar triang-sequence (make-array 14. :initial-element 0))
(defvar triang-a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12
						13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6)))
(defvar triang-b (make-array 37. :initial-contents  '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
						 2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5)))
(defvar triang-c (make-array 37. :initial-contents  '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
						 1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4)))
(defvar answer)
(defvar final)

(declaim (type simple-vector board triang-sequence triang-a triang-b triang-c))

(defun last-position ()
  (do ((i 1 (1+ i)))
      ((= i 16.) 0)
    (if (= 1 (the fixnum (aref board i)))
	(return i))))

(defun try (i depth)
  (declare (fixnum i depth))
  (cond ((= depth 14)
	 (let ((lp (last-position)))
	   (unless (member lp final)
	     (push lp final)))
	 (push (cdr (coerce (the simple-vector triang-sequence) 'list))
	       answer) t)	; this is a hack to replace LISTARRAY
	((and (= 1 (the fixnum (aref board (aref triang-a i))))
	      (= 1 (the fixnum (aref board (aref triang-b i))))
	      (= 0 (the fixnum (aref board (aref triang-c i)))))
	 (setf (aref board (aref triang-a i)) 0)
	 (setf (aref board (aref triang-b i)) 0)
	 (setf (aref board (aref triang-c i)) 1)
	 (setf (aref triang-sequence depth) i)
	 (do ((j 0 (1+ j))
	      (depth (1+ depth)))
	     ((or (= j 36.)
		  (try j depth)) ()))
         (setf (aref board (aref triang-a i)) 1)
	 (setf (aref board (aref triang-b i)) 1)
	 (setf (aref board (aref triang-c i)) 0) ())))

(defun triangle (i)
  (let ((answer ())
	(final ()))
    (try i 1)))

;; entry point 
(defun run-triangle ()
  (triangle 22))

;; EOF