mike@yetti.UUCP (Mike Clarkson ) (07/18/87)
Enclosed are the Gabriel benchmarks for Common Lisp, which were kindly
sent to me by Stan Shebs at Utah. I have compiled them under Lucid
and Dec Common Lisp without any problem. If you don't have a copy of
Gabriel's book on the subject, you should pick up a copy:
Richard P. Gabriel,
Performance and Evaluation of Lisp Systems,
MIT Press, 1985.
ISBN 0-262-07093-6
I would be interested in hearing from you with any results from the
benchmark suites, or of translations into different dialects of Lisp,
most notably Franz, or Scheme.
Mike Clarkson, ...!allegra \ BITNET: SYMALG@YUSOL or
CRESS, York University, ...!decvax \ mike@YUYETTI
4700 Keele Street, ...!ihnp4 > !utzoo!yetti!mike
North York, Ontario, ...!linus /
CANADA M3J 1P3. ...!watmath / Phone: +1 (416) 736-2100 x 7767
Long Live the Albigensian Heresy!
-------------------------------- cut here ------------------------------------
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# boyer.cl
# browse.cl
# ctak.cl
# dderiv.cl
# deriv.cl
# destruct.cl
# div.cl
# fft.cl
# fprint.cl
# fread.cl
# frpoly.cl
# puzzle.cl
# stak.cl
# tak.cl
# takl.cl
# takr.cl
# timer.cl
# tprint.cl
# traverse.cl
# triangle.cl
# This archive created: Thu Jul 16 04:01:51 1987
export PATH; PATH=/bin:$PATH
if test -f 'boyer.cl'
then
echo shar: will not over-write existing file "'boyer.cl'"
else
cat << \SHAR_EOF > 'boyer.cl'
;From: ihnp4!utah-cs!shebs@utah-cs.UTAH-CS (Stanley Shebs)
;Organization: University of Utah, Salt Lake City
;BTW, we have complete sets for PSL and Common Lisp that I can probably
;shar together and send. The code below is basically what's in Gabriel's
;book, but the PSL version bears less resemblance (different dialect):
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: boyer.cl
; Description: The Boyer benchmark
; Author: Bob Boyer
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:52:20 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)))
(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 (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-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 ()
(prog (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 ((equal n 1) ; I think (eql n 1) may work here
(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 (load eval)
(setup))
;;; make sure you've run (setup) then call: (test)
(run-benchmark "Boyer" '(test))
SHAR_EOF
fi # end of overwriting check
if test -f 'browse.cl'
then
echo shar: will not over-write existing file "'browse.cl'"
else
cat << \SHAR_EOF > 'browse.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: browse.cl
; Description: The BROWSE benchmark from the Gabriel tests
; Author: Richard Gabriel
; Created: 8-Apr-85
; Modified: 14-Jun-85 18:44:49 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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) `(schar (symbol-name ,x) 0))
(defun init (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 ((= i 0) m)
(t (1- i))))
(name (gensym) (gensym))
(a nil))
((= n 0) a)
(declare (fixnum n i))
(push name a)
(do ((i i (1- i)))
((= i 0))
(declare (fixnum i))
(setf (get name (gensym)) nil))
(setf (get name 'pattern)
(do ((i npats (1- i))
(ipats ipats (cdr ipats))
(a ()))
((= i 0) a)
(declare (fixnum i ipats))
(push (car ipats) a)))
(do ((j (- m i) (1- j)))
((= j 0))
(declare (fixnum j))
(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))))
(declare (fixnum n))
(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)))
(declare (fixnum n))))))))
(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)
(run-benchmark "Browse" '(browse))
SHAR_EOF
fi # end of overwriting check
if test -f 'ctak.cl'
then
echo shar: will not over-write existing file "'ctak.cl'"
else
cat << \SHAR_EOF > 'ctak.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: ctak.cl
; Description: The ctak benchmark
; Author: Richard Gabriel
; Created: 5-Apr-85
; Modified: 10-Apr-85 14:53:02 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CTAK -- A version of the TAK function that uses the CATCH/THROW facility.
(defun ctak (x y z)
(catch 'ctak (ctak-aux x y z)))
(defun ctak-aux (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) ;xy
(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))))))
;;; call: (ctak 18 12 6)
(run-benchmark "CTAK" '(ctak 18 12 6))
SHAR_EOF
fi # end of overwriting check
if test -f 'dderiv.cl'
then
echo shar: will not over-write existing file "'dderiv.cl'"
else
cat << \SHAR_EOF > 'dderiv.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: dderiv.cl
; Description: DDERIV benchmark from the Gabriel tests
; Author: Vaughan Pratt
; Created: 8-Apr-85
; Modified: 10-Apr-85 14:53:29 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DDERIV -- 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. You may have
;;; to do something like:
;;; :property keyword is not Common Lisp.
(defun dderiv-aux (a)
(list '/ (dderiv a) a))
(defun +dderiv (a)
(cons '+ (mapcar 'dderiv a)))
(setf (get '+ 'dderiv) '+dderiv) ; install function on the property list
(defun -dderiv (a)
(cons '- (mapcar 'dderiv a)))
(setf (get '- 'dderiv) '-dderiv) ; install function on the property list
(defun *dderiv (a)
(list '* (cons '* a)
(cons '+ (mapcar 'dderiv-aux a))))
(setf (get '* 'dderiv) '*dderiv) ; install function on the property list
(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) ; install function on the property list
(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 ()
(do ((i 0 (1+ i)))
((= i 1000))
(declare (fixnum i))
(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)
(run-benchmark "Dderiv" '(run))
SHAR_EOF
fi # end of overwriting check
if test -f 'deriv.cl'
then
echo shar: will not over-write existing file "'deriv.cl'"
else
cat << \SHAR_EOF > 'deriv.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: deriv.cl
; Description: The DERIV benchmark from the Gabriel tests.
; Author: Vaughan Pratt
; Created: 8-Apr-85
; Modified: 10-Apr-85 14:53:50 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DERIV -- 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 run ()
(do ((i 0 (1+ i)))
((= i 1000))
(declare (fixnum i))
(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)
(run-benchmark "Deriv" '(run))
SHAR_EOF
fi # end of overwriting check
if test -f 'destruct.cl'
then
echo shar: will not over-write existing file "'destruct.cl'"
else
cat << \SHAR_EOF > 'destruct.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: destruct.cl
; Description: DESTRUCTIVE benchmark from Gabriel tests
; Author: Bob Shaw, HPLabs/ATC
; Created: 8-Apr-85
; Modified: 10-Apr-85 14:54:12 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; DESTRU -- Destructive operation benchmark
(defun destructive (n m)
(declare (fixnum n m))
(let ((l (do ((i 10 (1- i))
(a nil (push nil a)))
((= i 0) a)
(declare (fixnum i)))))
(do ((i n (1- i)))
((= i 0))
(declare (fixnum i))
(cond ((null (car l))
(do ((l l (cdr l)))
((null l))
(or (car l)
(rplaca l (cons nil nil)))
(nconc (car l)
(do ((j m (1- j))
(a nil (push nil 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)
(declare (fixnum j))
(rplaca a i))
(let ((n (floor (length (car l1)) 2)))
(declare (fixnum n))
(cond ((= n 0) (rplaca l1 nil)
(car l1))
(t
(do ((j n (1- j))
(a (car l1) (cdr a)))
((= j 1)
(prog1 (cdr a)
(rplacd a nil)))
(declare (fixnum j))
(rplaca a i))))))))))))
;;; call: (destructive 600 50)
(run-benchmark "Destructive" '(destructive 600 50))
SHAR_EOF
fi # end of overwriting check
if test -f 'div.cl'
then
echo shar: will not over-write existing file "'div.cl'"
else
cat << \SHAR_EOF > 'div.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: div.cl
; Description: DIV benchmarks
; Author: Richard Gabriel
; Created: 8-Apr-85
; Modified: 19-Jul-85 18:28:01 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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)
(do ((n n (1- n))
(a () (push () a)))
((= n 0) a)
(declare (fixnum n))))
(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))
(declare (fixnum i))
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)))
(defun test-2 (l)
(do ((i 300 (1- i)))
((= i 0))
(declare (fixnum i))
(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*)
(run-benchmark "Div-iter" '(test-1 *ll*))
(run-benchmark "Div-rec" '(test-2 *ll*))
SHAR_EOF
fi # end of overwriting check
if test -f 'fft.cl'
then
echo shar: will not over-write existing file "'fft.cl'"
else
cat << \SHAR_EOF > 'fft.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: fft.cl
; Description: FFT benchmark from the Gabriel tests.
; Author: Harry Barrow
; Created: 8-Apr-85
; Modified: 6-May-85 09:29:22 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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))
(defun fft (areal aimag)
(declare (vector areal aimag))
(prog (ar ai i j k m n le le1 ip nv2 nm1 ur ui wr wi tr ti)
(declare (vector ai ai) (fixnum i j k m n le le1 nv2 nm1))
;; initialize
(setq ar areal
ai aimag
n (array-dimension ar 0)
n (1- n)
nv2 (floor n 2)
nm1 (1- n)
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))))
;; interchange elements in bit-reversed order
(setq j 1 i 1)
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))) ;loop thru stages (syntax converted
((> l m)) ; from old MACLISP style \bs)
(declare (fixnum l))
(setq le (expt 2 l)
le1 (floor le 2)
ur 1.0
ui 0.
wr (cos (/ pi (float le1)))
wi (sin (/ pi (float le1))))
;; loop thru butterflies
(do ((j 1 (1+ j)))
((> j le1))
(declare (fixnum j))
;; do a butterfly
(do ((i j (+ i le)))
((> i n))
(declare (fixnum i))
(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)))
;;; the timer which does 10 calls on fft
(defmacro fft-bench ()
`(do ((ntimes 0 (1+ ntimes)))
((= ntimes 10))
(fft *re* *im*)))
;;; call: (fft-bench)
(run-benchmark "FFT" '(fft-bench))
SHAR_EOF
fi # end of overwriting check
if test -f 'fprint.cl'
then
echo shar: will not over-write existing file "'fprint.cl'"
else
cat << \SHAR_EOF > 'fprint.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: fprint.cl
; Description: FPRINT benchmark
; Author: Richard Gabriel
; Created: 11-Apr-85
; Modified: 9-Jul-85 21:11:33 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FPRINT -- Benchmark to print to a file.
(defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
wxyzab23 xyzabc34 \123456ab \234567bc \345678cd
\456789de \567890ef \678901fg \789012gh \890123hi))
(defun init-aux (m n atoms)
(cond ((= m 0) (pop atoms))
(t (do ((i n (- i 2))
(a ()))
((< i 1) a)
(push (pop atoms) a)
(push (init-aux (1- m) n atoms) a)))))
(defun init (m n atoms)
(let ((atoms (subst () () atoms)))
(do ((a atoms (cdr a)))
((null (cdr a)) (rplacd a atoms)))
(init-aux m n atoms)))
(defvar test-pattern (init 6 6 test-atoms))
(defun fprint ()
(if (probe-file "fprint.tst") ; seems a little wierd, later calls slower
(delete-file "fprint.tst"))
(let((stream (open "fprint.tst" :direction :output)))
(print test-pattern stream)
(close stream)))
(eval-when (compile load eval)
(if (probe-file "fprint.tst")
(delete-file "fprint.tst")))
;;; call: (fprint)
(run-benchmark "Fprint" '(fprint))
SHAR_EOF
fi # end of overwriting check
if test -f 'fread.cl'
then
echo shar: will not over-write existing file "'fread.cl'"
else
cat << \SHAR_EOF > 'fread.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: fread.cl
; Description: FREAD benchmark
; Author: Richard Gabriel
; Created: 11-Apr-85
; Modified: 11-Apr-85 20:39:09 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FREAD -- Benchmark to read from a file.
;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created
;;; by FPRINT.
(defun fread ()
(let ((stream (open "fprint.tst" :direction :input)))
(read stream)
(close stream)))
(eval-when (load eval)
(if (not (probe-file "fprint.tst"))
(format t "~%Define FPRINT.TST by running the FPRINT benchmark!")))
;;; call: (fread))
(run-benchmark "Fread" '(fread))
SHAR_EOF
fi # end of overwriting check
if test -f 'frpoly.cl'
then
echo shar: will not over-write existing file "'frpoly.cl'"
else
cat << \SHAR_EOF > 'frpoly.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: frpoly.cl
; Description: FRPOLY benchmark
; Author: Richard Gabriel and Richard Fateman
; Created: 11-Apr-85
; Modified: 9-Jul-85 16:23:18 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FRPOLY -- Benchmark from Berkeley based on polynomial arithmetic.
;;; Originally writen in Franz Lisp by Richard Fateman.
;;; PDIFFER1 appears in the code, but is not defined; is not called for in the
;;; test, however.
(defvar f)
(defvar *i*)
(defvar v)
(defvar *x*)
(defvar *alpha*)
(defvar *a*)
(defvar *b*)
(defvar u*)
(defvar *y*)
(defvar r)
(defvar r2)
(defvar r3)
(defmacro pointergp (x y) `(> (get ,x 'order) (get ,y 'order)))
(defmacro pcoefp (e) `(atom ,e))
(defmacro pzerop (x) `(if (numberp ,x) (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* v)
(setq 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 v) (> e (car v)))
(setq u* (setq v (pplus1 u* (list e c))))
(setq y (cddr y))
(go a1))
((= e (car v))
(setq c (pplus c (cadr v)))
(if (pzerop c) ; never true, evidently
(setq u* (setq v (pdiffer1 u* (list (car v) (cadr v)))))
(rplaca (cdr v) c))
(setq y (cddr y))
(go a1)))
a (cond ((and (cddr v) (> (caddr v) e))
(setq v (cddr v))
(go a)))
(setq u (cdr 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 eval)
(setf (get 'x 'order) 1)
(setf (get 'y 'order) 2)
(setf (get 'z 'order) 3)
(setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1))) ; r= x+y+z+1
r2 (ptimes r 100000) ; r2 = 100000*r
r3 (ptimes r 1.0))) ; r3 = r in flonums
;;; four sets of three tests, call:
;;; (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2)
;;; (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5)
;;; (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10)
;;; (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15)
(run-benchmark "Frpoly Power=2 r=x+y+z+1" '(pexptsq r 2))
(run-benchmark "Frpoly Power=2 r2=1000r" '(pexptsq r2 2))
(run-benchmark "Frpoly Power=2 r3=r in flonums" '(pexptsq r3 2))
(run-benchmark "Frpoly Power=5 r=x+y+z+1" '(pexptsq r 5))
(run-benchmark "Frpoly Power=5 r2=1000r" '(pexptsq r2 5))
(run-benchmark "Frpoly Power=5 r3=r in flonums" '(pexptsq r3 5))
(run-benchmark "Frpoly Power=10 r=x+y+z+1" '(pexptsq r 10))
(run-benchmark "Frpoly Power=10 r2=1000r" '(pexptsq r2 10))
(run-benchmark "Frpoly Power=10 r3=r in flonums" '(pexptsq r3 10))
(run-benchmark "Frpoly Power=15 r=x+y+z+1" '(pexptsq r 15))
(run-benchmark "Frpoly Power=15 r2=1000r" '(pexptsq r2 15))
(run-benchmark "Frpoly Power=15 r3=r in flonums" '(pexptsq r3 15))
SHAR_EOF
fi # end of overwriting check
if test -f 'puzzle.cl'
then
echo shar: will not over-write existing file "'puzzle.cl'"
else
cat << \SHAR_EOF > 'puzzle.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: puzzle.cl
; Description: PUZZLE benchmark
; Author: Richard Gabriel, after Forrest Baskett
; Created: 12-Apr-85
; Modified: 12-Apr-85 14:20:23 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
(eval-when (compile load eval)
(defconstant size 511)
(defconstant classmax 3)
(defconstant typemax 12)
)
(defvar *iii* 0)
(defvar *kount* 0)
(defvar *d* 8)
(defvar *piececount* (make-array (1+ classmax) :initial-element 0))
(defvar *class* (make-array (1+ typemax) :initial-element 0))
(defvar *piecemax* (make-array (1+ typemax) :initial-element 0))
(defvar *puzzle* (make-array (1+ size)))
(defvar *p* (make-array (list (1+ typemax) (1+ size))))
(proclaim '(type fixnum *iii* *kount* *d*))
(proclaim '(type vector *piececount* *class* *piecemax* *puzzle*))
(defun fit (i j)
(declare (fixnum i j))
(let ((end (aref *piecemax* i)))
(do ((k 0 (1+ k)))
((> k end) t)
(declare (fixnum k))
(cond ((aref *p* i k)
(cond ((aref *puzzle* (+ j k))
(return nil))))))))
(defun place (i j)
(let ((end (aref *piecemax* i)))
(do ((k 0 (1+ k)))
((> k end))
(declare (fixnum k))
(cond ((aref *p* i k)
(setf (aref *puzzle* (+ j k)) t))))
(decf (aref *piececount* (aref *class* i)))
(do ((k j (1+ k)))
((> k size)
; (terpri)
; (princ "*Puzzle* filled")
0)
(declare (fixnum k))
(cond ((not (aref *puzzle* k))
(return k))))))
(defun puzzle-remove (i j)
(declare (fixnum i j))
(let ((end (aref *piecemax* i)))
(declare (fixnum end))
(do ((k 0 (1+ k)))
((> k end))
(declare (fixnum k))
(cond ((aref *p* i k)
(setf (aref *puzzle* (+ j k)) nil))))
(incf (aref *piececount* (aref *class* i)))))
(defun trial (j)
(declare (fixnum j))
(let ((k 0))
(declare (fixnum k))
(do ((i 0 (1+ i)))
((> i typemax) (setq *kount* (1+ *kount*)) nil)
(declare (fixnum i))
(cond ((not (= (aref *piececount* (aref *class* i)) 0))
(cond ((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 iclass ii jj kk))
(let ((index 0))
(declare (fixnum index))
(do ((i 0 (1+ i)))
((> i ii))
(declare (fixnum i))
(do ((j 0 (1+ j)))
((> j jj))
(declare (fixnum j))
(do ((k 0 (1+ k)))
((> k kk))
(declare (fixnum k))
(setq index (+ i (* *d* (+ j (* *d* k)))))
(setf (aref *p* *iii* index) t))))
(setf (aref *class* *iii*) iclass)
(setf (aref *piecemax* *iii*) index)
(cond ((not (= *iii* typemax))
(incf *iii*)))))
(defun start ()
(do ((m 0 (1+ m)))
((> m size))
(declare (fixnum m))
(setf (aref *puzzle* m) t))
(do ((i 1 (1+ i)))
((> i 5))
(declare (fixnum i))
(do ((j 1 (1+ j)))
((> j 5))
(declare (fixnum j))
(do ((k 1 (1+ k)))
((> k 5))
(declare (fixnum k))
(setf (aref *puzzle* (+ i (* *d* (+ j (* *d* k))))) nil))))
(do ((i 0 (1+ i)))
((> i typemax))
(declare (fixnum i))
(do ((m 0 (1+ m)))
((> m size))
(declare (fixnum m))
(setf (aref *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 (aref *piececount* 0) 13)
(setf (aref *piececount* 1) 3)
(setf (aref *piececount* 2) 1)
(setf (aref *piececount* 3) 1)
(let ((m (+ 1 (* *d* (1+ *d*))))
(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 ~S trials." *kount*))
(t (format t "~%Failure.")))))
;;; call: (start)
(run-benchmark "Puzzle" '(start))
SHAR_EOF
fi # end of overwriting check
if test -f 'stak.cl'
then
echo shar: will not over-write existing file "'stak.cl'"
else
cat << \SHAR_EOF > 'stak.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: stak.cl
; Description: STAK benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 09:54:50 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STAK -- The TAKeuchi function with special variables instead of parameter passing.
(defvar *x*)
(defvar *y*)
(defvar *z*)
(proclaim '(type fixnum *x* *y* *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))))
;;; call: (stak 18 12 6))
(run-benchmark "STAK" '(stak 18 12 6))
SHAR_EOF
fi # end of overwriting check
if test -f 'tak.cl'
then
echo shar: will not over-write existing file "'tak.cl'"
else
cat << \SHAR_EOF > 'tak.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: tak.cl
; Description: TAK benchmark from the Gabriel tests
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 09:58:18 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAK -- A vanilla version of the TAKeuchi function
(defun tak (x y z)
(declare (fixnum x y z))
(if (not (< y x))
z
(tak (tak (1- x) y z)
(tak (1- y) z x)
(tak (1- z) x y))))
;;; call: (tak 18 12 6)
(run-benchmark "TAK" '(tak 18 12 6))
SHAR_EOF
fi # end of overwriting check
if test -f 'takl.cl'
then
echo shar: will not over-write existing file "'takl.cl'"
else
cat << \SHAR_EOF > 'takl.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: takl.cl
; Description: TAKL benchmark from the Gabriel tests
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:07:00 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAKL -- The TAKeuchi function using lists as counters.
(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)))))
;;; call: (mas 18l 12l 6l)
(run-benchmark "TAKL" '(mas 18l 12l 6l))
SHAR_EOF
fi # end of overwriting check
if test -f 'takr.cl'
then
echo shar: will not over-write existing file "'takr.cl'"
else
cat << \SHAR_EOF > 'takr.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: takr.cl
; Description: TAKR benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:12:43 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TAKR -- 100 function (count `em) version of TAK that tries to defeat cache
;;; memory effects. Results should be the same as for TAK on stack machines.
;;; Distribution of calls is not completely flat.
(defun tak0 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak1 (tak37 (1- x) y z)
(tak11 (1- y) z x)
(tak17 (1- z) x y)))))
(defun tak1 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak2 (tak74 (1- x) y z)
(tak22 (1- y) z x)
(tak34 (1- z) x y)))))
(defun tak2 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak3 (tak11 (1- x) y z)
(tak33 (1- y) z x)
(tak51 (1- z) x y)))))
(defun tak3 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak4 (tak48 (1- x) y z)
(tak44 (1- y) z x)
(tak68 (1- z) x y)))))
(defun tak4 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak5 (tak85 (1- x) y z)
(tak55 (1- y) z x)
(tak85 (1- z) x y)))))
(defun tak5 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak6 (tak22 (1- x) y z)
(tak66 (1- y) z x)
(tak2 (1- z) x y)))))
(defun tak6 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak7 (tak59 (1- x) y z)
(tak77 (1- y) z x)
(tak19 (1- z) x y)))))
(defun tak7 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak8 (tak96 (1- x) y z)
(tak88 (1- y) z x)
(tak36 (1- z) x y)))))
(defun tak8 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak9 (tak33 (1- x) y z)
(tak99 (1- y) z x)
(tak53 (1- z) x y)))))
(defun tak9 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak10 (tak70 (1- x) y z)
(tak10 (1- y) z x)
(tak70 (1- z) x y)))))
(defun tak10 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak11 (tak7 (1- x) y z)
(tak21 (1- y) z x)
(tak87 (1- z) x y)))))
(defun tak11 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak12 (tak44 (1- x) y z)
(tak32 (1- y) z x)
(tak4 (1- z) x y)))))
(defun tak12 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak13 (tak81 (1- x) y z)
(tak43 (1- y) z x)
(tak21 (1- z) x y)))))
(defun tak13 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak14 (tak18 (1- x) y z)
(tak54 (1- y) z x)
(tak38 (1- z) x y)))))
(defun tak14 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak15 (tak55 (1- x) y z)
(tak65 (1- y) z x)
(tak55 (1- z) x y)))))
(defun tak15 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak16 (tak92 (1- x) y z)
(tak76 (1- y) z x)
(tak72 (1- z) x y)))))
(defun tak16 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak17 (tak29 (1- x) y z)
(tak87 (1- y) z x)
(tak89 (1- z) x y)))))
(defun tak17 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak18 (tak66 (1- x) y z)
(tak98 (1- y) z x)
(tak6 (1- z) x y)))))
(defun tak18 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak19 (tak3 (1- x) y z)
(tak9 (1- y) z x)
(tak23 (1- z) x y)))))
(defun tak19 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak20 (tak40 (1- x) y z)
(tak20 (1- y) z x)
(tak40 (1- z) x y)))))
(defun tak20 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak21 (tak77 (1- x) y z)
(tak31 (1- y) z x)
(tak57 (1- z) x y)))))
(defun tak21 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak22 (tak14 (1- x) y z)
(tak42 (1- y) z x)
(tak74 (1- z) x y)))))
(defun tak22 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak23 (tak51 (1- x) y z)
(tak53 (1- y) z x)
(tak91 (1- z) x y)))))
(defun tak23 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak24 (tak88 (1- x) y z)
(tak64 (1- y) z x)
(tak8 (1- z) x y)))))
(defun tak24 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak25 (tak25 (1- x) y z)
(tak75 (1- y) z x)
(tak25 (1- z) x y)))))
(defun tak25 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak26 (tak62 (1- x) y z)
(tak86 (1- y) z x)
(tak42 (1- z) x y)))))
(defun tak26 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak27 (tak99 (1- x) y z)
(tak97 (1- y) z x)
(tak59 (1- z) x y)))))
(defun tak27 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak28 (tak36 (1- x) y z)
(tak8 (1- y) z x)
(tak76 (1- z) x y)))))
(defun tak28 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak29 (tak73 (1- x) y z)
(tak19 (1- y) z x)
(tak93 (1- z) x y)))))
(defun tak29 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak30 (tak10 (1- x) y z)
(tak30 (1- y) z x)
(tak10 (1- z) x y)))))
(defun tak30 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak31 (tak47 (1- x) y z)
(tak41 (1- y) z x)
(tak27 (1- z) x y)))))
(defun tak31 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak32 (tak84 (1- x) y z)
(tak52 (1- y) z x)
(tak44 (1- z) x y)))))
(defun tak32 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak33 (tak21 (1- x) y z)
(tak63 (1- y) z x)
(tak61 (1- z) x y)))))
(defun tak33 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak34 (tak58 (1- x) y z)
(tak74 (1- y) z x)
(tak78 (1- z) x y)))))
(defun tak34 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak35 (tak95 (1- x) y z)
(tak85 (1- y) z x)
(tak95 (1- z) x y)))))
(defun tak35 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak36 (tak32 (1- x) y z)
(tak96 (1- y) z x)
(tak12 (1- z) x y)))))
(defun tak36 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak37 (tak69 (1- x) y z)
(tak7 (1- y) z x)
(tak29 (1- z) x y)))))
(defun tak37 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak38 (tak6 (1- x) y z)
(tak18 (1- y) z x)
(tak46 (1- z) x y)))))
(defun tak38 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak39 (tak43 (1- x) y z)
(tak29 (1- y) z x)
(tak63 (1- z) x y)))))
(defun tak39 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak40 (tak80 (1- x) y z)
(tak40 (1- y) z x)
(tak80 (1- z) x y)))))
(defun tak40 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak41 (tak17 (1- x) y z)
(tak51 (1- y) z x)
(tak97 (1- z) x y)))))
(defun tak41 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak42 (tak54 (1- x) y z)
(tak62 (1- y) z x)
(tak14 (1- z) x y)))))
(defun tak42 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak43 (tak91 (1- x) y z)
(tak73 (1- y) z x)
(tak31 (1- z) x y)))))
(defun tak43 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak44 (tak28 (1- x) y z)
(tak84 (1- y) z x)
(tak48 (1- z) x y)))))
(defun tak44 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak45 (tak65 (1- x) y z)
(tak95 (1- y) z x)
(tak65 (1- z) x y)))))
(defun tak45 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak46 (tak2 (1- x) y z)
(tak6 (1- y) z x)
(tak82 (1- z) x y)))))
(defun tak46 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak47 (tak39 (1- x) y z)
(tak17 (1- y) z x)
(tak99 (1- z) x y)))))
(defun tak47 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak48 (tak76 (1- x) y z)
(tak28 (1- y) z x)
(tak16 (1- z) x y)))))
(defun tak48 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak49 (tak13 (1- x) y z)
(tak39 (1- y) z x)
(tak33 (1- z) x y)))))
(defun tak49 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak50 (tak50 (1- x) y z)
(tak50 (1- y) z x)
(tak50 (1- z) x y)))))
(defun tak50 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak51 (tak87 (1- x) y z)
(tak61 (1- y) z x)
(tak67 (1- z) x y)))))
(defun tak51 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak52 (tak24 (1- x) y z)
(tak72 (1- y) z x)
(tak84 (1- z) x y)))))
(defun tak52 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak53 (tak61 (1- x) y z)
(tak83 (1- y) z x)
(tak1 (1- z) x y)))))
(defun tak53 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak54 (tak98 (1- x) y z)
(tak94 (1- y) z x)
(tak18 (1- z) x y)))))
(defun tak54 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak55 (tak35 (1- x) y z)
(tak5 (1- y) z x)
(tak35 (1- z) x y)))))
(defun tak55 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak56 (tak72 (1- x) y z)
(tak16 (1- y) z x)
(tak52 (1- z) x y)))))
(defun tak56 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak57 (tak9 (1- x) y z)
(tak27 (1- y) z x)
(tak69 (1- z) x y)))))
(defun tak57 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak58 (tak46 (1- x) y z)
(tak38 (1- y) z x)
(tak86 (1- z) x y)))))
(defun tak58 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak59 (tak83 (1- x) y z)
(tak49 (1- y) z x)
(tak3 (1- z) x y)))))
(defun tak59 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak60 (tak20 (1- x) y z)
(tak60 (1- y) z x)
(tak20 (1- z) x y)))))
(defun tak60 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak61 (tak57 (1- x) y z)
(tak71 (1- y) z x)
(tak37 (1- z) x y)))))
(defun tak61 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak62 (tak94 (1- x) y z)
(tak82 (1- y) z x)
(tak54 (1- z) x y)))))
(defun tak62 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak63 (tak31 (1- x) y z)
(tak93 (1- y) z x)
(tak71 (1- z) x y)))))
(defun tak63 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak64 (tak68 (1- x) y z)
(tak4 (1- y) z x)
(tak88 (1- z) x y)))))
(defun tak64 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak65 (tak5 (1- x) y z)
(tak15 (1- y) z x)
(tak5 (1- z) x y)))))
(defun tak65 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak66 (tak42 (1- x) y z)
(tak26 (1- y) z x)
(tak22 (1- z) x y)))))
(defun tak66 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak67 (tak79 (1- x) y z)
(tak37 (1- y) z x)
(tak39 (1- z) x y)))))
(defun tak67 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak68 (tak16 (1- x) y z)
(tak48 (1- y) z x)
(tak56 (1- z) x y)))))
(defun tak68 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak69 (tak53 (1- x) y z)
(tak59 (1- y) z x)
(tak73 (1- z) x y)))))
(defun tak69 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak70 (tak90 (1- x) y z)
(tak70 (1- y) z x)
(tak90 (1- z) x y)))))
(defun tak70 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak71 (tak27 (1- x) y z)
(tak81 (1- y) z x)
(tak7 (1- z) x y)))))
(defun tak71 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak72 (tak64 (1- x) y z)
(tak92 (1- y) z x)
(tak24 (1- z) x y)))))
(defun tak72 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak73 (tak1 (1- x) y z)
(tak3 (1- y) z x)
(tak41 (1- z) x y)))))
(defun tak73 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak74 (tak38 (1- x) y z)
(tak14 (1- y) z x)
(tak58 (1- z) x y)))))
(defun tak74 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak75 (tak75 (1- x) y z)
(tak25 (1- y) z x)
(tak75 (1- z) x y)))))
(defun tak75 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak76 (tak12 (1- x) y z)
(tak36 (1- y) z x)
(tak92 (1- z) x y)))))
(defun tak76 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak77 (tak49 (1- x) y z)
(tak47 (1- y) z x)
(tak9 (1- z) x y)))))
(defun tak77 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak78 (tak86 (1- x) y z)
(tak58 (1- y) z x)
(tak26 (1- z) x y)))))
(defun tak78 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak79 (tak23 (1- x) y z)
(tak69 (1- y) z x)
(tak43 (1- z) x y)))))
(defun tak79 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak80 (tak60 (1- x) y z)
(tak80 (1- y) z x)
(tak60 (1- z) x y)))))
(defun tak80 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak81 (tak97 (1- x) y z)
(tak91 (1- y) z x)
(tak77 (1- z) x y)))))
(defun tak81 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak82 (tak34 (1- x) y z)
(tak2 (1- y) z x)
(tak94 (1- z) x y)))))
(defun tak82 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak83 (tak71 (1- x) y z)
(tak13 (1- y) z x)
(tak11 (1- z) x y)))))
(defun tak83 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak84 (tak8 (1- x) y z)
(tak24 (1- y) z x)
(tak28 (1- z) x y)))))
(defun tak84 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak85 (tak45 (1- x) y z)
(tak35 (1- y) z x)
(tak45 (1- z) x y)))))
(defun tak85 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak86 (tak82 (1- x) y z)
(tak46 (1- y) z x)
(tak62 (1- z) x y)))))
(defun tak86 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak87 (tak19 (1- x) y z)
(tak57 (1- y) z x)
(tak79 (1- z) x y)))))
(defun tak87 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak88 (tak56 (1- x) y z)
(tak68 (1- y) z x)
(tak96 (1- z) x y)))))
(defun tak88 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak89 (tak93 (1- x) y z)
(tak79 (1- y) z x)
(tak13 (1- z) x y)))))
(defun tak89 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak90 (tak30 (1- x) y z)
(tak90 (1- y) z x)
(tak30 (1- z) x y)))))
(defun tak90 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak91 (tak67 (1- x) y z)
(tak1 (1- y) z x)
(tak47 (1- z) x y)))))
(defun tak91 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak92 (tak4 (1- x) y z)
(tak12 (1- y) z x)
(tak64 (1- z) x y)))))
(defun tak92 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak93 (tak41 (1- x) y z)
(tak23 (1- y) z x)
(tak81 (1- z) x y)))))
(defun tak93 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak94 (tak78 (1- x) y z)
(tak34 (1- y) z x)
(tak98 (1- z) x y)))))
(defun tak94 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak95 (tak15 (1- x) y z)
(tak45 (1- y) z x)
(tak15 (1- z) x y)))))
(defun tak95 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak96 (tak52 (1- x) y z)
(tak56 (1- y) z x)
(tak32 (1- z) x y)))))
(defun tak96 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak97 (tak89 (1- x) y z)
(tak67 (1- y) z x)
(tak49 (1- z) x y)))))
(defun tak97 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak98 (tak26 (1- x) y z)
(tak78 (1- y) z x)
(tak66 (1- z) x y)))))
(defun tak98 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak99 (tak63 (1- x) y z)
(tak89 (1- y) z x)
(tak83 (1- z) x y)))))
(defun tak99 (x y z)
(declare (fixnum x y z))
(cond ((not (< y x)) z)
(t (tak0 (tak0 (1- x) y z)
(tak0 (1- y) z x)
(tak0 (1- z) x y)))))
;;; call: (tak0 18 12 6)
(run-benchmark "TAKR" '(tak0 18 12 6))
SHAR_EOF
fi # end of overwriting check
if test -f 'timer.cl'
then
echo shar: will not over-write existing file "'timer.cl'"
else
cat << \SHAR_EOF > 'timer.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: timer.cl
; Description: The timer function for Gabriel's test suite.
; Author: Robert Kessler, Will Galway and Stan Shebs
; Created: 05-Mar-84
; Modified: 16-Dec-85 (Stan Shebs)
; Mode: PCLS
; Package: User
; Status: Experimental
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Invoke this function to run a benchmark. The first argument is a string
;;; identifying the benchmark, while the second is the form to be evaluated.
(defun run-benchmark (name form)
(let ((fname (gentemp)))
(eval `(defun ,fname () ,(build-timer-function name form)))
(compile fname)
(apply fname nil)))
;;; The following function builds the body of the timer function
(defun build-timer-function (string form)
(setq string (string string))
`(progn
(format t "~%--------------------------------------------------------~%")
(format t "~A~%" ,string)
(format t "Timing performed on ~A ~A running ~A ~A on ~A.~%"
(machine-type) (machine-version)
(software-type) (software-version)
(machine-instance))
(time ,form)))
SHAR_EOF
fi # end of overwriting check
if test -f 'tprint.cl'
then
echo shar: will not over-write existing file "'tprint.cl'"
else
cat << \SHAR_EOF > 'tprint.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: tprint.cl
; Description: TPRINT benchmark from the Gabriel tests
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 19-Jul-85 19:05:26 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TPRINT -- Benchmark to print and read to the terminal.
(defvar ttest-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9
stu0 uvw1 wxy2 xyz3 \123a \234b \345c \456d
\567d \678e \789f \890g))
(defun init (m n atoms)
(let ((atoms (subst () () atoms)))
(do ((a atoms (cdr a)))
((null (cdr a)) (rplacd a atoms)))
(init-aux m n atoms)))
(defun init-aux (m n atoms)
(cond ((= m 0) (pop atoms))
(t (do ((i n (- i 2))
(a ()))
((< i 1) a)
(push (pop atoms) a)
(push (init-aux (1- m) n atoms) a)))))
(defvar ttest-pattern (init 6 6 ttest-atoms))
;;; call: (print ttest-pattern)
(run-benchmark "Tprint" '(print ttest-pattern))
SHAR_EOF
fi # end of overwriting check
if test -f 'traverse.cl'
then
echo shar: will not over-write existing file "'traverse.cl'"
else
cat << \SHAR_EOF > 'traverse.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: traverse.cl
; Description: TRAVERSE benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:24:04 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
(defstruct node
(parents nil)
(sons nil)
(sn (snb))
(entry1 nil)
(entry2 nil)
(entry3 nil)
(entry4 nil)
(entry5 nil)
(entry6 nil)
(mark nil))
(defvar *sn* 0)
(defvar *rand* 21)
(defvar *count* 0)
(defvar *marker* nil)
(defvar *root*)
(proclaim '(type fixnum *sn* *rand* *count*))
(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 nil (caar q) (rplaca q nil)))
((= n 0)
(prog2 nil (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 nil (car q) (rplacd q p)))
(declare (fixnum n))))))
(defun traverse-select (n q)
(do ((n n (1- n))
(q (car q) (cdr q)))
((= n 0) (car q))
(declare (fixnum n))))
(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 (1- n) (1- m))
(p a))
((= m 0) (setq a `(,(rplacd p a)))
(do ((unused a)
(used (add (traverse-remove 0 a) nil))
(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))) ))
(declare (fixnum m))
(push (make-node) a))))
(defun find-root (node n)
(do ((n n (1- n)))
((= n 0) node)
(declare (fixnum n))
(cond ((null (node-parents node))
(return node))
(t (setq node (car (node-parents node)))))))
(defun travers (node mark)
(cond ((eq (node-mark node) mark) nil)
(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) nil)
(travers (car sons) mark)))))
(defun traverse (root)
(let ((*count* 0))
(travers root (setq *marker* (not *marker*)))
*count*))
(defun init-traverse () ; Changed from defmacro to defun \bs
(setq *root* (create-structure 100))
nil)
(defun run-traverse () ; Changed from defmacro to defun \bs
(do ((i 50 (1- i)))
((= i 0))
(declare (fixnum i))
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)
(traverse *root*)))
;;; to initialize, call: (init-traverse)
;;; to run traverse, call: (run-traverse)
(run-benchmark "Traverse-init" '(init-traverse))
(run-benchmark "Traverse" '(run-traverse))
SHAR_EOF
fi # end of overwriting check
if test -f 'triangle.cl'
then
echo shar: will not over-write existing file "'triangle.cl'"
else
cat << \SHAR_EOF > 'triangle.cl'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; File: triangle.cl
; Description: TRIANGLE benchmark
; Author: Richard Gabriel
; Created: 12-Apr-85
; Modified: 12-Apr-85 10:30:32 (Bob Shaw)
; Language: Common Lisp
; Package: User
; Status: Public Domain
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TRIANG -- Board game benchmark.
(eval-when (compile load eval)
(defvar *board* (make-array 16 :initial-element 1))
(defvar *sequence* (make-array 14 :initial-element 0))
(defvar *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 *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 *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*)
(setf (aref *board* 5) 0)
(proclaim '(type (vector fixnum) *board* *sequence* *a* *b* *c*))
)
(defun last-position ()
(do ((i 1 (1+ i)))
((= i 16) 0)
(declare (fixnum i))
(if (= 1 (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 *sequence* 'list)) *answer*)
t)
((and (= 1 (aref *board* (aref *a* i)))
(= 1 (aref *board* (aref *b* i)))
(= 0 (aref *board* (aref *c* i))))
(setf (aref *board* (aref *a* i)) 0)
(setf (aref *board* (aref *b* i)) 0)
(setf (aref *board* (aref *c* i)) 1)
(setf (aref *sequence* depth) i)
(do ((j 0 (1+ j))
(depth (1+ depth)))
((or (= j 36) (try j depth)) nil)
(declare (fixnum j depth)))
(setf (aref *board* (aref *a* i)) 1)
(setf (aref *board* (aref *b* i)) 1)
(setf (aref *board* (aref *c* i)) 0) ())))
(defun gogogo (i)
(let ((*answer* ())
(*final* ()))
(try i 1)))
;;; call: (gogogo 22))
(run-benchmark "Triangle" '(gogogo 22))
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0
--
Mike Clarkson, ...!allegra \ BITNET: mike@YUYETTI or
CRESS, York University, ...!decvax \ SYMALG@YUSOL
4700 Keele Street, ...!ihnp4 > !utzoo!yetti!mike
North York, Ontario, ...!linus /
CANADA M3J 1P3. ...!watmath / Phone: +1 (416) 736-2100 x 7767
"...the most inevitable business communications system on the planet."
- ROLM magazine advertisement
which planet?