mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-13 04:42:13 -08:00
Removed benchmarks
This commit is contained in:
jjgarcia
parent
bbb6b6d0a3
commit
b1e54f45b2
39 changed files with 0 additions and 5022 deletions
|
|
@ -1,45 +0,0 @@
|
|||
top_srcdir=@top_srcdir@
|
||||
srcdir=@srcdir@
|
||||
|
||||
@SET_MAKE@
|
||||
LN_S = @LN_S@
|
||||
|
||||
FILES = CMUCLc ECLc CLISPc CMUCLi ECLi CLISPi
|
||||
LISP ?= ../ecl -dir `pwd`/../
|
||||
NAME ?= ECLc
|
||||
COMPILE ?= NIL
|
||||
|
||||
BENCHMARK: $(FILES)
|
||||
rm -f BENCHMARK
|
||||
(echo "(load \"$(srcdir)/test-help.lsp\")"; \
|
||||
echo "(beautify-output \"BENCHMARK\")"; \
|
||||
cat $(FILES); \
|
||||
echo "NIL";)\
|
||||
| ../ecl ; cat BENCHMARK
|
||||
|
||||
CMUCLi:
|
||||
$(MAKE) test LISP="lisp" NAME=CMUCLi COMPILE="NIL"
|
||||
CMUCLc:
|
||||
$(MAKE) test LISP="lisp" NAME=CMUCLc COMPILE="T"
|
||||
CLISPi:
|
||||
$(MAKE) test LISP="clisp -a" NAME=CLISPi COMPILE="NIL"
|
||||
CLISPc:
|
||||
$(MAKE) test LISP="clisp -a" NAME=CLISPc COMPILE="T"
|
||||
ECLi:
|
||||
$(MAKE) test NAME=ECLi COMPILE="NIL"
|
||||
ECLc: ../h/ecl.h
|
||||
$(MAKE) test NAME=ECLc COMPILE="T"
|
||||
|
||||
test:
|
||||
(echo "(load \"$(srcdir)/make-declare.lsp\")"; \
|
||||
echo "(load \"$(srcdir)/test-help.lsp\")"; \
|
||||
echo "(do-all-tests \"$(NAME)\" \"$(srcdir)/\" \""`pwd`"/\" $(COMPILE))"; \
|
||||
echo "#+(or cmu ecl) (quit)") | $(LISP)
|
||||
|
||||
../h/ecl.h:
|
||||
$(LN_S) $(top_srcdir)/h/*.h ../h
|
||||
|
||||
clean:
|
||||
rm -f $(FILES) BENCHMARK
|
||||
rm -f core *.fas *.c *.h a.out *.o *.lbin *.bin *.*fasl *~ *.lib *#
|
||||
rm -f *.x86f
|
||||
|
|
@ -1,544 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
|
||||
;;; Fairly CONS intensive.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(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 boyer-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 boyer-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 ((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)))
|
||||
|
||||
(defvar setup-performed-p (prog1 t (boyer-setup)))
|
||||
|
||||
(defun testboyer ()
|
||||
(boyer-test))
|
||||
|
|
@ -1,142 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; BROWSE -- Benchmark to create and browse through an AI-like data base
|
||||
;;; of units.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
;;; 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
|
||||
|
||||
(eval-when (eval compile)
|
||||
(defvar *browse-rand* 21)
|
||||
(proclaim '(type fixnum *browse-rand*))
|
||||
(defconstant *browse-star* (code-char 42))
|
||||
(defconstant *browse-questionmark* (code-char 63)))
|
||||
|
||||
(eval-when (eval compile)
|
||||
;; maybe SYMBOL-NAME
|
||||
(defmacro browse-char1 (x) `(schar (symbol-name ,x) 0)))
|
||||
|
||||
|
||||
(defun browse-init (n m npats ipats)
|
||||
(declare (type fixnum n m npats))
|
||||
(setq *browse-rand* 21)
|
||||
(let ((ipats (copy-tree ipats)))
|
||||
(do ((p ipats (cdr p)))
|
||||
((null (cdr p)) (rplacd p ipats)))
|
||||
(do ((n n (the fixnum (1- n)))
|
||||
(i m (cond ((= i 0) m)
|
||||
(t (the fixnum (1- i)))))
|
||||
(name (gentemp) (gentemp))
|
||||
(a ()))
|
||||
((= n 0) a)
|
||||
(declare (type fixnum n i))
|
||||
(push name a)
|
||||
(do ((i i (the fixnum (1- i))))
|
||||
((= i 0))
|
||||
(declare (type fixnum i))
|
||||
(setf (get name (gensym)) nil))
|
||||
(setf (get name 'pattern)
|
||||
(do ((i npats (the fixnum (1- i)))
|
||||
(ipats ipats (cdr ipats))
|
||||
(a ()))
|
||||
((= i 0) a)
|
||||
(declare (type fixnum i))
|
||||
(push (car ipats) a)))
|
||||
(do ((j (the fixnum (- m i)) (the fixnum (1- j))))
|
||||
((= j 0))
|
||||
(declare (type fixnum j))
|
||||
(setf (get name (gensym)) nil)))))
|
||||
|
||||
|
||||
(defun browse-random ()
|
||||
(setq *browse-rand* (rem (the fixnum (* *browse-rand* 17)) 251)))
|
||||
|
||||
(defun browse-randomize (l)
|
||||
(do ((a ()))
|
||||
((null l) a)
|
||||
(let ((n (rem (the fixnum (browse-random)) (the fixnum (length l)))))
|
||||
(declare (type fixnum n))
|
||||
(cond ((= n 0)
|
||||
(push (car l) a)
|
||||
(setq l (cdr l)))
|
||||
(t
|
||||
(do ((n n (the fixnum (1- n)))
|
||||
(x l (cdr x)))
|
||||
((= n 1)
|
||||
(push (cadr x) a)
|
||||
(rplacd x (cddr x)))
|
||||
(declare (type 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))
|
||||
;;replace eq by 'eql for char
|
||||
(cond ((eql (browse-char1 (car pat))
|
||||
*browse-questionmark*)
|
||||
(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))))))
|
||||
((eql (browse-char1 (car pat)) *browse-star*)
|
||||
(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 (browse-randomize
|
||||
(browse-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) ())))))
|
||||
|
||||
(defun testbrowse ()
|
||||
(browse))
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
gcc cc,5 cc,4
|
||||
BOYER 12.533 12.350 12.250
|
||||
BROWSE 24.517 25.083 25.067
|
||||
CTAK 6.517 7.100 7.133
|
||||
DDERIV 6.050 6.550 6.533
|
||||
DERIV 4.950 5.017 5.033
|
||||
DESTRU 2.900 3.300 3.283
|
||||
DIV2 5.533 5.600 5.583
|
||||
FFT-MOD 7.917 21.583 21.533
|
||||
FFT 59.150 65.117 64.700
|
||||
FPRINT 1.800 1.850 1.767
|
||||
FREAD 3.033 2.533 2.483
|
||||
FRPOLY 86.567 86.800 86.483
|
||||
PUZZLE-MOD 7.200 7.633 7.617
|
||||
PUZZLE 8.317 8.800 8.667
|
||||
STAK 3.733 4.217 4.200
|
||||
TAK-MOD 5.367 3.650 4.350
|
||||
TAK 6.483 5.467 5.967
|
||||
TAKL 2.617 3.167 3.117
|
||||
TAKR 1.000 0.883 1.033
|
||||
TPRINT 3.167 3.150 3.183
|
||||
TRAVERSE 38.933 39.533 39.217
|
||||
TRIANG-MOD 118.033 131.700 130.767
|
||||
TRIANG 149.267 152.517 151.400
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
|
||||
AKCL version 1.20
|
||||
LUCID version 2.1.1
|
||||
KCL is the Jun 87 version unmodified.
|
||||
|
||||
Gabriel benchmarks run on a Sun 3-160 by Bill Schelter.
|
||||
Colu
|
||||
|
||||
Thu Apr 7 10:47:59 CDT 1988
|
||||
|
||||
HARDWARE: Sun280 Sun280 Sun3-160 Sun3-160 Sun3-160
|
||||
SOFTWARE: AKCL LUCID AKCL LUCID KCL
|
||||
|
||||
BOYER 6.667 6.533 9.200 12.200 15.160 15.950
|
||||
BROWSE 12.900 13.433 18.500 24.183 29.560 41.283
|
||||
CTAK 3.500 3.000 1.140 6.583 2.160 7.050
|
||||
DDERIV 3.317 3.317 5.420 6.033 9.260 8.417
|
||||
DERIV 2.633 2.700 5.240 4.850 8.200 6.450
|
||||
DESTRU-MOD 1.000 1.090
|
||||
DESTRU 1.350 1.667 1.080 2.883 1.720 3.717
|
||||
DIV2 3.117 3.100 4.380 5.433 6.660 5.667
|
||||
FFT-MOD 5.350 5.317 38.360 7.700 51.880 29.467
|
||||
FFT 32.150 32.317 34.760 58.450 51.840 (error)
|
||||
FPRINT 0.667 1.033 0.800 1.817 1.460 2.417
|
||||
FREAD 1.212 1.333 1.670 2.500 3.220 2.783
|
||||
FRPOLY 46.883 46.033 30.040 85.450 45.200 90.167
|
||||
PUZZLE-MOD 4.383 4.350 4.380 7.117 6.960 10.183
|
||||
PUZZLE 4.833 4.900 3.180 8.200 5.140 11.183
|
||||
STAK 1.813 1.817 1.380 3.717 2.620 4.350
|
||||
TAK-MOD 2.900 2.900 2.800 5.150 4.680 3.600
|
||||
TAK 3.833 3.750 2.760 6.467 4.900 5.767
|
||||
TAKL 1.350 1.583 1.680 2.600 2.640 3.017
|
||||
TAKR 0.521 0.533 0.460 0.933 0.840 1.483
|
||||
TPRINT 1.046 1.650 2.100 3.117 3.680 4.233
|
||||
TRAVERSE 25.667 25.833 27.940 38.917 40.060 71.133
|
||||
TRIANG-MOD 63.500 62.217 255.460 112.750 453.460 160.783
|
||||
TRIANG 78.017 77.450 76.760 147.567 141.62 220.917
|
||||
|
||||
|
||||
Additional notes: All files were proclaimed using the proclaim-file
|
||||
facility in make-declare.lsp. The XX-MOD tests, differ from the
|
||||
original XX tests only in the matter of additional proclamations and
|
||||
perhaps changing an array type. This sometimes hurt lucid, mainly
|
||||
because the original declarations were optimal for lucid. (Also in
|
||||
several places we changed an eq of integers or characters to an eql,
|
||||
to conform with correct Common Lisp, and ensure that the test would
|
||||
actually run as intended.) In AKCL three of the four float types map
|
||||
to 64 bit floats, with only short-float being a 32 bit float. On
|
||||
lucid all four appear to be 32 bit (judging from the fact that 1.0e38
|
||||
is the largest float in each case). Thus KCL and AKCL are using 64
|
||||
bit floats in the fft examples, while lucid appears to be using 32 bit
|
||||
floats. We did not know what switches to use to speed lucid floating
|
||||
arithmetic.
|
||||
|
||||
|
||||
To run the tests in a lisp called foo (eg akcl, lucid,..)
|
||||
% cd gabriel
|
||||
% make -e "LISP=foo" >> #errs &
|
||||
The times will be recorded in a file called times. All files
|
||||
will be proclaimed, and compiled automatically.
|
||||
|
||||
|
||||
|
|
@ -1,146 +0,0 @@
|
|||
;; $Header$
|
||||
;;
|
||||
;; benchmark control
|
||||
|
||||
(setf (comp:target-fpp) :m68881)
|
||||
(setq comp::*target-architecture* :mc68020)
|
||||
(setf (sys:gsgc-parameter :generation-spread) 4)
|
||||
|
||||
(require :foreign)
|
||||
(use-package :ff)
|
||||
(load "time.o")
|
||||
|
||||
(defforeign 'get_time
|
||||
:entry-point (convert-to-lang "get_time" :language :c)
|
||||
:arguments '(t))
|
||||
|
||||
(import '(lisp::time-utime-sec lisp::time-utime-usec lisp::time-stime-sec
|
||||
lisp::time-stime-usec lisp::time-stime-minflt
|
||||
lisp::time-stime-majflt lisp::time-stime-maxrss
|
||||
lisp::time-real-sec lisp::time-real-usec))
|
||||
|
||||
(defcstruct time
|
||||
(utime-sec :unsigned-long)
|
||||
(utime-usec :unsigned-long)
|
||||
(stime-sec :unsigned-long)
|
||||
(stime-usec :unsigned-long)
|
||||
(stime-minflt :unsigned-long)
|
||||
(stime-majflt :unsigned-long)
|
||||
(stime-maxrss :unsigned-long)
|
||||
(real-sec :unsigned-long)
|
||||
(real-usec :unsigned-long))
|
||||
|
||||
(defmacro bm-time-macro (form)
|
||||
`(let ((start (make-time)) (end (make-time)))
|
||||
(get_time start)
|
||||
(multiple-value-prog1 ,form
|
||||
(get_time end)
|
||||
(print-time start end))))
|
||||
|
||||
(defun print-time (start end)
|
||||
(let* ((u1 (truncate (+ (* 1000000 (time-utime-sec start))
|
||||
(time-utime-usec start))
|
||||
1000))
|
||||
(s1 (truncate (+ (* 1000000 (time-stime-sec start))
|
||||
(time-stime-usec start))
|
||||
1000))
|
||||
(u2 (truncate (+ (* 1000000 (time-utime-sec end))
|
||||
(time-utime-usec end))
|
||||
1000))
|
||||
(s2 (truncate (+ (* 1000000 (time-stime-sec end))
|
||||
(time-stime-usec end))
|
||||
1000))
|
||||
(r1 (truncate (+ (* 1000000 (time-real-sec start))
|
||||
(time-real-usec start))
|
||||
1000))
|
||||
(r2 (truncate (+ (* 1000000 (time-real-sec end))
|
||||
(time-real-usec end))
|
||||
1000))
|
||||
(page-faults (- (+ (time-stime-majflt end)
|
||||
(time-stime-minflt end))
|
||||
(+ (time-stime-minflt start)
|
||||
(time-stime-majflt start))))
|
||||
(real (- r2 r1))
|
||||
(user (- u2 u1))
|
||||
(system (- s2 s1)))
|
||||
(format *trace-output*
|
||||
"
|
||||
(~10:<~d~> ;; non-gc user
|
||||
~10:<~d~> ;; non-gc system
|
||||
~10:<~d~> ;; gc user
|
||||
~10:<~d~> ;; gc system
|
||||
~10:<~d~> ;; total user
|
||||
~10:<~d~> ;; total gc
|
||||
~10:<~d~> ;; real
|
||||
~10:<~d~> ;; max rss size (pages)
|
||||
~10:<~d~> ;; page faults
|
||||
)"
|
||||
user system 0 0 user 0 real
|
||||
(time-stime-maxrss end) page-faults)))
|
||||
|
||||
(defparameter *benches*
|
||||
'(boyer
|
||||
browse
|
||||
ctak
|
||||
dderiv
|
||||
deriv
|
||||
destru
|
||||
(div2 div2-iter div2-recur)
|
||||
fft
|
||||
fprint
|
||||
fread
|
||||
(frpoly frpoly-1 frpoly-2 frpoly-3 frpoly-4)
|
||||
puzzle
|
||||
stak
|
||||
tak
|
||||
takl
|
||||
takr
|
||||
tprint
|
||||
(traverse traverse-init traverse-run)
|
||||
triang))
|
||||
|
||||
(defun compile-all-bms (&optional (result-file "results.compile"))
|
||||
(let ((old-time (macro-function 'time)))
|
||||
(setf (macro-function 'time) (macro-function 'bm-time-macro))
|
||||
(let ((*trace-output*
|
||||
(open result-file :direction :output :if-exists :supersede)))
|
||||
(format *trace-output* "(:benchmark-compilation~%")
|
||||
(gc :tenure)
|
||||
(bm-time-macro
|
||||
(dolist (bench *benches*)
|
||||
(if (consp bench) (setq bench (car bench)))
|
||||
(setq bench (string-downcase (string bench)))
|
||||
(compile-file (merge-pathnames (make-pathname :type "cl") bench))))
|
||||
(format *trace-output* ")~%")
|
||||
(close *trace-output*))
|
||||
(setf (macro-function 'time) old-time)
|
||||
nil))
|
||||
|
||||
(defun run-all-bms (&optional (result-file "results.run"))
|
||||
(let ((*trace-output*
|
||||
(open result-file :direction :output :if-exists :append)))
|
||||
(dolist (bench *benches*)
|
||||
(run-bench bench))
|
||||
(close *trace-output*)))
|
||||
|
||||
(defun run-bench (bench &aux name function)
|
||||
(cond
|
||||
((consp bench)
|
||||
;; the form of bench is
|
||||
;; (file name1 name2 ...)
|
||||
(load (string-downcase (symbol-name (car bench))))
|
||||
(dolist (name (cdr bench))
|
||||
(run-bench-1 name (find-symbol (format nil "~a~a" 'test name)))))
|
||||
(t (load (string-downcase (symbol-name bench)))
|
||||
(run-bench-1 bench (find-symbol (format nil "~a~a" 'test bench))))))
|
||||
|
||||
(defun run-bench-1 (bench function)
|
||||
(format *trace-output* "~%(:~a~%" bench)
|
||||
(dotimes (n 3)
|
||||
(gc :tenure)
|
||||
(funcall function))
|
||||
(format *trace-output* ")~%")
|
||||
(force-output *trace-output*))
|
||||
|
||||
(defun run-benches (&rest bench-list)
|
||||
(mapc #'(lambda (bench) (apply #'run-bench bench)) bench-list))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(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))
|
||||
(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 testctak ()
|
||||
(ctak 18 12 6))
|
||||
|
|
@ -1,71 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; 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:
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
;;; :property keyword is not Common Lisp.
|
||||
|
||||
(defun dderiv-aux (a)
|
||||
(list '// (dderiv a) a))
|
||||
|
||||
(defun +dderiv (a)
|
||||
(cons '+ (mapcar 'dderiv a)))
|
||||
|
||||
(defun -dderiv (a)
|
||||
(cons '- (mapcar 'dderiv a)))
|
||||
|
||||
(defun *dderiv (a)
|
||||
(list '* (cons '* a)
|
||||
(cons '+ (mapcar 'dderiv-aux a))))
|
||||
|
||||
(defun //dderiv (a)
|
||||
(list '-
|
||||
(list '//
|
||||
(dderiv (car a))
|
||||
(cadr a))
|
||||
(list '//
|
||||
(car a)
|
||||
(list '*
|
||||
(cadr a)
|
||||
(cadr a)
|
||||
(dderiv (cadr a))))))
|
||||
|
||||
(mapc #'(lambda (op fun) (setf (get op 'dderiv) (symbol-function fun)))
|
||||
'(+ - * //)
|
||||
'(+dderiv -dderiv *dderiv //dderiv))
|
||||
|
||||
(defun dderiv (a)
|
||||
(cond
|
||||
((atom a)
|
||||
(cond ((eq a 'x) 1) (t 0)))
|
||||
(t (let ((dderiv (get (car a) 'dderiv)))
|
||||
(cond (dderiv (funcall dderiv (cdr a)))
|
||||
(t 'error))))))
|
||||
|
||||
(defun dderiv-run ()
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((= (the fixnum i) 1000.))
|
||||
(declare (type 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))))
|
||||
|
||||
(defun testdderiv ()
|
||||
(dderiv-run))
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; DERIV -- Symbolic derivative benchmark written by Vaughn Pratt.
|
||||
;;; It uses a simple subset of Lisp and does a lot of CONSing.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(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 (the fixnum (1+ i))))
|
||||
((= (the fixnum i) 1000.)) ;runs it 5000 times
|
||||
(declare (type fixnum i)) ;improves the code a little
|
||||
(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))))
|
||||
|
||||
(defun testderiv ()
|
||||
(deriv-run))
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;; DESTRU -- Destructive operation benchmark
|
||||
|
||||
;;mod: add fixnum declaration for n in the following let:
|
||||
;; (let ((n (floor (the fixnum (length (car l1))) 2)))
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defun destructive (n m)
|
||||
(declare (type fixnum n m))
|
||||
(let ((l (do ((i 10. (the fixnum (1- i)))
|
||||
(a () (push () a)))
|
||||
((= (the fixnum i) 0) a)
|
||||
(declare (type fixnum i)))))
|
||||
(do ((i n (the fixnum (1- i))))
|
||||
((= (the fixnum i) 0))
|
||||
(declare (type fixnum i))
|
||||
(cond ((null (car l))
|
||||
(do ((l l (cdr l)))
|
||||
((null l))
|
||||
(or (car l)
|
||||
(rplaca l (cons () ())))
|
||||
(nconc (car l)
|
||||
(do ((j m (the fixnum (1- j)))
|
||||
(a () (push () a)))
|
||||
((= (the fixnum j) 0) a)
|
||||
(declare (type fixnum j))))))
|
||||
(t
|
||||
(do ((l1 l (cdr l1))
|
||||
(l2 (cdr l) (cdr l2)))
|
||||
((null l2))
|
||||
(rplacd (do ((j (floor (the fixnum (length (car l2))) 2)
|
||||
(the fixnum (1- j)))
|
||||
(a (car l2) (cdr a)))
|
||||
((zerop (the fixnum j)) a)
|
||||
(declare (type fixnum j))
|
||||
(rplaca a i))
|
||||
(let ((n (floor (the fixnum (length (car l1))) 2)))
|
||||
(declare (fixnum n))
|
||||
(cond ((= (the fixnum n) 0) (rplaca l1 ())
|
||||
(car l1))
|
||||
(t
|
||||
(do ((j n (the fixnum (1- j)))
|
||||
(a (car l1) (cdr a)))
|
||||
((= (the fixnum j) 1)
|
||||
(prog1 (cdr a)
|
||||
(rplacd a ())))
|
||||
(declare (type fixnum j))
|
||||
(rplaca a i))))))))))))
|
||||
|
||||
(defun testdestru ()
|
||||
(destructive 600 50))
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;; DESTRU -- Destructive operation benchmark
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defun destructive (n m)
|
||||
(declare (type fixnum n m))
|
||||
(let ((l (do ((i 10. (the fixnum (1- i)))
|
||||
(a () (push () a)))
|
||||
((= (the fixnum i) 0) a)
|
||||
(declare (type fixnum i)))))
|
||||
(do ((i n (the fixnum (1- i))))
|
||||
((= (the fixnum i) 0))
|
||||
(declare (type fixnum i))
|
||||
(cond ((null (car l))
|
||||
(do ((l l (cdr l)))
|
||||
((null l))
|
||||
(or (car l)
|
||||
(rplaca l (cons () ())))
|
||||
(nconc (car l)
|
||||
(do ((j m (the fixnum (1- j)))
|
||||
(a () (push () a)))
|
||||
((= (the fixnum j) 0) a)
|
||||
(declare (type fixnum j))))))
|
||||
(t
|
||||
(do ((l1 l (cdr l1))
|
||||
(l2 (cdr l) (cdr l2)))
|
||||
((null l2))
|
||||
(rplacd (do ((j (floor (the fixnum (length (car l2))) 2)
|
||||
(the fixnum (1- j)))
|
||||
(a (car l2) (cdr a)))
|
||||
((zerop (the fixnum j)) a)
|
||||
(declare (type fixnum j))
|
||||
(rplaca a i))
|
||||
(let ((n (floor (the fixnum (length (car l1))) 2)))
|
||||
(cond ((= (the fixnum n) 0) (rplaca l1 ())
|
||||
(car l1))
|
||||
(t
|
||||
(do ((j n (the fixnum (1- j)))
|
||||
(a (car l1) (cdr a)))
|
||||
((= (the fixnum j) 1)
|
||||
(prog1 (cdr a)
|
||||
(rplacd a ())))
|
||||
(declare (type fixnum j))
|
||||
(rplaca a i))))))))))))
|
||||
|
||||
(defun testdestru ()
|
||||
(destructive 600 50))
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; DIV2 -- Benchmark which divides by 2 using lists of n ()'s.
|
||||
;;; This file contains a recursive as well as an iterative test.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defun create-n (n)
|
||||
(declare (type fixnum n))
|
||||
(do ((n n (the fixnum (1- n)))
|
||||
(a () (push () a)))
|
||||
((= (the fixnum n) 0) a)
|
||||
(declare (type 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 (the fixnum (1- i))))
|
||||
((= (the fixnum i) 0))
|
||||
(declare (type fixnum i))
|
||||
(iterative-div2 l)
|
||||
(iterative-div2 l)
|
||||
(iterative-div2 l)
|
||||
(iterative-div2 l)))
|
||||
|
||||
(defun test-2 (l)
|
||||
(do ((i 300 (the fixnum (1- i))))
|
||||
((= (the fixnum i) 0))
|
||||
(declare (type fixnum i))
|
||||
(recursive-div2 l)
|
||||
(recursive-div2 l)
|
||||
(recursive-div2 l)
|
||||
(recursive-div2 l)))
|
||||
|
||||
(defun testdiv2 ()
|
||||
(testdiv2-iter)
|
||||
(testdiv2-recur))
|
||||
|
||||
(defun testdiv2-iter ()
|
||||
(test-1 ll))
|
||||
|
||||
(defun testdiv2-recur ()
|
||||
(test-2 ll))
|
||||
|
|
@ -1,146 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;; FFT -- This is an FFT benchmark written by Harry Barrow.
|
||||
;; It tests a variety of floating point operations, including array references.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar **fft-re**
|
||||
(make-array 1025. :element-type
|
||||
#+excl 'single-float #+lucid 'float #+KCL 'single-float
|
||||
#+ecl 'single-float #+clisp 'single-float #+cmu 'single-float
|
||||
:initial-element 0.0))
|
||||
|
||||
(defvar **fft-im**
|
||||
(make-array 1025. :element-type
|
||||
#+excl 'single-float #+lucid 'single-float #+KCL 'single-float
|
||||
#+ecl 'single-float #+clisp 'single-float #+cmu 'single-float
|
||||
:initial-element 0.0))
|
||||
|
||||
(defmacro ff+ (a b)
|
||||
`(the single-float (+ (the single-float ,a) (the single-float ,b))))
|
||||
|
||||
(defmacro ff*(a b)
|
||||
`(the single-float (* (the single-float ,a) (the single-float ,b))))
|
||||
(defmacro ff-(a b)
|
||||
`(the single-float (- (the single-float ,a) (the single-float ,b))))
|
||||
|
||||
|
||||
(proclaim '(type (#+KCL vector #-KCL simple-array
|
||||
#+excl single-float #+lucid single-float #+KCL single-float
|
||||
#+ecl single-float
|
||||
#-KCL (*)) **fft-re** **fft-im**))
|
||||
|
||||
(defvar s-pi (float pi 0.0))
|
||||
(proclaim '(#+excl single-float #+KCL single-float #+lucid single-float #+ecl single-float s-pi))
|
||||
|
||||
(defun fft (areal aimag)
|
||||
(declare (type (simple-array single-float (*)) areal aimag))
|
||||
(prog* ((ar areal)
|
||||
(ai aimag)
|
||||
(i 1)
|
||||
(j 0)
|
||||
(k 0)
|
||||
(m 0) ;compute m = log(n)
|
||||
(n (1- (array-dimension ar 0)))
|
||||
(nv2 (floor n 2))
|
||||
(le 0) (le1 0) (ip 0)
|
||||
(ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0))
|
||||
(declare (type fixnum i j k n nv2 m le le1 ip))
|
||||
(declare (type (simple-array single-float (*)) ar ai))
|
||||
(declare (single-float ur ui wr wi tr ti))
|
||||
l1 (cond ((< i n)
|
||||
(setq m (the fixnum (1+ m))
|
||||
i (the fixnum (+ i i)))
|
||||
(go l1)))
|
||||
(cond ((not (equal n (the fixnum (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 (the fixnum (- j k))
|
||||
k (the fixnum (/ k 2)))
|
||||
(go l6)))
|
||||
(setq j (the fixnum (+ j k))
|
||||
i (the fixnum (1+ i)))
|
||||
(cond ((< i n)
|
||||
(go l3)))
|
||||
(do ((l 1 (the fixnum (1+ (the fixnum l)))))
|
||||
((> (the fixnum l) m)) ;loop thru stages
|
||||
(declare (type fixnum l))
|
||||
(setq le (the fixnum (expt 2 l))
|
||||
le1 (the (values fixnum fixnum) (floor le 2))
|
||||
ur 1.0
|
||||
ui 0.0
|
||||
wr (cos (/ s-pi (float le1)))
|
||||
wi (sin (/ s-pi (float le1))))
|
||||
(do ((j 1 (the fixnum (1+ (the fixnum j)))))
|
||||
((> (the fixnum j) le1)) ;loop thru butterflies
|
||||
(declare (type fixnum j))
|
||||
(do ((i j (+ (the fixnum i) le)))
|
||||
((> (the fixnum i) n)) ;do a butterfly
|
||||
(declare (type fixnum i))
|
||||
(setq ip (the fixnum (+ i le1))
|
||||
tr (ff- (ff* (aref ar ip) ur)
|
||||
(ff* (aref ai ip) ui))
|
||||
ti (ff+ (ff* (aref ar ip) ui)
|
||||
(ff* (aref ai ip) ur)))
|
||||
(setf (aref ar ip) (ff- (aref ar i) tr))
|
||||
(setf (aref ai ip) (ff- (aref ai i) ti))
|
||||
(setf (aref ar i) (ff+ (aref ar i) tr))
|
||||
(setf (aref ai i) (ff+ (aref ai i) ti))))
|
||||
(setq tr (ff- (ff* ur wr) (ff* ui wi))
|
||||
ti (ff+ (ff* ur wi) (ff* ui wr))
|
||||
ur tr
|
||||
ui ti))
|
||||
(return t)))
|
||||
|
||||
(defun fft-bench ()
|
||||
(dotimes (i 10)
|
||||
(fft **fft-re** **fft-im**)))
|
||||
|
||||
(defun testfft ()
|
||||
(fft-bench))
|
||||
|
||||
|
||||
;;;
|
||||
;;; the following are for verifying that the implementation gives the
|
||||
;;; correct result
|
||||
;;;
|
||||
|
||||
(defun clear-fft ()
|
||||
(dotimes (i 1025)
|
||||
(setf (aref **fft-re** i) 0.0
|
||||
(aref **fft-im** i) 0.0))
|
||||
(values))
|
||||
|
||||
(defun setup-fft-component (theta &optional (phase 0.0))
|
||||
(let ((f (f* 2 pi theta))
|
||||
(c (cos (f* 0.5 pi phase)))
|
||||
(s (sin (f* 0.5 pi phase))))
|
||||
(dotimes (i 1025)
|
||||
(let ((x (sin (* f (/ i 1024.0)))))
|
||||
(incf (aref **fft-re** i) (float (* c x) 0.0))
|
||||
(incf (aref **fft-im** i) (float (* s x) 0.0)))))
|
||||
(values))
|
||||
|
||||
(defvar fft-delta 0.0001)
|
||||
|
||||
(defun print-fft ()
|
||||
(dotimes (i 1025)
|
||||
(let ((re (aref **fft-re** i))
|
||||
(im (aref **fft-im** i)))
|
||||
(unless (and (< (abs re) fft-delta) (< (abs im) fft-delta))
|
||||
(format t "~4d ~10f ~10f~%" i re im))))
|
||||
(values))
|
||||
|
|
@ -1,136 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;; FFT -- This is an FFT benchmark written by Harry Barrow.
|
||||
;; It tests a variety of floating point operations, including array references.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar **fft-re**
|
||||
(make-array 1025. :element-type
|
||||
#+excl 'single-float #+lucid 'float #+KCL 'single-float
|
||||
#+ecl 'single-float #+clisp 'single-float #+cmu 'single-float
|
||||
:initial-element 0.0))
|
||||
|
||||
(defvar **fft-im**
|
||||
(make-array 1025. :element-type
|
||||
#+excl 'single-float #+lucid 'single-float #+KCL 'single-float
|
||||
#+ecl 'single-float #+clisp 'single-float #+cmu 'single-float
|
||||
:initial-element 0.0))
|
||||
|
||||
(proclaim '(type (#+KCL vector #-KCL simple-array
|
||||
#+excl single-float #+lucid single-float #+KCL single-float #+ecl single-float
|
||||
#-KCL (*)) **fft-re** **fft-im**))
|
||||
|
||||
(defvar s-pi (float pi 0.0))
|
||||
(proclaim '(#+excl single-float #+ecl single-float #+KCL single-float #+lucid single-float #+ecl single-float s-pi))
|
||||
|
||||
(defun fft (areal aimag)
|
||||
(declare (type (simple-array single-float (*)) areal aimag))
|
||||
(prog* ((ar areal)
|
||||
(ai aimag)
|
||||
(i 1)
|
||||
(j 0)
|
||||
(k 0)
|
||||
(m 0) ;compute m = log(n)
|
||||
(n (1- (array-dimension ar 0)))
|
||||
(nv2 (floor n 2))
|
||||
(le 0) (le1 0) (ip 0)
|
||||
(ur 0.0) (ui 0.0) (wr 0.0) (wi 0.0) (tr 0.0) (ti 0.0))
|
||||
(declare (type fixnum i j k n nv2 m le le1 ip))
|
||||
(declare (type (simple-array single-float (*)) ar ai))
|
||||
(declare (single-float ur ui wr wi tr ti))
|
||||
l1 (cond ((< i n)
|
||||
(setq m (the fixnum (1+ m))
|
||||
i (the fixnum (+ i i)))
|
||||
(go l1)))
|
||||
(cond ((not (equal n (the fixnum (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 (the fixnum (- j k))
|
||||
k (the fixnum (/ k 2)))
|
||||
(go l6)))
|
||||
(setq j (the fixnum (+ j k))
|
||||
i (the fixnum (1+ i)))
|
||||
(cond ((< i n)
|
||||
(go l3)))
|
||||
(do ((l 1 (the fixnum (1+ (the fixnum l)))))
|
||||
((> (the fixnum l) m)) ;loop thru stages
|
||||
(declare (type fixnum l))
|
||||
(setq le (the fixnum (expt 2 l))
|
||||
le1 (the (values fixnum fixnum) (floor le 2))
|
||||
ur 1.0
|
||||
ui 0.0
|
||||
wr (cos (/ s-pi (float le1)))
|
||||
wi (sin (/ s-pi (float le1))))
|
||||
(do ((j 1 (the fixnum (1+ (the fixnum j)))))
|
||||
((> (the fixnum j) le1)) ;loop thru butterflies
|
||||
(declare (type fixnum j))
|
||||
(do ((i j (+ (the fixnum i) le)))
|
||||
((> (the fixnum i) n)) ;do a butterfly
|
||||
(declare (type fixnum i))
|
||||
(setq ip (the fixnum (+ 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 fft-bench ()
|
||||
(dotimes (i 10)
|
||||
(fft **fft-re** **fft-im**)))
|
||||
|
||||
(defun testfft ()
|
||||
(fft-bench))
|
||||
|
||||
|
||||
;;;
|
||||
;;; the following are for verifying that the implementation gives the
|
||||
;;; correct result
|
||||
;;;
|
||||
|
||||
(defun clear-fft ()
|
||||
(dotimes (i 1025)
|
||||
(setf (aref **fft-re** i) 0.0
|
||||
(aref **fft-im** i) 0.0))
|
||||
(values))
|
||||
|
||||
(defun setup-fft-component (theta &optional (phase 0.0))
|
||||
(let ((f (* 2 pi theta))
|
||||
(c (cos (* 0.5 pi phase)))
|
||||
(s (sin (* 0.5 pi phase))))
|
||||
(dotimes (i 1025)
|
||||
(let ((x (sin (* f (/ i 1024.0)))))
|
||||
(incf (aref **fft-re** i) (float (* c x) 0.0))
|
||||
(incf (aref **fft-im** i) (float (* s x) 0.0)))))
|
||||
(values))
|
||||
|
||||
(defvar fft-delta 0.0001)
|
||||
|
||||
(defun print-fft ()
|
||||
(dotimes (i 1025)
|
||||
(let ((re (aref **fft-re** i))
|
||||
(im (aref **fft-im** i)))
|
||||
(unless (and (< (abs re) fft-delta) (< (abs im) fft-delta))
|
||||
(format t "~4d ~10f ~10f~%" i re im))))
|
||||
(values))
|
||||
|
|
@ -1,39 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; FPRINT -- Benchmark to print to a file.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(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)
|
||||
(declare (fixnum m n))
|
||||
(cond ((= m 0) (pop atoms))
|
||||
(t (do ((i n (the fixnum (- i 2)))
|
||||
(a ()))
|
||||
((< i 1) a)
|
||||
(declare (fixnum i))
|
||||
(push (pop atoms) a)
|
||||
(push (init-aux (the fixnum (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)))
|
||||
(init-aux m n atoms)))
|
||||
|
||||
(defvar test-pattern (fprint-init 6. 6. test-atoms))
|
||||
|
||||
(defun fprint ()
|
||||
(if (probe-file "/tmp/fprint.tst")
|
||||
(delete-file "/tmp/fprint.tst"))
|
||||
(let ((stream (open "/tmp/fprint.tst" :direction :output)))
|
||||
(print test-pattern stream)
|
||||
(close stream)))
|
||||
|
||||
(defun testfprint ()
|
||||
(fprint))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; FREAD -- Benchmark to read from a file.
|
||||
;;; Pronounced "FRED". Requires the existance of FPRINT.TST which is created
|
||||
;;; by FPRINT.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defun fread ()
|
||||
(let ((stream (open "/tmp/fprint.tst" :direction :input)))
|
||||
(read stream)
|
||||
(close stream)))
|
||||
|
||||
(defun testfread ()
|
||||
(fread))
|
||||
|
|
@ -1,247 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;; 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 this
|
||||
;; test, however.
|
||||
|
||||
;;
|
||||
;; This contain 2 fixes from Gabriel's book.
|
||||
;;
|
||||
;; "ptimes3": after label 'b', change the "if" to a "cond".
|
||||
;; The "go" should be activated when the condition
|
||||
;; holds, NOT when it fails.
|
||||
;;
|
||||
;; The variables *x*, u*, and v are used specially, since this is
|
||||
;; used to handle polynomial coefficients in a recursive
|
||||
;; way. Declaring them global is the wrong approach.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar ans)
|
||||
(defvar coef)
|
||||
(defvar f)
|
||||
(defvar inc)
|
||||
(defvar i)
|
||||
(defvar qq)
|
||||
(defvar ss)
|
||||
(defvar v)
|
||||
(defvar *x*)
|
||||
(defvar *alpha*)
|
||||
(defvar *a*)
|
||||
(defvar *b*)
|
||||
(defvar *chk)
|
||||
(defvar *l)
|
||||
(defvar *p)
|
||||
(defvar q*)
|
||||
(defvar u*)
|
||||
(defvar *var)
|
||||
(defvar *y*)
|
||||
(defvar r)
|
||||
(defvar r2)
|
||||
(defvar r3)
|
||||
(defvar start)
|
||||
(defvar res1)
|
||||
(defvar res2)
|
||||
(defvar res3)
|
||||
|
||||
;(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
|
||||
(defmacro valget (x) `(the fixnum (symbol-value ,x)))
|
||||
(defmacro pointergp (x y) `(> (valget ,x) (valget ,y)))
|
||||
(defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y))))
|
||||
(defmacro f> (x y) `(> (the fixnum ,x) (the fixnum ,y)))
|
||||
|
||||
(defmacro pcoefp (e) `(atom ,e))
|
||||
|
||||
(defmacro pzerop (x)
|
||||
`(and (not (consp ,x))
|
||||
(if (typep ,x 'fixnum) (eql 0 (the fixnum ,x))
|
||||
(if (typep ,x 'float) (= 0.0 (the float ,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 (f+ (car *x*) (car y))
|
||||
c (ptimes (cadr y) (cadr *x*) ))
|
||||
(cond ((pzerop c)
|
||||
(setq y (cddr y))
|
||||
(go a1))
|
||||
((or (null v) (f> 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 (cond ((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 (f+ (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 (valget 'x ) 1)
|
||||
(setf (valget 'y) 2)
|
||||
(setf (valget 'z ) 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 with floating point coefficients
|
||||
|
||||
|
||||
(defun standard-frpoly-test1 ()
|
||||
(progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil))
|
||||
|
||||
(defun standard-frpoly-test2 ()
|
||||
(progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil))
|
||||
|
||||
(defun standard-frpoly-test3 ()
|
||||
(progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil))
|
||||
|
||||
(defun standard-frpoly-test4 ()
|
||||
(progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil))
|
||||
|
||||
(defun testfrpoly ()
|
||||
(testfrpoly-1)
|
||||
(testfrpoly-2)
|
||||
(testfrpoly-3)
|
||||
(testfrpoly-4))
|
||||
|
||||
(defun testfrpoly-1 ()
|
||||
(print (time (standard-frpoly-test1))))
|
||||
|
||||
(defun testfrpoly-2 ()
|
||||
(print (time (standard-frpoly-test2))))
|
||||
|
||||
(defun testfrpoly-3 ()
|
||||
(print (time (standard-frpoly-test3))))
|
||||
|
||||
(defun testfrpoly-4 ()
|
||||
(print (time (standard-frpoly-test4))))
|
||||
|
|
@ -1,240 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;; 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 this
|
||||
;; test, however.
|
||||
|
||||
;;
|
||||
;; This contain 2 fixes from Gabriel's book.
|
||||
;;
|
||||
;; "ptimes3": after label 'b', change the "if" to a "cond".
|
||||
;; The "go" should be activated when the condition
|
||||
;; holds, NOT when it fails.
|
||||
;;
|
||||
;; The variables *x*, u*, and v are used specially, since this is
|
||||
;; used to handle polynomial coefficients in a recursive
|
||||
;; way. Declaring them global is the wrong approach.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar ans)
|
||||
(defvar coef)
|
||||
(defvar f)
|
||||
(defvar inc)
|
||||
(defvar i)
|
||||
(defvar qq)
|
||||
(defvar ss)
|
||||
(defvar v)
|
||||
(defvar *x*)
|
||||
(defvar *alpha*)
|
||||
(defvar *a*)
|
||||
(defvar *b*)
|
||||
(defvar *chk)
|
||||
(defvar *l)
|
||||
(defvar *p)
|
||||
(defvar q*)
|
||||
(defvar u*)
|
||||
(defvar *var)
|
||||
(defvar *y*)
|
||||
(defvar r)
|
||||
(defvar r2)
|
||||
(defvar r3)
|
||||
(defvar start)
|
||||
(defvar res1)
|
||||
(defvar res2)
|
||||
(defvar res3)
|
||||
|
||||
(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* 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 (cond ((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 with floating point coefficients
|
||||
|
||||
|
||||
(defun standard-frpoly-test1 ()
|
||||
(progn (pexptsq r 2) (pexptsq r2 2) (pexptsq r3 2) nil))
|
||||
|
||||
(defun standard-frpoly-test2 ()
|
||||
(progn (pexptsq r 5) (pexptsq r2 5) (pexptsq r3 5) nil))
|
||||
|
||||
(defun standard-frpoly-test3 ()
|
||||
(progn (pexptsq r 10) (pexptsq r2 10) (pexptsq r3 10) nil))
|
||||
|
||||
(defun standard-frpoly-test4 ()
|
||||
(progn (pexptsq r 15) (pexptsq r2 15) (pexptsq r3 15) nil))
|
||||
|
||||
(defun testfrpoly ()
|
||||
(testfrpoly-1)
|
||||
(testfrpoly-2)
|
||||
(testfrpoly-3)
|
||||
(testfrpoly-4))
|
||||
|
||||
(defun testfrpoly-1 ()
|
||||
(standard-frpoly-test1))
|
||||
|
||||
(defun testfrpoly-2 ()
|
||||
(standard-frpoly-test2))
|
||||
|
||||
(defun testfrpoly-3 ()
|
||||
(standard-frpoly-test3))
|
||||
|
||||
(defun testfrpoly-4 ()
|
||||
(standard-frpoly-test4))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
#-boehm-gc
|
||||
(allocate 'cons 2000 t)
|
||||
#-ecl
|
||||
(allocate 'fixnum 200 t)
|
||||
;;so that the lisps do the same thing.
|
||||
(setq *print-pretty* nil)
|
||||
#+(and ecl (not boehm-gc))
|
||||
(setq si:*gc-verbose* nil)
|
||||
;;If running this on a machine without a floating point chip delete this
|
||||
#+nil
|
||||
(when (and (boundp 'compiler::*cc*)
|
||||
(search "gcc" compiler::*cc*)
|
||||
(search "msoft-float" compiler::*cc*))
|
||||
(setq compiler::*cc* "gcc -DVOL=volatile ")
|
||||
; (setq compiler::*register-min* 100000) (setq compiler::*cc* "cc -f68881 -DVOL= ") (print "using cc")
|
||||
)
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
|
||||
(defun pi-inv (bits &aux (m 0))
|
||||
(declare (integer bits m))
|
||||
(let* ((n (+ bits (integer-length bits) 11))
|
||||
(tt (truncate (ash 1 n) 882))
|
||||
(d (* 4 882 882))
|
||||
(s 0))
|
||||
(declare (integer s d tt n))
|
||||
; (print (list n tt d s))
|
||||
(do ((i 2 (+ i 2))
|
||||
(j 1123 (+ j 21460)))
|
||||
((zerop tt) (cons s (- (+ n 2))))
|
||||
(declare (integer i j))
|
||||
(setq s (+ s (* j tt))
|
||||
m (- (* (- i 1) (- (* 2 i) 1) (- (* 2 i) 3)))
|
||||
tt (truncate (* m tt) (* d (the integer (expt i 3))))))))
|
||||
|
||||
(defun dvide (x y n)
|
||||
(let* ((ew (+ (integer-length (car y)) (- (integer-length (car x))) n 1))
|
||||
(mw (truncate (ash (car x) ew) (car y)))
|
||||
(ew (- (cdr x) (cdr y) ew)))
|
||||
(cons mw ew)))
|
||||
|
||||
(defun pi (bits) (dvide (cons 1 0) (pi-inv bits) bits))
|
||||
|
||||
(defun test-float (x) (scale-float (coerce (car x) 'long-float) (cdr x)))
|
||||
|
||||
(defun factorial (n)
|
||||
(declare (fixnum n))
|
||||
(do ((i 1 (+ i 1))
|
||||
(ans 1 (* i ans)))
|
||||
((> i n) ans)
|
||||
(declare (fixnum i ) (integer ans))))
|
||||
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
;; By W. Schelter
|
||||
;; Usage: (proclaim-file "foo.lsp") (compile-file "foo.lsp")
|
||||
|
||||
;; You may wish to adjust the following to output the proclamations
|
||||
;; for inclusion in a file. All fixed arg functions should be proclaimed
|
||||
;; before their references for maximum efficiency.
|
||||
|
||||
;; CAVEAT: The following code only checks for fixed args, it does
|
||||
;; not check for single valuedness BUT does make a proclamation
|
||||
;; to that efect. Unfortunately it is impossible to tell about
|
||||
;; multiple values without doing a full compiler type pass over
|
||||
;; all files in the relevant system. However the AKCL compiler should
|
||||
;; warn if you inadvertantly proclaim foo to be single valued and then try
|
||||
;; to use more than one value.
|
||||
|
||||
(DEFVAR *DECLARE-T-ONLY* NIL)
|
||||
(DEFUN PROCLAIM-FILE (NAME &OPTIONAL *DECLARE-T-ONLY*)
|
||||
(WITH-OPEN-FILE
|
||||
(FILE NAME
|
||||
:DIRECTION :INPUT)
|
||||
(LET ((EOF (CONS NIL NIL)))
|
||||
(LOOP
|
||||
(LET ((FORM (READ FILE NIL EOF)))
|
||||
(COND ((EQ EOF FORM) (RETURN NIL))
|
||||
((MAKE-DECLARE-FORM FORM ))))))))
|
||||
|
||||
(DEFUN MAKE-DECLARE-FORM (FORM)
|
||||
; !!!
|
||||
(WHEN
|
||||
(LISTP FORM)
|
||||
(COND ((MEMBER (CAR FORM) '(EVAL-WHEN ))
|
||||
(DOLIST (V (CDDR FORM)) (MAKE-DECLARE-FORM V)))
|
||||
((MEMBER (CAR FORM) '(PROGN ))
|
||||
(DOLIST (V (CDR FORM)) (MAKE-DECLARE-FORM V)))
|
||||
((MEMBER (CAR FORM) '(IN-PACKAGE DEFCONSTANT))
|
||||
(EVAL FORM))
|
||||
((MEMBER (CAR FORM) '(DEFUN))
|
||||
(COND
|
||||
((AND
|
||||
(CONSP (CADDR FORM))
|
||||
(NOT (MEMBER '&REST (CADDR FORM)))
|
||||
(NOT (MEMBER '&BODY (CADDR FORM)))
|
||||
(NOT (MEMBER '&KEY (CADDR FORM)))
|
||||
(NOT (MEMBER '&OPTIONAL (CADDR FORM))))
|
||||
;;could print declarations here.
|
||||
(print (list (cadr form) (ARG-DECLARES (THIRD FORM) (cdddr FORM))))
|
||||
(FUNCALL 'PROCLAIM
|
||||
(LIST 'FUNCTION
|
||||
(CADR FORM)
|
||||
(ARG-DECLARES (THIRD FORM) (cdddr FORM))
|
||||
T))))))))
|
||||
|
||||
(DEFUN ARG-DECLARES (ARGS DECLS &AUX ANS)
|
||||
(COND ((STRINGP (CAR DECLS)) (SETQ DECLS (CADR DECLS)))
|
||||
(T (SETQ DECLS (CAR DECLS))))
|
||||
(COND ((AND (not *declare-t-only*)
|
||||
(CONSP DECLS) (EQ (CAR DECLS ) 'DECLARE))
|
||||
(DO ((V ARGS (CDR V)))
|
||||
((OR (EQ (CAR V) '&AUX)
|
||||
(NULL V))
|
||||
(NREVERSE ANS))
|
||||
(PUSH (DECL-TYPE (CAR V) DECLS) ANS)))
|
||||
(T (MAKE-LIST (- (LENGTH args)
|
||||
(LENGTH (MEMBER '&AUX args)))
|
||||
:INITIAL-ELEMENT T))))
|
||||
|
||||
(DEFUN DECL-TYPE (V DECLS)
|
||||
(DOLIST (D (CDR DECLS))
|
||||
(CASE (CAR D)
|
||||
(TYPE (IF (MEMBER V (CDDR D))
|
||||
(RETURN-FROM DECL-TYPE (SECOND D))))
|
||||
((FIXNUM CHARACTER FLOAT LONG-FLOAT SHORT-FLOAT )
|
||||
(IF (MEMBER V (CDR D)) (RETURN-FROM DECL-TYPE (CAR D))))))
|
||||
T)
|
||||
|
||||
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
FILES= boyer browse ctak dderiv deriv destru-mod destru div2 fft-mod \
|
||||
fft fprint fread frpoly puzzle-mod puzzle stak \
|
||||
tak-mod tak takl takr tprint traverse triang-mod triang
|
||||
|
||||
REPEAT ?= 1
|
||||
LISP ?= ecl
|
||||
RESULTS ?= times
|
||||
|
||||
all:
|
||||
make compile
|
||||
@ echo >> $(RESULTS)
|
||||
@ echo "-------------- SESSION ------------------" >> $(RESULTS)
|
||||
@ echo >> $(RESULTS)
|
||||
@ echo " " For $(LISP) Common Lisp >> $(RESULTS)
|
||||
@ date >> $(RESULTS)
|
||||
make -i test
|
||||
|
||||
compile:
|
||||
for v in $(FILES) ; do \
|
||||
echo "(load \"make-declare.lsp\")(si::proclaim-file \"$$v.cl\")" \
|
||||
"(compile-file \"$$v.cl\")" | $(LISP) ; done
|
||||
|
||||
|
||||
test:
|
||||
for v in $(FILES) ; do \
|
||||
echo "(load \"test-help.lsp\")(do-test \"$$v\" \"$(RESULTS)\")" \
|
||||
| $(LISP); \
|
||||
done
|
||||
|
||||
clean:
|
||||
rm -f core *.data *.c a.out *.o *.lbin *.bin *.*fasl *~ *.x86f *.fas *.lib *#
|
||||
|
||||
|
|
@ -1,184 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defconstant puzzle-size 511.)
|
||||
(defconstant puzzle-classmax 3.)
|
||||
(defconstant puzzle-typemax 12.))
|
||||
|
||||
(defvar **iii** 0)
|
||||
(defvar **kount** 0)
|
||||
(defvar puzzle-d 8.)
|
||||
|
||||
(defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar puzzle (make-array (1+ puzzle-size)))
|
||||
(defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size))))
|
||||
|
||||
(defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i))))
|
||||
|
||||
(eval-when (eval compile)
|
||||
(proclaim '(type fixnum **iii** **kount** puzzle-d))
|
||||
(proclaim '(type (array fixnum) piececount puzzle-class piecemax))
|
||||
(proclaim '(type simple-vector puzzle))
|
||||
(proclaim '(simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size)) puzzle-p)))
|
||||
|
||||
(defun fit (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (fref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end) t)
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(cond ((aref puzzle (the fixnum (+ j k)))
|
||||
(return nil))))))))
|
||||
|
||||
(declaim (function place (fixnum fixnum) fixnum))
|
||||
(defun jil () 3)
|
||||
(defun place (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (fref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) t))))
|
||||
(setf (fref piececount (fref puzzle-class i))
|
||||
(the fixnum
|
||||
(- (the fixnum
|
||||
(fref piececount (fref puzzle-class i))) 1)))
|
||||
(do ((k j (the fixnum (1+ k))))
|
||||
((> k puzzle-size)
|
||||
(terpri)
|
||||
(princ "Puzzle filled")
|
||||
0)
|
||||
(declare (type fixnum k))
|
||||
(cond ((not (aref puzzle k))
|
||||
(return k))))))
|
||||
|
||||
|
||||
(defun puzzle-remove (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (fref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) nil))))
|
||||
(setf (fref piececount (fref puzzle-class i))
|
||||
(the fixnum
|
||||
(+ (the fixnum (fref piececount (fref puzzle-class i))) 1)))))
|
||||
|
||||
(defun trial (j)
|
||||
(declare (type fixnum j))
|
||||
(let ((k 0))
|
||||
(declare (type fixnum k))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax)
|
||||
(setq **kount** (the fixnum (1+ **kount**))) nil)
|
||||
(declare (type fixnum i))
|
||||
(cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0))
|
||||
(cond ((fit i j)
|
||||
(setq k (place i j))
|
||||
(cond ((or (trial k)
|
||||
(= k 0))
|
||||
(setq **kount** (the fixnum (+ **kount** 1)))
|
||||
(return t))
|
||||
(t (puzzle-remove i j))))))))))
|
||||
|
||||
(defun definepiece (iclass ii jj kk)
|
||||
(declare (type fixnum ii jj kk))
|
||||
(let ((index 0))
|
||||
(declare (type fixnum index))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i ii))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 0 (the fixnum (1+ j))))
|
||||
((> j jj))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k kk))
|
||||
(declare (type fixnum k))
|
||||
(setq index
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
(setf (aref puzzle-p **iii** index) t))))
|
||||
(setf (fref puzzle-class **iii**) iclass)
|
||||
(setf (fref piecemax **iii**) index)
|
||||
(cond ((not (= **iii** puzzle-typemax))
|
||||
(setq **iii** (the fixnum (+ **iii** 1)))))))
|
||||
|
||||
(defun puzzle-start ()
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(setf (aref puzzle m) t))
|
||||
(do ((i 1 (the fixnum (1+ i))))
|
||||
((> i 5))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 1 (the fixnum (1+ j))))
|
||||
((> j 5))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 1 (the fixnum (1+ k))))
|
||||
((> k 5))
|
||||
(declare (type fixnum k))
|
||||
(setf (aref puzzle
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
nil))))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax))
|
||||
(declare (type fixnum i))
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(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 (fref piececount 0) 13.)
|
||||
(setf (fref piececount 1) 3)
|
||||
(setf (fref piececount 2) 1)
|
||||
(setf (fref piececount 3) 1)
|
||||
(let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d))))))
|
||||
(n 0)(**kount** 0))
|
||||
(declare (type fixnum m n **kount**))
|
||||
(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.")))))
|
||||
|
||||
(defun testpuzzle ()
|
||||
(puzzle-start))
|
||||
|
|
@ -1,190 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defconstant puzzle-size 511.)
|
||||
(defconstant puzzle-classmax 3.)
|
||||
(defconstant puzzle-typemax 12.))
|
||||
|
||||
(defvar **iii** 0)
|
||||
(defvar **kount** 0)
|
||||
(defvar puzzle-d 8.)
|
||||
(proclaim '(type fixnum **iii** **kount** puzzle-d))
|
||||
|
||||
(defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar puzzle (make-array (1+ puzzle-size)))
|
||||
(defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size))))
|
||||
|
||||
(proclaim '(type (array fixnum) piececount puzzle-class piecemax))
|
||||
(defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i))))
|
||||
|
||||
|
||||
(proclaim '(type simple-vector puzzle))
|
||||
|
||||
(proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size)))
|
||||
puzzle-p))
|
||||
|
||||
(defun fit (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (fref piecemax i))
|
||||
(puzzle-pl puzzle-p))
|
||||
(declare (type fixnum end)
|
||||
(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size)))
|
||||
puzzle-pl)
|
||||
)
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end) t)
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-pl i k)
|
||||
(cond ((aref puzzle (the fixnum (+ j k)))
|
||||
(return nil))))))))
|
||||
|
||||
(proclaim '(function place (fixnum fixnum ) fixnum))
|
||||
|
||||
(defun place (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (fref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) t))))
|
||||
(setf (fref piececount (fref puzzle-class i))
|
||||
(the fixnum
|
||||
(- (the fixnum
|
||||
(fref piececount (fref puzzle-class i))) 1)))
|
||||
(do ((k j (the fixnum (1+ k))))
|
||||
((> k puzzle-size)
|
||||
(terpri)
|
||||
(princ "Puzzle filled")
|
||||
0)
|
||||
(declare (type fixnum k))
|
||||
(cond ((not (aref puzzle k))
|
||||
(return k))))))
|
||||
|
||||
|
||||
(defun puzzle-remove (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (fref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) nil))))
|
||||
(setf (fref piececount (fref puzzle-class i))
|
||||
(the fixnum
|
||||
(+ (the fixnum (fref piececount (fref puzzle-class i))) 1)))))
|
||||
|
||||
(defun trial (j)
|
||||
(declare (type fixnum j))
|
||||
(let ((k 0))
|
||||
(declare (type fixnum k))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax)
|
||||
(setq **kount** (the fixnum (1+ **kount**))) nil)
|
||||
(declare (type fixnum i))
|
||||
(cond ((not (= (the fixnum (fref piececount (fref puzzle-class i))) 0))
|
||||
(cond ((fit i j)
|
||||
(setq k (place i j))
|
||||
(cond ((or (trial k)
|
||||
(= k 0))
|
||||
(setq **kount** (the fixnum (+ **kount** 1)))
|
||||
(return t))
|
||||
(t (puzzle-remove i j))))))))))
|
||||
|
||||
(defun definepiece (iclass ii jj kk)
|
||||
(declare (type fixnum ii jj kk))
|
||||
(let ((index 0))
|
||||
(declare (type fixnum index))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i ii))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 0 (the fixnum (1+ j))))
|
||||
((> j jj))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k kk))
|
||||
(declare (type fixnum k))
|
||||
(setq index
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
(setf (aref puzzle-p **iii** index) t))))
|
||||
(setf (fref puzzle-class **iii**) iclass)
|
||||
(setf (fref piecemax **iii**) index)
|
||||
(cond ((not (= **iii** puzzle-typemax))
|
||||
(setq **iii** (the fixnum (+ **iii** 1)))))))
|
||||
|
||||
(defun puzzle-start ()
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(setf (aref puzzle m) t))
|
||||
(do ((i 1 (the fixnum (1+ i))))
|
||||
((> i 5))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 1 (the fixnum (1+ j))))
|
||||
((> j 5))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 1 (the fixnum (1+ k))))
|
||||
((> k 5))
|
||||
(declare (type fixnum k))
|
||||
(setf (aref puzzle
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
nil))))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax))
|
||||
(declare (type fixnum i))
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(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 (fref piececount 0) 13.)
|
||||
(setf (fref piececount 1) 3)
|
||||
(setf (fref piececount 2) 1)
|
||||
(setf (fref piececount 3) 1)
|
||||
(let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d))))))
|
||||
(n 0)(**kount** 0))
|
||||
(declare (type fixnum m n **kount**))
|
||||
(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.")))))
|
||||
|
||||
(defun testpuzzle ()
|
||||
(time (puzzle-start)))
|
||||
|
|
@ -1,186 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defconstant puzzle-size 511.)
|
||||
(defconstant puzzle-classmax 3.)
|
||||
(defconstant puzzle-typemax 12.))
|
||||
|
||||
(defvar **iii** 0)
|
||||
(defvar **kount** 0)
|
||||
(defvar puzzle-d 8.)
|
||||
|
||||
(defvar piececount (make-array (1+ puzzle-classmax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar puzzle-class (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar piecemax (make-array (1+ puzzle-typemax) :element-type 'fixnum :initial-element 0))
|
||||
(defvar puzzle (make-array (1+ puzzle-size)))
|
||||
(defvar puzzle-p (make-array (list (1+ puzzle-typemax) (1+ puzzle-size))))
|
||||
|
||||
(defmacro fref (a i) `(the fixnum (aref ,a (the fixnum ,i))))
|
||||
|
||||
(eval-when (eval compile)
|
||||
(proclaim '(type fixnum **iii** **kount** puzzle-d))
|
||||
(proclaim '(type (array fixnum) piececount puzzle-class piecemax))
|
||||
(proclaim '(type simple-vector puzzle))
|
||||
(proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size)))
|
||||
puzzle-p)))
|
||||
|
||||
(defun fit (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (aref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end) t)
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(cond ((aref puzzle (the fixnum (+ j k)))
|
||||
(return nil))))))))
|
||||
|
||||
(declaim (function place (fixnum fixnum ) fixnum))
|
||||
(declaim (function puzzle-remove (fixnum fixnum) fixnum))
|
||||
(defun jil () 3)
|
||||
(defun place (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (aref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) t))))
|
||||
(setf (aref piececount (aref puzzle-class i))
|
||||
(the fixnum
|
||||
(- (the fixnum
|
||||
(aref piececount (aref puzzle-class i))) 1)))
|
||||
(do ((k j (the fixnum (1+ k))))
|
||||
((> k puzzle-size)
|
||||
(terpri)
|
||||
(princ "Puzzle filled")
|
||||
0)
|
||||
(declare (type fixnum k))
|
||||
(cond ((not (aref puzzle k))
|
||||
(return k))))))
|
||||
|
||||
|
||||
(defun puzzle-remove (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (aref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) nil))))
|
||||
(setf (aref piececount (aref puzzle-class i))
|
||||
(the fixnum
|
||||
(+ (the fixnum (aref piececount (aref puzzle-class i))) 1)))))
|
||||
|
||||
(defun trial (j)
|
||||
(declare (type fixnum j))
|
||||
(let ((k 0))
|
||||
(declare (type fixnum k))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax)
|
||||
(setq **kount** (the fixnum (1+ **kount**))) nil)
|
||||
(declare (type fixnum i))
|
||||
(cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0))
|
||||
(cond ((fit i j)
|
||||
(setq k (place i j))
|
||||
(cond ((or (trial k)
|
||||
(= k 0))
|
||||
(setq **kount** (the fixnum (+ **kount** 1)))
|
||||
(return t))
|
||||
(t (puzzle-remove i j))))))))))
|
||||
|
||||
(defun definepiece (iclass ii jj kk)
|
||||
(declare (type fixnum ii jj kk))
|
||||
(let ((index 0))
|
||||
(declare (type fixnum index))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i ii))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 0 (the fixnum (1+ j))))
|
||||
((> j jj))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k kk))
|
||||
(declare (type fixnum k))
|
||||
(setq index
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
(setf (aref puzzle-p **iii** index) t))))
|
||||
(setf (aref puzzle-class **iii**) iclass)
|
||||
(setf (aref piecemax **iii**) index)
|
||||
(cond ((not (= **iii** puzzle-typemax))
|
||||
(setq **iii** (the fixnum (+ **iii** 1)))))))
|
||||
|
||||
(defun puzzle-start ()
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(setf (aref puzzle m) t))
|
||||
(do ((i 1 (the fixnum (1+ i))))
|
||||
((> i 5))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 1 (the fixnum (1+ j))))
|
||||
((> j 5))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 1 (the fixnum (1+ k))))
|
||||
((> k 5))
|
||||
(declare (type fixnum k))
|
||||
(setf (aref puzzle
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
nil))))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax))
|
||||
(declare (type fixnum i))
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(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 (aref piececount 0) 13.)
|
||||
(setf (aref piececount 1) 3)
|
||||
(setf (aref piececount 2) 1)
|
||||
(setf (aref piececount 3) 1)
|
||||
(let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d))))))
|
||||
(n 0)(**kount** 0))
|
||||
(declare (type fixnum m n **kount**))
|
||||
(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.")))))
|
||||
|
||||
(defun testpuzzle ()
|
||||
(puzzle-start))
|
||||
|
|
@ -1,178 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defconstant puzzle-size 511.)
|
||||
(defconstant puzzle-classmax 3.)
|
||||
(defconstant puzzle-typemax 12.))
|
||||
|
||||
(defvar **iii** 0)
|
||||
(defvar **kount** 0)
|
||||
(defvar puzzle-d 8.)
|
||||
(defvar piececount (make-array (1+ puzzle-classmax) :initial-element 0))
|
||||
(defvar puzzle-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))))
|
||||
|
||||
(eval-when (eval compile)
|
||||
(proclaim '(type fixnum **iii** **kount** puzzle-d))
|
||||
(proclaim '(type simple-vector piececount puzzle-class piecemax puzzle))
|
||||
(proclaim '(type (simple-array t (#.(1+ puzzle-typemax) #.(1+ puzzle-size)))
|
||||
puzzle-p)))
|
||||
|
||||
(defun fit (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (aref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end) t)
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(cond ((aref puzzle (the fixnum (+ j k)))
|
||||
(return nil))))))))
|
||||
|
||||
(defun place (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (aref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) t))))
|
||||
(setf (aref piececount (aref puzzle-class i))
|
||||
(the fixnum
|
||||
(- (the fixnum
|
||||
(aref piececount (aref puzzle-class i))) 1)))
|
||||
(do ((k j (the fixnum (1+ k))))
|
||||
((> k puzzle-size)
|
||||
(terpri)
|
||||
(princ "Puzzle filled")
|
||||
0)
|
||||
(declare (type fixnum k))
|
||||
(cond ((not (aref puzzle k))
|
||||
(return k))))))
|
||||
|
||||
|
||||
(defun puzzle-remove (i j)
|
||||
(declare (type fixnum i j))
|
||||
(let ((end (aref piecemax i)))
|
||||
(declare (type fixnum end))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k end))
|
||||
(declare (type fixnum k))
|
||||
(cond ((aref puzzle-p i k)
|
||||
(setf (aref puzzle (the fixnum (+ j k))) nil))))
|
||||
(setf (aref piececount (aref puzzle-class i))
|
||||
(+ (the fixnum (aref piececount (aref puzzle-class i))) 1))))
|
||||
|
||||
(defun trial (j)
|
||||
(declare (type fixnum j))
|
||||
(let ((k 0))
|
||||
(declare (type fixnum k))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax)
|
||||
(setq **kount** (the fixnum (1+ **kount**))) nil)
|
||||
(declare (type fixnum i))
|
||||
(cond ((not (= (the fixnum (aref piececount (aref puzzle-class i))) 0))
|
||||
(cond ((fit i j)
|
||||
(setq k (place i j))
|
||||
(cond ((or (trial k)
|
||||
(= k 0))
|
||||
(setq **kount** (the fixnum (+ **kount** 1)))
|
||||
(return t))
|
||||
(t (puzzle-remove i j))))))))))
|
||||
|
||||
(defun definepiece (iclass ii jj kk)
|
||||
(declare (type fixnum ii jj kk))
|
||||
(let ((index 0))
|
||||
(declare (type fixnum index))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i ii))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 0 (the fixnum (1+ j))))
|
||||
((> j jj))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 0 (the fixnum (1+ k))))
|
||||
((> k kk))
|
||||
(declare (type fixnum k))
|
||||
(setq index
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
(setf (aref puzzle-p **iii** index) t))))
|
||||
(setf (aref puzzle-class **iii**) iclass)
|
||||
(setf (aref piecemax **iii**) index)
|
||||
(cond ((not (= **iii** puzzle-typemax))
|
||||
(setq **iii** (the fixnum (+ **iii** 1)))))))
|
||||
|
||||
(defun puzzle-start ()
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(setf (aref puzzle m) t))
|
||||
(do ((i 1 (the fixnum (1+ i))))
|
||||
((> i 5))
|
||||
(declare (type fixnum i))
|
||||
(do ((j 1 (the fixnum (1+ j))))
|
||||
((> j 5))
|
||||
(declare (type fixnum j))
|
||||
(do ((k 1 (the fixnum (1+ k))))
|
||||
((> k 5))
|
||||
(declare (type fixnum k))
|
||||
(setf (aref puzzle
|
||||
(+ i
|
||||
(the fixnum
|
||||
(* puzzle-d
|
||||
(the fixnum
|
||||
(+ j
|
||||
(the fixnum
|
||||
(* puzzle-d k))))))))
|
||||
nil))))
|
||||
(do ((i 0 (the fixnum (1+ i))))
|
||||
((> i puzzle-typemax))
|
||||
(declare (type fixnum i))
|
||||
(do ((m 0 (the fixnum (1+ m))))
|
||||
((> m puzzle-size))
|
||||
(declare (type fixnum m))
|
||||
(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 (aref piececount 0) 13.)
|
||||
(setf (aref piececount 1) 3)
|
||||
(setf (aref piececount 2) 1)
|
||||
(setf (aref piececount 3) 1)
|
||||
(let ((m (+ 1 (the fixnum (* puzzle-d (the fixnum (+ 1 puzzle-d))))))
|
||||
(n 0)(**kount** 0))
|
||||
(declare (type fixnum m n **kount**))
|
||||
(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.")))))
|
||||
|
||||
(defun testpuzzle ()
|
||||
(puzzle-start))
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
I added some more optimizers to fix things I noticed--wfs.
|
||||
|
||||
|
||||
browse.cl Errors in code: There was an eq char compare test which
|
||||
should have been eql for common lisp. Corrected this.
|
||||
|
||||
akcl run time : 25.500 secs
|
||||
with
|
||||
(allocate-relocatable-pages 70)
|
||||
(allocate 'cons 1300 t)
|
||||
(allocate 'symbol 200 t)
|
||||
Lucid time 27 seconds (about 4 meg of space allocated).
|
||||
|
||||
-----------------
|
||||
|
||||
|
||||
traverse init
|
||||
run time : 4.200 secs
|
||||
traverse run
|
||||
run time : 34.950 secs
|
||||
|
||||
lucid:
|
||||
Total cpu time = 4460 milliseconds
|
||||
Total cpu time = 34920 milliseconds
|
||||
|
||||
|
||||
-------------------------
|
||||
|
||||
|
||||
deriv
|
||||
|
||||
For lucid:
|
||||
(time (dotimes (i 5) (testderiv)))
|
||||
Total cpu time = 35480 milliseconds
|
||||
|
||||
kcl:
|
||||
(allocate 'cons 2000 t)
|
||||
(time (dotimes (i 5) (testderiv)))
|
||||
run time : 33.167 secs
|
||||
I did at the start which seemed to be roughly
|
||||
what lucid was grabbing. It gc'd several times in both implementations.
|
||||
|
||||
ps:
|
||||
run time : 49.300 secs instead of 33.2 secs. in the old akcl.
|
||||
|
||||
|
||||
------------------
|
||||
|
||||
I changed the fixnum declarations for the three arrays a b c,
|
||||
and the function try. These actually slowed lucid down,
|
||||
so we include the times for lucid using its own declarations.
|
||||
|
||||
triang-mod.cl
|
||||
|
||||
kcl: run time : 137.850 secs
|
||||
on triang.cl
|
||||
lucid: Total cpu time = 136940 milliseconds
|
||||
On triang-mod.cl
|
||||
lucid: Total cpu time = 258900 milliseconds
|
||||
|
||||
(kcl using the lucid declarations was around 234. seconds I think)
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; STAK -- The TAKeuchi function with special variables instead of
|
||||
;;; parameter passing.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar stak-x)
|
||||
(defvar stak-y)
|
||||
(defvar stak-z)
|
||||
(declaim (fixnum stak-x stak-y stak-z))
|
||||
|
||||
(defun stak (stak-x stak-y stak-z)
|
||||
(stak-aux))
|
||||
|
||||
(defun stak-aux ()
|
||||
(if (not (< stak-y stak-x))
|
||||
stak-z
|
||||
(let ((stak-x (let ((stak-x (the fixnum (1- stak-x)))
|
||||
(stak-y stak-y)
|
||||
(stak-z stak-z))
|
||||
(stak-aux)))
|
||||
(stak-y (let ((stak-x (the fixnum (1- stak-y)))
|
||||
(stak-y stak-z)
|
||||
(stak-z stak-x))
|
||||
(stak-aux)))
|
||||
(stak-z (let ((stak-x (the fixnum (1- stak-z)))
|
||||
(stak-y stak-x)
|
||||
(stak-z stak-y))
|
||||
(stak-aux))))
|
||||
(stak-aux))))
|
||||
|
||||
(defun teststak ()
|
||||
(stak 18 12 6))
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
#+excl
|
||||
(eval-when (compile) (setq comp::register-use-threshold 6))
|
||||
|
||||
(declaim (function tak (fixnum fixnum fixnum) fixnum))
|
||||
|
||||
(defun tak (x y z)
|
||||
(declare (fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t
|
||||
(tak
|
||||
(tak (the fixnum (1- x)) y z)
|
||||
(tak (the fixnum (1- y)) z x)
|
||||
(tak (the fixnum (1- z)) x y)))))
|
||||
|
||||
(defun testtak ()
|
||||
(progn (tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)))
|
||||
|
||||
#+excl (eval-when (compile) (setq comp::register-use-threshold 3))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
#+excl
|
||||
(eval-when (compile) (setq comp::register-use-threshold 6))
|
||||
|
||||
(defun tak (x y z)
|
||||
(declare (fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t
|
||||
(tak
|
||||
(tak (the fixnum (1- x)) y z)
|
||||
(tak (the fixnum (1- y)) z x)
|
||||
(tak (the fixnum (1- z)) x y)))))
|
||||
|
||||
(defun testtak ()
|
||||
(progn (tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)
|
||||
(tak 18 12 6)))
|
||||
|
||||
#+excl (eval-when (compile) (setq comp::register-use-threshold 3))
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; TAKL -- The TAKeuchi function using lists as counters.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defun listn (n)
|
||||
(declare (type fixnum n))
|
||||
(if (not (= 0 n))
|
||||
(cons n (listn (the fixnum (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)))))
|
||||
|
||||
(defun testtakl ()
|
||||
(mas 18l 12l 6l))
|
||||
|
|
@ -1,613 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; 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.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defun tak0 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak1 (tak37 (the fixnum (1- x)) y z)
|
||||
(tak11 (the fixnum (1- y)) z x)
|
||||
(tak17 (the fixnum (1- z)) x y)))))
|
||||
(defun tak1 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak2 (tak74 (the fixnum (1- x)) y z)
|
||||
(tak22 (the fixnum (1- y)) z x)
|
||||
(tak34 (the fixnum (1- z)) x y)))))
|
||||
(defun tak2 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak3 (tak11 (the fixnum (1- x)) y z)
|
||||
(tak33 (the fixnum (1- y)) z x)
|
||||
(tak51 (the fixnum (1- z)) x y)))))
|
||||
(defun tak3 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak4 (tak48 (the fixnum (1- x)) y z)
|
||||
(tak44 (the fixnum (1- y)) z x)
|
||||
(tak68 (the fixnum (1- z)) x y)))))
|
||||
(defun tak4 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak5 (tak85 (the fixnum (1- x)) y z)
|
||||
(tak55 (the fixnum (1- y)) z x)
|
||||
(tak85 (the fixnum (1- z)) x y)))))
|
||||
(defun tak5 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak6 (tak22 (the fixnum (1- x)) y z)
|
||||
(tak66 (the fixnum (1- y)) z x)
|
||||
(tak2 (the fixnum (1- z)) x y)))))
|
||||
(defun tak6 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak7 (tak59 (the fixnum (1- x)) y z)
|
||||
(tak77 (the fixnum (1- y)) z x)
|
||||
(tak19 (the fixnum (1- z)) x y)))))
|
||||
(defun tak7 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak8 (tak96 (the fixnum (1- x)) y z)
|
||||
(tak88 (the fixnum (1- y)) z x)
|
||||
(tak36 (the fixnum (1- z)) x y)))))
|
||||
(defun tak8 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak9 (tak33 (the fixnum (1- x)) y z)
|
||||
(tak99 (the fixnum (1- y)) z x)
|
||||
(tak53 (the fixnum (1- z)) x y)))))
|
||||
(defun tak9 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak10 (tak70 (the fixnum (1- x)) y z)
|
||||
(tak10 (the fixnum (1- y)) z x)
|
||||
(tak70 (the fixnum (1- z)) x y)))))
|
||||
(defun tak10 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak11 (tak7 (the fixnum (1- x)) y z)
|
||||
(tak21 (the fixnum (1- y)) z x)
|
||||
(tak87 (the fixnum (1- z)) x y)))))
|
||||
(defun tak11 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak12 (tak44 (the fixnum (1- x)) y z)
|
||||
(tak32 (the fixnum (1- y)) z x)
|
||||
(tak4 (the fixnum (1- z)) x y)))))
|
||||
(defun tak12 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak13 (tak81 (the fixnum (1- x)) y z)
|
||||
(tak43 (the fixnum (1- y)) z x)
|
||||
(tak21 (the fixnum (1- z)) x y)))))
|
||||
|
||||
(defun tak13 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak14 (tak18 (the fixnum (1- x)) y z)
|
||||
(tak54 (the fixnum (1- y)) z x)
|
||||
(tak38 (the fixnum (1- z)) x y)))))
|
||||
(defun tak14 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak15 (tak55 (the fixnum (1- x)) y z)
|
||||
(tak65 (the fixnum (1- y)) z x)
|
||||
(tak55 (the fixnum (1- z)) x y)))))
|
||||
(defun tak15 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak16 (tak92 (the fixnum (1- x)) y z)
|
||||
(tak76 (the fixnum (1- y)) z x)
|
||||
(tak72 (the fixnum (1- z)) x y)))))
|
||||
(defun tak16 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak17 (tak29 (the fixnum (1- x)) y z)
|
||||
(tak87 (the fixnum (1- y)) z x)
|
||||
(tak89 (the fixnum (1- z)) x y)))))
|
||||
(defun tak17 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak18 (tak66 (the fixnum (1- x)) y z)
|
||||
(tak98 (the fixnum (1- y)) z x)
|
||||
(tak6 (the fixnum (1- z)) x y)))))
|
||||
(defun tak18 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak19 (tak3 (the fixnum (1- x)) y z)
|
||||
(tak9 (the fixnum (1- y)) z x)
|
||||
(tak23 (the fixnum (1- z)) x y)))))
|
||||
(defun tak19 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak20 (tak40 (the fixnum (1- x)) y z)
|
||||
(tak20 (the fixnum (1- y)) z x)
|
||||
(tak40 (the fixnum (1- z)) x y)))))
|
||||
(defun tak20 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak21 (tak77 (the fixnum (1- x)) y z)
|
||||
(tak31 (the fixnum (1- y)) z x)
|
||||
(tak57 (the fixnum (1- z)) x y)))))
|
||||
(defun tak21 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak22 (tak14 (the fixnum (1- x)) y z)
|
||||
(tak42 (the fixnum (1- y)) z x)
|
||||
(tak74 (the fixnum (1- z)) x y)))))
|
||||
(defun tak22 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak23 (tak51 (the fixnum (1- x)) y z)
|
||||
(tak53 (the fixnum (1- y)) z x)
|
||||
(tak91 (the fixnum (1- z)) x y)))))
|
||||
(defun tak23 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak24 (tak88 (the fixnum (1- x)) y z)
|
||||
(tak64 (the fixnum (1- y)) z x)
|
||||
(tak8 (the fixnum (1- z)) x y)))))
|
||||
(defun tak24 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak25 (tak25 (the fixnum (1- x)) y z)
|
||||
(tak75 (the fixnum (1- y)) z x)
|
||||
(tak25 (the fixnum (1- z)) x y)))))
|
||||
(defun tak25 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak26 (tak62 (the fixnum (1- x)) y z)
|
||||
(tak86 (the fixnum (1- y)) z x)
|
||||
(tak42 (the fixnum (1- z)) x y)))))
|
||||
(defun tak26 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak27 (tak99 (the fixnum (1- x)) y z)
|
||||
(tak97 (the fixnum (1- y)) z x)
|
||||
(tak59 (the fixnum (1- z)) x y)))))
|
||||
(defun tak27 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak28 (tak36 (the fixnum (1- x)) y z)
|
||||
(tak8 (the fixnum (1- y)) z x)
|
||||
(tak76 (the fixnum (1- z)) x y)))))
|
||||
(defun tak28 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak29 (tak73 (the fixnum (1- x)) y z)
|
||||
(tak19 (the fixnum (1- y)) z x)
|
||||
(tak93 (the fixnum (1- z)) x y)))))
|
||||
(defun tak29 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak30 (tak10 (the fixnum (1- x)) y z)
|
||||
(tak30 (the fixnum (1- y)) z x)
|
||||
(tak10 (the fixnum (1- z)) x y)))))
|
||||
(defun tak30 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak31 (tak47 (the fixnum (1- x)) y z)
|
||||
(tak41 (the fixnum (1- y)) z x)
|
||||
(tak27 (the fixnum (1- z)) x y)))))
|
||||
(defun tak31 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak32 (tak84 (the fixnum (1- x)) y z)
|
||||
(tak52 (the fixnum (1- y)) z x)
|
||||
(tak44 (the fixnum (1- z)) x y)))))
|
||||
(defun tak32 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak33 (tak21 (the fixnum (1- x)) y z)
|
||||
(tak63 (the fixnum (1- y)) z x)
|
||||
(tak61 (the fixnum (1- z)) x y)))))
|
||||
(defun tak33 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak34 (tak58 (the fixnum (1- x)) y z)
|
||||
(tak74 (the fixnum (1- y)) z x)
|
||||
(tak78 (the fixnum (1- z)) x y)))))
|
||||
(defun tak34 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak35 (tak95 (the fixnum (1- x)) y z)
|
||||
(tak85 (the fixnum (1- y)) z x)
|
||||
(tak95 (the fixnum (1- z)) x y)))))
|
||||
(defun tak35 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak36 (tak32 (the fixnum (1- x)) y z)
|
||||
(tak96 (the fixnum (1- y)) z x)
|
||||
(tak12 (the fixnum (1- z)) x y)))))
|
||||
(defun tak36 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak37 (tak69 (the fixnum (1- x)) y z)
|
||||
(tak7 (the fixnum (1- y)) z x)
|
||||
(tak29 (the fixnum (1- z)) x y)))))
|
||||
(defun tak37 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak38 (tak6 (the fixnum (1- x)) y z)
|
||||
(tak18 (the fixnum (1- y)) z x)
|
||||
(tak46 (the fixnum (1- z)) x y)))))
|
||||
(defun tak38 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak39 (tak43 (the fixnum (1- x)) y z)
|
||||
(tak29 (the fixnum (1- y)) z x)
|
||||
(tak63 (the fixnum (1- z)) x y)))))
|
||||
(defun tak39 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak40 (tak80 (the fixnum (1- x)) y z)
|
||||
(tak40 (the fixnum (1- y)) z x)
|
||||
(tak80 (the fixnum (1- z)) x y)))))
|
||||
(defun tak40 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak41 (tak17 (the fixnum (1- x)) y z)
|
||||
(tak51 (the fixnum (1- y)) z x)
|
||||
(tak97 (the fixnum (1- z)) x y)))))
|
||||
(defun tak41 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak42 (tak54 (the fixnum (1- x)) y z)
|
||||
(tak62 (the fixnum (1- y)) z x)
|
||||
(tak14 (the fixnum (1- z)) x y)))))
|
||||
(defun tak42 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak43 (tak91 (the fixnum (1- x)) y z)
|
||||
(tak73 (the fixnum (1- y)) z x)
|
||||
(tak31 (the fixnum (1- z)) x y)))))
|
||||
(defun tak43 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak44 (tak28 (the fixnum (1- x)) y z)
|
||||
(tak84 (the fixnum (1- y)) z x)
|
||||
(tak48 (the fixnum (1- z)) x y)))))
|
||||
(defun tak44 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak45 (tak65 (the fixnum (1- x)) y z)
|
||||
(tak95 (the fixnum (1- y)) z x)
|
||||
(tak65 (the fixnum (1- z)) x y)))))
|
||||
(defun tak45 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak46 (tak2 (the fixnum (1- x)) y z)
|
||||
(tak6 (the fixnum (1- y)) z x)
|
||||
(tak82 (the fixnum (1- z)) x y)))))
|
||||
(defun tak46 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak47 (tak39 (the fixnum (1- x)) y z)
|
||||
(tak17 (the fixnum (1- y)) z x)
|
||||
(tak99 (the fixnum (1- z)) x y)))))
|
||||
(defun tak47 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak48 (tak76 (the fixnum (1- x)) y z)
|
||||
(tak28 (the fixnum (1- y)) z x)
|
||||
(tak16 (the fixnum (1- z)) x y)))))
|
||||
(defun tak48 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak49 (tak13 (the fixnum (1- x)) y z)
|
||||
(tak39 (the fixnum (1- y)) z x)
|
||||
(tak33 (the fixnum (1- z)) x y)))))
|
||||
(defun tak49 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak50 (tak50 (the fixnum (1- x)) y z)
|
||||
(tak50 (the fixnum (1- y)) z x)
|
||||
(tak50 (the fixnum (1- z)) x y)))))
|
||||
(defun tak50 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak51 (tak87 (the fixnum (1- x)) y z)
|
||||
(tak61 (the fixnum (1- y)) z x)
|
||||
(tak67 (the fixnum (1- z)) x y)))))
|
||||
(defun tak51 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak52 (tak24 (the fixnum (1- x)) y z)
|
||||
(tak72 (the fixnum (1- y)) z x)
|
||||
(tak84 (the fixnum (1- z)) x y)))))
|
||||
(defun tak52 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak53 (tak61 (the fixnum (1- x)) y z)
|
||||
(tak83 (the fixnum (1- y)) z x)
|
||||
(tak1 (the fixnum (1- z)) x y)))))
|
||||
(defun tak53 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak54 (tak98 (the fixnum (1- x)) y z)
|
||||
(tak94 (the fixnum (1- y)) z x)
|
||||
(tak18 (the fixnum (1- z)) x y)))))
|
||||
(defun tak54 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak55 (tak35 (the fixnum (1- x)) y z)
|
||||
(tak5 (the fixnum (1- y)) z x)
|
||||
(tak35 (the fixnum (1- z)) x y)))))
|
||||
(defun tak55 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak56 (tak72 (the fixnum (1- x)) y z)
|
||||
(tak16 (the fixnum (1- y)) z x)
|
||||
(tak52 (the fixnum (1- z)) x y)))))
|
||||
(defun tak56 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak57 (tak9 (the fixnum (1- x)) y z)
|
||||
(tak27 (the fixnum (1- y)) z x)
|
||||
(tak69 (the fixnum (1- z)) x y)))))
|
||||
(defun tak57 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak58 (tak46 (the fixnum (1- x)) y z)
|
||||
(tak38 (the fixnum (1- y)) z x)
|
||||
(tak86 (the fixnum (1- z)) x y)))))
|
||||
(defun tak58 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak59 (tak83 (the fixnum (1- x)) y z)
|
||||
(tak49 (the fixnum (1- y)) z x)
|
||||
(tak3 (the fixnum (1- z)) x y)))))
|
||||
(defun tak59 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak60 (tak20 (the fixnum (1- x)) y z)
|
||||
(tak60 (the fixnum (1- y)) z x)
|
||||
(tak20 (the fixnum (1- z)) x y)))))
|
||||
(defun tak60 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak61 (tak57 (the fixnum (1- x)) y z)
|
||||
(tak71 (the fixnum (1- y)) z x)
|
||||
(tak37 (the fixnum (1- z)) x y)))))
|
||||
(defun tak61 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak62 (tak94 (the fixnum (1- x)) y z)
|
||||
(tak82 (the fixnum (1- y)) z x)
|
||||
(tak54 (the fixnum (1- z)) x y)))))
|
||||
(defun tak62 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak63 (tak31 (the fixnum (1- x)) y z)
|
||||
(tak93 (the fixnum (1- y)) z x)
|
||||
(tak71 (the fixnum (1- z)) x y)))))
|
||||
(defun tak63 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak64 (tak68 (the fixnum (1- x)) y z)
|
||||
(tak4 (the fixnum (1- y)) z x)
|
||||
(tak88 (the fixnum (1- z)) x y)))))
|
||||
(defun tak64 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak65 (tak5 (the fixnum (1- x)) y z)
|
||||
(tak15 (the fixnum (1- y)) z x)
|
||||
(tak5 (the fixnum (1- z)) x y)))))
|
||||
(defun tak65 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak66 (tak42 (the fixnum (1- x)) y z)
|
||||
(tak26 (the fixnum (1- y)) z x)
|
||||
(tak22 (the fixnum (1- z)) x y)))))
|
||||
(defun tak66 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak67 (tak79 (the fixnum (1- x)) y z)
|
||||
(tak37 (the fixnum (1- y)) z x)
|
||||
(tak39 (the fixnum (1- z)) x y)))))
|
||||
(defun tak67 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak68 (tak16 (the fixnum (1- x)) y z)
|
||||
(tak48 (the fixnum (1- y)) z x)
|
||||
(tak56 (the fixnum (1- z)) x y)))))
|
||||
(defun tak68 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak69 (tak53 (the fixnum (1- x)) y z)
|
||||
(tak59 (the fixnum (1- y)) z x)
|
||||
(tak73 (the fixnum (1- z)) x y)))))
|
||||
(defun tak69 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak70 (tak90 (the fixnum (1- x)) y z)
|
||||
(tak70 (the fixnum (1- y)) z x)
|
||||
(tak90 (the fixnum (1- z)) x y)))))
|
||||
(defun tak70 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak71 (tak27 (the fixnum (1- x)) y z)
|
||||
(tak81 (the fixnum (1- y)) z x)
|
||||
(tak7 (the fixnum (1- z)) x y)))))
|
||||
(defun tak71 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak72 (tak64 (the fixnum (1- x)) y z)
|
||||
(tak92 (the fixnum (1- y)) z x)
|
||||
(tak24 (the fixnum (1- z)) x y)))))
|
||||
(defun tak72 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak73 (tak1 (the fixnum (1- x)) y z)
|
||||
(tak3 (the fixnum (1- y)) z x)
|
||||
(tak41 (the fixnum (1- z)) x y)))))
|
||||
(defun tak73 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak74 (tak38 (the fixnum (1- x)) y z)
|
||||
(tak14 (the fixnum (1- y)) z x)
|
||||
(tak58 (the fixnum (1- z)) x y)))))
|
||||
(defun tak74 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak75 (tak75 (the fixnum (1- x)) y z)
|
||||
(tak25 (the fixnum (1- y)) z x)
|
||||
(tak75 (the fixnum (1- z)) x y)))))
|
||||
(defun tak75 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak76 (tak12 (the fixnum (1- x)) y z)
|
||||
(tak36 (the fixnum (1- y)) z x)
|
||||
(tak92 (the fixnum (1- z)) x y)))))
|
||||
(defun tak76 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak77 (tak49 (the fixnum (1- x)) y z)
|
||||
(tak47 (the fixnum (1- y)) z x)
|
||||
(tak9 (the fixnum (1- z)) x y)))))
|
||||
(defun tak77 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak78 (tak86 (the fixnum (1- x)) y z)
|
||||
(tak58 (the fixnum (1- y)) z x)
|
||||
(tak26 (the fixnum (1- z)) x y)))))
|
||||
(defun tak78 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak79 (tak23 (the fixnum (1- x)) y z)
|
||||
(tak69 (the fixnum (1- y)) z x)
|
||||
(tak43 (the fixnum (1- z)) x y)))))
|
||||
(defun tak79 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak80 (tak60 (the fixnum (1- x)) y z)
|
||||
(tak80 (the fixnum (1- y)) z x)
|
||||
(tak60 (the fixnum (1- z)) x y)))))
|
||||
(defun tak80 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak81 (tak97 (the fixnum (1- x)) y z)
|
||||
(tak91 (the fixnum (1- y)) z x)
|
||||
(tak77 (the fixnum (1- z)) x y)))))
|
||||
(defun tak81 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak82 (tak34 (the fixnum (1- x)) y z)
|
||||
(tak2 (the fixnum (1- y)) z x)
|
||||
(tak94 (the fixnum (1- z)) x y)))))
|
||||
(defun tak82 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak83 (tak71 (the fixnum (1- x)) y z)
|
||||
(tak13 (the fixnum (1- y)) z x)
|
||||
(tak11 (the fixnum (1- z)) x y)))))
|
||||
(defun tak83 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak84 (tak8 (the fixnum (1- x)) y z)
|
||||
(tak24 (the fixnum (1- y)) z x)
|
||||
(tak28 (the fixnum (1- z)) x y)))))
|
||||
(defun tak84 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak85 (tak45 (the fixnum (1- x)) y z)
|
||||
(tak35 (the fixnum (1- y)) z x)
|
||||
(tak45 (the fixnum (1- z)) x y)))))
|
||||
(defun tak85 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak86 (tak82 (the fixnum (1- x)) y z)
|
||||
(tak46 (the fixnum (1- y)) z x)
|
||||
(tak62 (the fixnum (1- z)) x y)))))
|
||||
(defun tak86 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak87 (tak19 (the fixnum (1- x)) y z)
|
||||
(tak57 (the fixnum (1- y)) z x)
|
||||
(tak79 (the fixnum (1- z)) x y)))))
|
||||
(defun tak87 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak88 (tak56 (the fixnum (1- x)) y z)
|
||||
(tak68 (the fixnum (1- y)) z x)
|
||||
(tak96 (the fixnum (1- z)) x y)))))
|
||||
(defun tak88 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak89 (tak93 (the fixnum (1- x)) y z)
|
||||
(tak79 (the fixnum (1- y)) z x)
|
||||
(tak13 (the fixnum (1- z)) x y)))))
|
||||
(defun tak89 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak90 (tak30 (the fixnum (1- x)) y z)
|
||||
(tak90 (the fixnum (1- y)) z x)
|
||||
(tak30 (the fixnum (1- z)) x y)))))
|
||||
(defun tak90 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak91 (tak67 (the fixnum (1- x)) y z)
|
||||
(tak1 (the fixnum (1- y)) z x)
|
||||
(tak47 (the fixnum (1- z)) x y)))))
|
||||
(defun tak91 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak92 (tak4 (the fixnum (1- x)) y z)
|
||||
(tak12 (the fixnum (1- y)) z x)
|
||||
(tak64 (the fixnum (1- z)) x y)))))
|
||||
(defun tak92 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak93 (tak41 (the fixnum (1- x)) y z)
|
||||
(tak23 (the fixnum (1- y)) z x)
|
||||
(tak81 (the fixnum (1- z)) x y)))))
|
||||
(defun tak93 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak94 (tak78 (the fixnum (1- x)) y z)
|
||||
(tak34 (the fixnum (1- y)) z x)
|
||||
(tak98 (the fixnum (1- z)) x y)))))
|
||||
(defun tak94 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak95 (tak15 (the fixnum (1- x)) y z)
|
||||
(tak45 (the fixnum (1- y)) z x)
|
||||
(tak15 (the fixnum (1- z)) x y)))))
|
||||
(defun tak95 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak96 (tak52 (the fixnum (1- x)) y z)
|
||||
(tak56 (the fixnum (1- y)) z x)
|
||||
(tak32 (the fixnum (1- z)) x y)))))
|
||||
(defun tak96 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak97 (tak89 (the fixnum (1- x)) y z)
|
||||
(tak67 (the fixnum (1- y)) z x)
|
||||
(tak49 (the fixnum (1- z)) x y)))))
|
||||
(defun tak97 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak98 (tak26 (the fixnum (1- x)) y z)
|
||||
(tak78 (the fixnum (1- y)) z x)
|
||||
(tak66 (the fixnum (1- z)) x y)))))
|
||||
(defun tak98 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak99 (tak63 (the fixnum (1- x)) y z)
|
||||
(tak89 (the fixnum (1- y)) z x)
|
||||
(tak83 (the fixnum (1- z)) x y)))))
|
||||
(defun tak99 (x y z)
|
||||
(declare (type fixnum x y z))
|
||||
(cond ((not (< y x)) z)
|
||||
(t (tak0 (tak0 (the fixnum (1- x)) y z)
|
||||
(tak0 (the fixnum (1- y)) z x)
|
||||
(tak0 (the fixnum (1- z)) x y)))))
|
||||
|
||||
(defun testtakr ()
|
||||
(tak0 18 12 6))
|
||||
|
|
@ -1,144 +0,0 @@
|
|||
(in-package "CL-USER")
|
||||
|
||||
(setq *print-circle* nil)
|
||||
|
||||
#+clisp
|
||||
(defmacro with-ignored-errors (&rest forms)
|
||||
(let ((b (gensym)))
|
||||
`(block ,b
|
||||
(let ((*error-handler*
|
||||
#'(lambda (&rest args) (return-from ,b 'error))
|
||||
))
|
||||
,@forms
|
||||
) )
|
||||
) )
|
||||
|
||||
#+akcl
|
||||
(defmacro with-ignored-errors (&rest forms)
|
||||
(let ((b (gensym))
|
||||
(h (gensym)))
|
||||
`(block ,b
|
||||
(let ((,h (symbol-function 'system:universal-error-handler)))
|
||||
(unwind-protect
|
||||
(progn (setf (symbol-function 'system:universal-error-handler)
|
||||
#'(lambda (&rest args) (return-from ,b 'error))
|
||||
)
|
||||
,@forms
|
||||
)
|
||||
(setf (symbol-function 'system:universal-error-handler) ,h)
|
||||
) ) )
|
||||
) )
|
||||
|
||||
#+allegro
|
||||
(defmacro with-ignored-errors (&rest forms)
|
||||
(let ((r (gensym)))
|
||||
`(let ((,r (multiple-value-list (excl:errorset (progn ,@forms)))))
|
||||
(if (car ,r) (values-list (cdr ,r)) 'error)
|
||||
)
|
||||
) )
|
||||
|
||||
#-(or clisp akcl allegro)
|
||||
(defmacro with-ignored-errors (&rest forms)
|
||||
(let ((b (gensym)))
|
||||
`(block ,b
|
||||
(handler-bind
|
||||
((error #'(lambda (condition) (return-from ,b 'error))))
|
||||
,@forms
|
||||
) )
|
||||
) )
|
||||
|
||||
(defvar *source-dir* "./")
|
||||
(defvar *output-dir* "./")
|
||||
|
||||
(defconstant +all-tests+ '("boyer" "browse" "ctak" "dderiv" "deriv"
|
||||
"destru-mod" "destru" "div2"
|
||||
"fprint" "fread" "frpoly"
|
||||
"puzzle" "puzzle-mod" "puzzle-mod2"
|
||||
"stak" "tak" "tak-mod" "takl" "takr"
|
||||
"tprint" "traverse" "triang-mod" "triang"
|
||||
;; These two are at the end because they cause
|
||||
;; SIGSEGVS in ECLS.
|
||||
#+nil"fft-mod" #+nil"fft"))
|
||||
|
||||
(defconstant +repeats+ '(("destru" 4)("destru-mod" 4)("fprint" 4)("fread" 4)
|
||||
("stak" 4)("takr" 4)("tprint" 4)))
|
||||
|
||||
#+(or (and ecls (not boehm-gc)) cmu)
|
||||
(setq system::*gc-verbose* nil)
|
||||
|
||||
(defun do-test (file &key (repeat 1 given) compile &aux tem)
|
||||
(when (find-package "TESTING")
|
||||
(delete-package "TESTING"))
|
||||
#+cmu
|
||||
(gc :full t)
|
||||
#+clisp
|
||||
(system::gc)
|
||||
#+ecl
|
||||
(system::gc t)
|
||||
(let ((source-file (merge-pathnames (merge-pathnames file *source-dir*) "foo.cl"))
|
||||
(fasl-file (and compile (compile-file-pathname (merge-pathnames file *output-dir*))))
|
||||
(*package* (make-package "TESTING")))
|
||||
(cond (compile
|
||||
(proclaim-file source-file)
|
||||
(compile-file source-file :output-file fasl-file
|
||||
#+ecl :c-file #+ecl t #+ecl :h-file #+ecl t
|
||||
#+ecl :verbose #+ecl t)
|
||||
(print fasl-file)
|
||||
(load fasl-file :verbose t))
|
||||
(t
|
||||
(load source-file :verbose t)))
|
||||
(if (and (not given)
|
||||
(setq tem (assoc file +repeats+ :test 'equalp)))
|
||||
(setq repeat (second tem)))
|
||||
(let* ((pos (position #\- file))
|
||||
(name (if pos (subseq file 0 pos) file))
|
||||
(command (intern (string-upcase (format nil "TEST~a" name))))
|
||||
(start (get-internal-run-time)))
|
||||
(dotimes (i repeat) (funcall command))
|
||||
(setq start (- (get-internal-run-time) start))
|
||||
(/ (float start) (* (float internal-time-units-per-second) repeat)))))
|
||||
|
||||
|
||||
(defun do-all-tests (name *source-dir* *output-dir* &optional (compile nil))
|
||||
(with-open-file (st name :direction :output
|
||||
:if-does-not-exist :create
|
||||
:if-exists :supersede)
|
||||
(print (cons name (mapcar #'(lambda (name)
|
||||
(with-ignored-errors
|
||||
(do-test name :compile compile)))
|
||||
+all-tests+))
|
||||
st)))
|
||||
|
||||
(defun beautify-output (output)
|
||||
(let ((data nil) (envs 0) (tests 0))
|
||||
(do ((item (read) (read)))
|
||||
((null item))
|
||||
(push item data))
|
||||
(setq envs (length data)
|
||||
tests (length (car data))
|
||||
data (make-array (list (1+ envs) tests)
|
||||
:initial-contents (cons (cons "" +all-tests+) data)))
|
||||
(with-open-file (st output :direction :output :if-exists :append
|
||||
:if-does-not-exist :create)
|
||||
(dotimes (row tests)
|
||||
(dotimes (col (1+ envs))
|
||||
(let ((data (aref data col row)))
|
||||
(cond ((zerop col)
|
||||
(format st "~%~12a" data))
|
||||
((numberp data)
|
||||
(format st " ~7,3f" data))
|
||||
((eq data 'ERROR)
|
||||
(format st " *****"))
|
||||
(t
|
||||
(format st " ~7<~a~>" data))))))
|
||||
(format st "
|
||||
|
||||
IMPLi = Implementation IMPL interpreted
|
||||
IMPLc = Implementation IMPL compiled
|
||||
|
||||
CLISP = CLISP 2000-03-06 (March 2000)
|
||||
CMUCL = CMUCL 18c
|
||||
ECLS = ECLS ~A
|
||||
" (lisp-implementation-version))
|
||||
(terpri st))
|
||||
(quit)))
|
||||
|
|
@ -1,645 +0,0 @@
|
|||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 10:47:59 CDT 1988
|
||||
|
||||
BOYER 12.350 sec.
|
||||
BROWSE 32.467 sec.
|
||||
CTAK 7.200 sec.
|
||||
DDERIV 7.883 sec.
|
||||
DERIV 6.417 sec.
|
||||
DESTRU 2.917 sec.
|
||||
DIV2 5.550 sec.
|
||||
FFT-MOD 23.167 sec.
|
||||
FFT 65.000 sec.
|
||||
FPRINT 1.783 sec.
|
||||
FREAD 2.600 sec.
|
||||
FRPOLY 86.183 sec.
|
||||
PUZZLE-MOD 7.200 sec.
|
||||
PUZZLE 8.233 sec.
|
||||
STAK 3.733 sec.
|
||||
TAK 6.467 sec.
|
||||
TAKL 2.667 sec.
|
||||
TAKR 1.017 sec.
|
||||
TPRINT 3.183 sec.
|
||||
TRAVERSE 44.100 sec.
|
||||
TRIANG-MOD 139.117 sec.
|
||||
TRIANG 149.900 sec.
|
||||
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lucid Common Lisp
|
||||
Thu Apr 7 11:12:44 CDT 1988
|
||||
|
||||
BOYER 15.160 sec.
|
||||
BROWSE 29.560 sec.
|
||||
CTAK 2.160 sec.
|
||||
DDERIV 9.260 sec.
|
||||
DERIV 8.200 sec.
|
||||
DESTRU 1.720 sec.
|
||||
DIV2 6.660 sec.
|
||||
FFT-MOD 51.880 sec.
|
||||
FFT 51.840 sec.
|
||||
FPRINT 1.460 sec.
|
||||
FREAD 3.180 sec.
|
||||
FRPOLY 45.200 sec.
|
||||
PUZZLE-MOD 6.960 sec.
|
||||
PUZZLE 5.140 sec.
|
||||
STAK 2.620 sec.
|
||||
TAK 4.900 sec.
|
||||
TAKL 2.640 sec.
|
||||
TAKR 0.840 sec.
|
||||
TPRINT 3.680 sec.
|
||||
TRAVERSE 40.060 sec.
|
||||
TRIANG-MOD 288.140 sec.
|
||||
TRIANG 141.62 sec.
|
||||
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 11:58:43 CDT 1988
|
||||
|
||||
BOYER 12.533 sec.
|
||||
BROWSE 24.517 sec.
|
||||
CTAK 6.517 sec.
|
||||
DDERIV 6.050 sec.
|
||||
DERIV 4.950 sec.
|
||||
DESTRU 2.900 sec.
|
||||
DIV2 5.533 sec.
|
||||
FFT-MOD 23.283 sec.
|
||||
FFT 64.450 sec.
|
||||
FPRINT 1.800
|
||||
FREAD 3.033
|
||||
FRPOLY 86.567
|
||||
PUZZLE-MOD 7.200
|
||||
PUZZLE 8.317
|
||||
STAK 3.733
|
||||
TAK 6.483
|
||||
TAKL 2.617
|
||||
TAKR 1.000
|
||||
TPRINT 3.167
|
||||
TRAVERSE 38.933
|
||||
TRIANG-MOD 138.500
|
||||
TRIANG 149.267
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For kcl Common Lisp
|
||||
Thu Apr 7 12:32:17 CDT 1988
|
||||
|
||||
|
||||
BOYER 15.950
|
||||
BROWSE 41.283
|
||||
CTAK 7.050
|
||||
DDERIV 8.417
|
||||
DERIV 6.450
|
||||
DESTRU 3.717
|
||||
DIV2 5.667
|
||||
FFT-MOD 29.467
|
||||
FPRINT 2.417
|
||||
FREAD 2.867
|
||||
FRPOLY 90.167
|
||||
PUZZLE-MOD 10.183
|
||||
PUZZLE 11.183
|
||||
STAK 4.350
|
||||
TAK 5.767
|
||||
TAKL 3.017
|
||||
TAKR 1.483
|
||||
TPRINT 4.233
|
||||
TRAVERSE 71.133
|
||||
TRIANG-MOD 204.100
|
||||
TRIANG 220.917
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 13:23:19 CDT 1988
|
||||
|
||||
FFT-MOD 7.933
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 13:25:08 CDT 1988
|
||||
|
||||
FFT 59.150
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 19:35:41 CDT 1988
|
||||
|
||||
TRIANG-MOD 118.033
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lucid Common Lisp
|
||||
Thu Apr 7 19:42:21 CDT 1988
|
||||
|
||||
TRIANG-MOD 453.840
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For kcl Common Lisp
|
||||
Thu Apr 7 20:56:37 CDT 1988
|
||||
|
||||
TRIANG-MOD 160.783
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For kcl Common Lisp
|
||||
Thu Apr 7 21:13:11 CDT 1988
|
||||
|
||||
TAK-MOD 3.600
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 21:13:53 CDT 1988
|
||||
|
||||
TAK-MOD 5.367
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lucid Common Lisp
|
||||
Thu Apr 7 21:14:32 CDT 1988
|
||||
|
||||
TAK-MOD 4.760
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 22:15:52 CDT 1988
|
||||
|
||||
BOYER 12.350
|
||||
BROWSE 25.083
|
||||
CTAK 7.100
|
||||
DDERIV 6.550
|
||||
DERIV 5.017
|
||||
DESTRU 3.300
|
||||
DIV2 5.600
|
||||
FFT-MOD 21.583
|
||||
FFT 65.117
|
||||
FPRINT 1.850
|
||||
FREAD 2.533
|
||||
FRPOLY 86.800
|
||||
PUZZLE-MOD 7.633
|
||||
PUZZLE 8.800
|
||||
STAK 4.217
|
||||
TAK-MOD 3.650
|
||||
TAK 5.467
|
||||
TAKL 3.167
|
||||
TAKR 0.883
|
||||
TPRINT 3.150
|
||||
TRAVERSE 39.533
|
||||
TRIANG-MOD 131.700
|
||||
TRIANG 152.517
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp cc,4
|
||||
Thu Apr 7 22:51:17 CDT 1988
|
||||
|
||||
BOYER 12.250
|
||||
BROWSE 25.067
|
||||
CTAK 7.133
|
||||
DDERIV 6.533
|
||||
DERIV 5.033
|
||||
DESTRU 3.283
|
||||
DIV2 5.583
|
||||
FFT-MOD 21.533
|
||||
FFT 64.700
|
||||
FPRINT 1.767
|
||||
FREAD 2.483
|
||||
FRPOLY 86.483
|
||||
PUZZLE-MOD 7.617
|
||||
PUZZLE 8.667
|
||||
STAK 4.200
|
||||
TAK-MOD 4.350
|
||||
TAK 5.967
|
||||
TAKL 3.117
|
||||
TAKR 1.033
|
||||
TPRINT 3.183
|
||||
TRAVERSE 39.217
|
||||
TRIANG-MOD 130.767
|
||||
TRIANG 151.400
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 7 23:23:59 CDT 1988
|
||||
|
||||
FREAD 2.550
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For kcl Common Lisp
|
||||
Thu Apr 7 23:27:10 CDT 1988
|
||||
|
||||
FREAD 2.800
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lucid Common Lisp
|
||||
Thu Apr 7 23:27:48 CDT 1988
|
||||
|
||||
FREAD 3.280
|
||||
|
||||
;next using regmin=1000000
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Fri Apr 8 00:15:43 CDT 1988
|
||||
|
||||
BOYER 12.283
|
||||
BROWSE 25.450
|
||||
CTAK 6.817
|
||||
DDERIV 6.550
|
||||
DERIV 4.917
|
||||
DESTRU 3.333
|
||||
DIV2 5.667
|
||||
FFT-MOD 22.050
|
||||
FFT 65.450
|
||||
FPRINT 1.850
|
||||
FREAD 2.517
|
||||
FRPOLY 86.733
|
||||
PUZZLE-MOD 9.900
|
||||
PUZZLE 10.600
|
||||
STAK 4.217
|
||||
TAK-MOD 3.650
|
||||
TAK 5.350
|
||||
TAKL 3.067
|
||||
TAKR 0.883
|
||||
TPRINT 3.183
|
||||
TRAVERSE 37.133
|
||||
TRIANG-MOD 130.850
|
||||
TRIANG 153.833
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Fri Apr 8 00:46:22 CDT 1988
|
||||
|
||||
BOYER 12.200
|
||||
BROWSE 24.183
|
||||
CTAK 6.583
|
||||
DDERIV 6.033
|
||||
DERIV 4.850
|
||||
DESTRU 2.883
|
||||
DIV2 5.433
|
||||
FFT-MOD 7.700
|
||||
FFT 58.450
|
||||
FPRINT 1.817
|
||||
FREAD 2.500
|
||||
FRPOLY 85.450
|
||||
PUZZLE-MOD 7.117
|
||||
PUZZLE 8.200
|
||||
STAK 3.717
|
||||
TAK-MOD 5.150
|
||||
TAK 6.467
|
||||
TAKL 2.600
|
||||
TAKR 0.933
|
||||
TPRINT 3.117
|
||||
TRAVERSE 38.917
|
||||
TRIANG-MOD 112.750
|
||||
TRIANG 147.567
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lisp Common Lisp
|
||||
Thu Apr 14 15:07:28 CDT 1988
|
||||
|
||||
BOYER 9.200
|
||||
BROWSE 18.500
|
||||
CTAK 1.140
|
||||
DDERIV 5.420
|
||||
DERIV 5.240
|
||||
DESTRU 1.080
|
||||
DIV2 4.380
|
||||
FFT-MOD 38.360
|
||||
FFT 34.760
|
||||
FPRINT 0.840
|
||||
FREAD 1.760
|
||||
FRPOLY 30.040
|
||||
PUZZLE-MOD 4.380
|
||||
PUZZLE 3.180
|
||||
STAK 1.380
|
||||
TAK-MOD 2.800
|
||||
TAK 2.760
|
||||
TAKL 1.680
|
||||
TAKR 0.460
|
||||
TPRINT 2.100
|
||||
TRAVERSE 27.940
|
||||
TRIANG-MOD 255.460
|
||||
TRIANG 76.760
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Thu Apr 14 15:58:30 CDT 1988
|
||||
|
||||
BOYER 6.633
|
||||
BROWSE 13.300
|
||||
CTAK 3.217
|
||||
DDERIV 4.717
|
||||
DERIV 4.100
|
||||
DESTRU 1.733
|
||||
DIV2 3.200
|
||||
FFT-MOD 5.917
|
||||
FPRINT 1.033
|
||||
FREAD 1.300
|
||||
FRPOLY 46.550
|
||||
PUZZLE-MOD 4.333
|
||||
PUZZLE 4.833
|
||||
STAK 1.817
|
||||
TAK-MOD 2.900
|
||||
TAK 3.883
|
||||
TAKL 1.533
|
||||
TAKR 0.533
|
||||
TPRINT 1.750
|
||||
TRAVERSE 25.783
|
||||
TRIANG-MOD 63.350
|
||||
TRIANG 77.833
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Fri Apr 15 23:48:59 CDT 1988
|
||||
|
||||
TRAVERSE 0.600
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Fri Apr 15 23:50:36 CDT 1988
|
||||
|
||||
BROWSE 12.883
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Fri Apr 15 23:58:06 CDT 1988
|
||||
|
||||
TRAVERSE 25.433
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Fri Apr 15 23:59:47 CDT 1988
|
||||
|
||||
BROWSE 13.150
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lisp Common Lisp
|
||||
Sat Apr 16 12:53:00 CDT 1988
|
||||
|
||||
DESTRU-MOD 1.380
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lisp Common Lisp
|
||||
Sat Apr 16 12:54:07 CDT 1988
|
||||
|
||||
DESTRU 1.100
|
||||
DESTRU 1.683
|
||||
DESTRU-MOD 1.117
|
||||
DESTRU 1.200
|
||||
DESTRU-MOD 1.160
|
||||
DESTRU-MOD 1.000
|
||||
DESTRU 1.337
|
||||
DESTRU 1.095
|
||||
DESTRU-MOD 1.185
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Sat Apr 16 13:42:57 CDT 1988
|
||||
|
||||
BOYER 7.267
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Sat Apr 16 13:44:00 CDT 1988
|
||||
|
||||
BROWSE 14.150
|
||||
BOYER 7.050
|
||||
CTAK 3.767
|
||||
DDERIV 4.633
|
||||
BROWSE 13.683
|
||||
DERIV 4.083
|
||||
CTAK 3.450
|
||||
DESTRU-MOD 1.071
|
||||
DDERIV 4.683
|
||||
DESTRU 1.408
|
||||
DIV2 3.100
|
||||
DERIV 4.017
|
||||
DESTRU-MOD 1.008
|
||||
FFT-MOD 6.200
|
||||
DESTRU 1.375
|
||||
DIV2 3.100
|
||||
FFT-MOD 5.967
|
||||
FPRINT 1.046
|
||||
FREAD 1.271
|
||||
FRPOLY 46.967
|
||||
FPRINT 1.096
|
||||
PUZZLE-MOD 4.367
|
||||
FREAD 1.354
|
||||
PUZZLE 4.983
|
||||
STAK 1.800
|
||||
TAK-MOD 2.900
|
||||
TAK 3.867
|
||||
TAKL 1.350
|
||||
TPRINT 1.775
|
||||
FRPOLY 47.733
|
||||
PUZZLE-MOD 4.483
|
||||
PUZZLE 4.883
|
||||
TRAVERSE 26.200
|
||||
STAK 1.950
|
||||
TAK-MOD 3.067
|
||||
TAK 4.533
|
||||
TAKL 1.467
|
||||
TPRINT 1.867
|
||||
TRAVERSE 26.033
|
||||
TRIANG-MOD 66.833
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Sat Apr 16 13:57:26 CDT 1988
|
||||
|
||||
TAKR 0.512
|
||||
TRIANG-MOD 64.917
|
||||
TRIANG 80.117
|
||||
TRIANG 80.500
|
||||
BOYER 6.583
|
||||
BROWSE 13.033
|
||||
CTAK 3.517
|
||||
DDERIV 4.567
|
||||
DERIV 3.933
|
||||
DESTRU-MOD 1.038
|
||||
DESTRU 1.367
|
||||
DIV2 3.150
|
||||
FFT-MOD 5.283
|
||||
FFT 32.267
|
||||
FPRINT 0.629
|
||||
FREAD 1.212
|
||||
FRPOLY 48.100
|
||||
PUZZLE-MOD 4.633
|
||||
PUZZLE 5.017
|
||||
STAK 1.813
|
||||
TAK-MOD 2.933
|
||||
TAK 4.017
|
||||
TAKL 1.350
|
||||
TAKR 0.550
|
||||
TPRINT 1.038
|
||||
TRAVERSE 26.317
|
||||
TRIANG-MOD 66.583
|
||||
BOYER 7.000
|
||||
BROWSE 13.600
|
||||
DDERIV 3.283
|
||||
DERIV 2.733
|
||||
DESTRU 1.408
|
||||
DESTRU-MOD 1.063
|
||||
FREAD 1.288
|
||||
FPRINT 0.608
|
||||
|
||||
|
||||
BOYER 6.667
|
||||
BROWSE 12.900
|
||||
CTAK 3.500
|
||||
DDERIV 3.317
|
||||
DERIV 2.633
|
||||
DESTRU-MOD 1.000
|
||||
DESTRU 1.350
|
||||
DIV2 3.117
|
||||
FFT-MOD 5.350
|
||||
FFT 32.150
|
||||
FPRINT 0.667
|
||||
FREAD 1.212
|
||||
FRPOLY 46.883
|
||||
PUZZLE-MOD 4.383
|
||||
PUZZLE 4.833
|
||||
STAK 1.813
|
||||
TAK-MOD 2.900
|
||||
TAK 3.833
|
||||
TAKL 1.350
|
||||
TAKR 0.521
|
||||
TPRINT 1.046
|
||||
TRAVERSE 25.667
|
||||
TRIANG-MOD 63.500
|
||||
TRIANG 78.017
|
||||
|
||||
------
|
||||
FPRINT 0.800
|
||||
FREAD 1.670
|
||||
TPRINT 2.275
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For lisp Common Lisp
|
||||
Sat Apr 16 21:28:52 CDT 1988
|
||||
|
||||
DESTRU-MOD 1.090
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Sat Apr 16 21:42:49 CDT 1988
|
||||
|
||||
BOYER 6.583
|
||||
BROWSE 12.900
|
||||
CTAK 2.883
|
||||
DDERIV 3.300
|
||||
DERIV 2.633
|
||||
DESTRU-MOD 0.988
|
||||
DESTRU 1.367
|
||||
DIV2 3.117
|
||||
FFT-MOD 5.283
|
||||
FFT 32.150
|
||||
FPRINT 0.637
|
||||
FREAD 1.221
|
||||
FRPOLY 46.600
|
||||
PUZZLE-MOD 4.283
|
||||
PUZZLE 4.850
|
||||
STAK 1.800
|
||||
TAK-MOD 2.883
|
||||
TAK 3.833
|
||||
TAKL 1.350
|
||||
TAKR 0.517
|
||||
TPRINT 1.013
|
||||
TRAVERSE 25.567
|
||||
TRIANG-MOD 63.317
|
||||
TRIANG 77.867
|
||||
BOYER 6.833
|
||||
BOYER 6.600
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Tue Apr 19 17:28:36 CDT 1988
|
||||
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Tue Apr 19 17:29:35 CDT 1988
|
||||
|
||||
BOYER 6.583
|
||||
BOYER 8.383
|
||||
BOYER 7.050
|
||||
BOYER 6.567
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For skcl Common Lisp
|
||||
Tue Apr 19 23:40:44 CDT 1988
|
||||
|
||||
BOYER 6.600
|
||||
BROWSE 12.817
|
||||
CTAK 3.417
|
||||
DDERIV 3.283
|
||||
DERIV 2.633
|
||||
DESTRU-MOD 0.975
|
||||
DESTRU 1.362
|
||||
DIV2 3.150
|
||||
FFT-MOD 5.283
|
||||
FFT 32.133
|
||||
FPRINT 0.625
|
||||
FREAD 1.242
|
||||
FRPOLY 46.500
|
||||
PUZZLE-MOD 4.283
|
||||
PUZZLE 4.833
|
||||
STAK 1.771
|
||||
TAK-MOD 2.883
|
||||
TAK 3.783
|
||||
TAKL 1.317
|
||||
TAKR 0.504
|
||||
TPRINT 1.025
|
||||
TRAVERSE 25.533
|
||||
TRIANG-MOD 62.450
|
||||
TRIANG 77.800
|
||||
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For ecl Common Lisp
|
||||
sáb feb 26 09:58:33 CET 2000
|
||||
|
||||
BOYER 0.150
|
||||
CTAK 0.030
|
||||
DDERIV 0.090
|
||||
DERIV 0.080
|
||||
DESTRU-MOD 0.023
|
||||
DESTRU 0.025
|
||||
DIV2 0.070
|
||||
FFT-MOD 0.020
|
||||
FPRINT 0.023
|
||||
FREAD 0.038
|
||||
FRPOLY 15.560
|
||||
PUZZLE-MOD 0.090
|
||||
PUZZLE 0.090
|
||||
STAK 0.025
|
||||
TAK-MOD 0.050
|
||||
TAK 0.050
|
||||
TAKL 0.020
|
||||
TAKR 0.010
|
||||
TPRINT 0.035
|
||||
TRAVERSE 0.950
|
||||
TRIANG-MOD 0.000
|
||||
TRIANG 1.030
|
||||
-------------- SESSION ------------------
|
||||
|
||||
For gcl Common Lisp
|
||||
sáb feb 26 09:59:35 CET 2000
|
||||
|
||||
BOYER 0.140
|
||||
CTAK 0.040
|
||||
DDERIV 0.080
|
||||
DERIV 0.070
|
||||
DESTRU-MOD 0.018
|
||||
DESTRU 0.035
|
||||
DIV2 0.080
|
||||
FFT-MOD 0.020
|
||||
FFT 0.020
|
||||
FPRINT 0.015
|
||||
FREAD 0.018
|
||||
FRPOLY 3.160
|
||||
PUZZLE-MOD 0.080
|
||||
PUZZLE 0.100
|
||||
STAK 0.028
|
||||
TAK-MOD 0.050
|
||||
TAK 0.060
|
||||
TAKL 0.020
|
||||
TAKR 0.010
|
||||
TPRINT 0.025
|
||||
TRAVERSE 1.150
|
||||
TRIANG 1.150
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; TPRINT -- Benchmark to print and read to the terminal.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar 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 ((= m 0) (pop atoms))
|
||||
(t (do ((i n (the fixnum (- i 2)))
|
||||
(a ()))
|
||||
((< i 1) a)
|
||||
(push (pop atoms) a)
|
||||
(push (tprint-init-aux (the fixnum (1- m)) n atoms) a)))))
|
||||
|
||||
(defvar test-pattern (tprint-init 6. 6. test-atoms))
|
||||
|
||||
|
||||
(defun standard-tprint-test ()
|
||||
(print test-pattern))
|
||||
|
||||
(defun testtprint ()
|
||||
(print test-pattern))
|
||||
|
|
@ -1,151 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(eval-when (eval compile load)
|
||||
(defstruct node
|
||||
(parents ())
|
||||
(sons ())
|
||||
(sn (snb))
|
||||
(entry1 ())
|
||||
(entry2 ())
|
||||
(entry3 ())
|
||||
(entry4 ())
|
||||
(entry5 ())
|
||||
(entry6 ())
|
||||
(mark ()))
|
||||
)
|
||||
(defvar traverse-sn 0)
|
||||
(defvar traverse-rand 21.)
|
||||
(defvar traverse-count 0)
|
||||
(declaim (type fixnum traverse-sn traverse-rand traverse-count))
|
||||
(defvar traverse-marker nil)
|
||||
(defvar traverse-root)
|
||||
|
||||
(setq traverse-sn 0 traverse-rand 21 traverse-count 0 traverse-marker nil)
|
||||
|
||||
(defun snb ()
|
||||
(setq traverse-sn (the fixnum (1+ traverse-sn))))
|
||||
|
||||
(defun traverse-seed ()
|
||||
(setq traverse-rand 21.))
|
||||
|
||||
(defun traverse-random ()
|
||||
(setq traverse-rand
|
||||
(the fixnum (rem (the fixnum (* traverse-rand 17)) 251))))
|
||||
|
||||
(defun traverse-remove (n q)
|
||||
(declare (type fixnum n))
|
||||
(cond ((eq (cdr (car q)) (car q))
|
||||
(prog2 () (caar q) (rplaca q ())))
|
||||
((= n 0)
|
||||
(prog2 () (caar q)
|
||||
(do ((p (car q) (cdr p)))
|
||||
((eq (cdr p) (car q))
|
||||
(rplaca q
|
||||
(rplacd p (cdr (car q))))))))
|
||||
(t (do ((n n (the fixnum (1- n)))
|
||||
(q (car q) (cdr q))
|
||||
(p (cdr (car q)) (cdr p)))
|
||||
((= n 0) (prog2 () (car q) (rplacd q p)))
|
||||
(declare (type fixnum n))))))
|
||||
|
||||
(defun traverse-select (n q)
|
||||
(declare (type fixnum n))
|
||||
(do ((n n (the fixnum (1- n)))
|
||||
(q (car q) (cdr q)))
|
||||
((= n 0) (car q))
|
||||
(declare (type fixnum n))))
|
||||
|
||||
(defun traverse-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 traverse-create-structure (n)
|
||||
(declare (type fixnum n))
|
||||
(let ((a `(,(make-node))))
|
||||
(do ((m (the fixnum (1- n)) (the fixnum (1- m)))
|
||||
(p a))
|
||||
((= m 0) (setq a `(,(rplacd p a)))
|
||||
(do ((unused a)
|
||||
(used (traverse-add (traverse-remove 0 a) ()))
|
||||
(x) (y))
|
||||
((null (car unused))
|
||||
(find-root (traverse-select 0 used) n))
|
||||
(setq x (traverse-remove
|
||||
(the fixnum (rem (the fixnum (traverse-random)) n))
|
||||
unused))
|
||||
(setq y (traverse-select
|
||||
(the fixnum (rem (the fixnum (traverse-random)) n))
|
||||
used))
|
||||
(traverse-add x used)
|
||||
(setf (node-sons y) `(,x .,(node-sons y)))
|
||||
(setf (node-parents x) `(,y .,(node-parents x))) ))
|
||||
(declare (type fixnum m))
|
||||
(push (make-node) a))))
|
||||
|
||||
(defun find-root (node n)
|
||||
(declare (type fixnum n))
|
||||
(do ((n n (the fixnum (1- n))))
|
||||
((= n 0) node)
|
||||
(declare (type 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) ())
|
||||
(t (setf (node-mark node) mark)
|
||||
(setq traverse-count (the fixnum (1+ traverse-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 (traverse-root)
|
||||
(let ((traverse-count 0))
|
||||
(declare (type fixnum traverse-count))
|
||||
(travers traverse-root
|
||||
(setq traverse-marker (not traverse-marker)))
|
||||
traverse-count))
|
||||
|
||||
(defun init-traverse()
|
||||
(setq traverse-root (traverse-create-structure 100.))
|
||||
nil)
|
||||
|
||||
(defun run-traverse ()
|
||||
(do ((i 50 (the fixnum (1- (the fixnum i)))))
|
||||
((= (the fixnum i) 0))
|
||||
(declare (type fixnum i))
|
||||
(traverse traverse-root)
|
||||
(traverse traverse-root)
|
||||
(traverse traverse-root)
|
||||
(traverse traverse-root)
|
||||
(traverse traverse-root)))
|
||||
|
||||
(defun testtraverse ()
|
||||
(testtraverse-init)
|
||||
(testtraverse-run))
|
||||
|
||||
(defun testtraverse-init ()
|
||||
(init-traverse))
|
||||
|
||||
(defun testtraverse-run ()
|
||||
(run-traverse))
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; TRIANG -- Board game benchmark.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(defvar a)
|
||||
(defvar b)
|
||||
(defvar c)
|
||||
(defvar answer)
|
||||
(defvar final)
|
||||
|
||||
(eval-when (eval compile)
|
||||
(proclaim '(special board seq a b c))
|
||||
(proclaim '(special board seq a b c))
|
||||
(proclaim '(type (vector fixnum ) board))
|
||||
(proclaim '(type (vector fixnum ) seq))
|
||||
(proclaim '(type (vector fixnum ) a))
|
||||
(proclaim '(type (vector fixnum ) b))
|
||||
(proclaim '(type (vector fixnum ) c))
|
||||
(proclaim '(function triang-setup () t))
|
||||
(proclaim '(function last-position () fixnum))
|
||||
(proclaim '(function try (fixnum fixnum) t))
|
||||
(proclaim '(function simple-vector-to-list (t) t))
|
||||
(proclaim '(function gogogo (fixnum) t))
|
||||
(proclaim '(function testtriang () t)))
|
||||
|
||||
(defun triang-setup ()
|
||||
(setq board (make-array 16 :element-type 'fixnum :initial-element 1))
|
||||
(setq seq (make-array 14 :element-type 'fixnum :initial-element 0))
|
||||
(setq a
|
||||
(make-array
|
||||
37
|
||||
:element-type 'fixnum
|
||||
: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)))
|
||||
(setq b (make-array
|
||||
37
|
||||
:element-type 'fixnum
|
||||
: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)))
|
||||
(setq c (make-array
|
||||
37
|
||||
:element-type 'fixnum
|
||||
: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)))
|
||||
(setf (aref board 5) 0))
|
||||
|
||||
(defun last-position ()
|
||||
(do ((i 1 (the fixnum (+ i 1))))
|
||||
((= i 16) 0)
|
||||
(declare (fixnum i))
|
||||
(if (eq 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 :test #'eq)
|
||||
(push lp final)))
|
||||
;;; (format t "~&~s" (cdr (simple-vector-to-list seq)))
|
||||
(push (cdr (simple-vector-to-list seq))
|
||||
answer) t) ; this is a hack to replace LISTARRAY
|
||||
((and (eql 1 (aref board (aref a i)))
|
||||
(eql 1 (aref board (aref b i)))
|
||||
(eql 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 seq depth) i)
|
||||
(do ((j 0 (the fixnum (+ j 1)))
|
||||
(depth (the fixnum (+ depth 1))))
|
||||
((or (= j 36)
|
||||
(try j depth)) ())
|
||||
(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 simple-vector-to-list (seq)
|
||||
(do ((i (- (length seq) 1) (1- i))
|
||||
(res))
|
||||
((< i 0)
|
||||
res)
|
||||
(declare (fixnum i))
|
||||
(push (aref seq i) res)))
|
||||
|
||||
(defun gogogo (i)
|
||||
(let ((answer ())
|
||||
(final ()))
|
||||
(try i 1)))
|
||||
|
||||
(defun testtriang ()
|
||||
(triang-setup)
|
||||
(gogogo 22))
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; TRIANG -- Board game benchmark.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(proclaim '(special board sequence a b c))
|
||||
|
||||
(proclaim '(type (vector fixnum) a b c))
|
||||
(defmacro fref (v i) `(the fixnum (aref (the (vector fixnum) ,v) ,i)))
|
||||
|
||||
(defvar answer)
|
||||
(defvar final)
|
||||
|
||||
(defun triang-setup ()
|
||||
(setq board (make-array 16 :initial-element 1))
|
||||
(setq sequence (make-array 14 :initial-element 0))
|
||||
(setq a
|
||||
(make-array
|
||||
37
|
||||
:element-type 'fixnum :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)))
|
||||
(setq b (make-array
|
||||
37 :element-type 'fixnum :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)))
|
||||
(setq c (make-array
|
||||
37 :element-type 'fixnum :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)))
|
||||
(setf (svref board 5) 0))
|
||||
|
||||
|
||||
(defun last-position ()
|
||||
(do ((i 1 (the fixnum (+ i 1))))
|
||||
((= i 16) 0)
|
||||
(declare (fixnum i))
|
||||
(if (eq 1 (svref board i))
|
||||
(return i))))
|
||||
(proclaim '(function try (fixnum fixnum) t))
|
||||
(defun try (i depth)
|
||||
(declare (fixnum i depth))
|
||||
(cond ((= depth 14)
|
||||
(let ((lp (last-position)))
|
||||
(unless (member lp final :test #'eq)
|
||||
(push lp final)))
|
||||
(push (cdr (simple-vector-to-list sequence))
|
||||
answer) t) ; this is a hack to replace LISTARRAY
|
||||
((and (eq 1 (svref board (fref a i)))
|
||||
(eq 1 (svref board (fref b i)))
|
||||
(eq 0 (svref board (fref c i))))
|
||||
(setf (svref board (fref a i)) 0)
|
||||
(setf (svref board (fref b i)) 0)
|
||||
(setf (svref board (fref c i)) 1)
|
||||
(setf (svref sequence depth) i)
|
||||
(do ((j 0 (the fixnum (+ j 1)))
|
||||
(depth (the fixnum (+ depth 1))))
|
||||
((or (= j 36)
|
||||
(try j depth)) ())
|
||||
(declare (fixnum j depth)))
|
||||
(setf (svref board (fref a i)) 1)
|
||||
(setf (svref board (fref b i)) 1)
|
||||
(setf (svref board (fref c i)) 0) ())))
|
||||
|
||||
(defun simple-vector-to-list (seq)
|
||||
(do ((i (- (length seq) 1) (1- i))
|
||||
(res))
|
||||
((< i 0)
|
||||
res)
|
||||
(declare (fixnum i))
|
||||
(push (svref seq i) res)))
|
||||
|
||||
(defun gogogo (i)
|
||||
(let ((answer ())
|
||||
(final ()))
|
||||
(try i 1)))
|
||||
|
||||
(defun testtriang ()
|
||||
(triang-setup)
|
||||
(print (time (gogogo 22))))
|
||||
|
|
@ -1,77 +0,0 @@
|
|||
;; $Header$
|
||||
;; $Locker$
|
||||
|
||||
;;; TRIANG -- Board game benchmark.
|
||||
|
||||
(in-package "TESTING")
|
||||
|
||||
(declaim (special board seq a b c))
|
||||
(defvar answer)
|
||||
(defvar final)
|
||||
|
||||
(defun triang-setup ()
|
||||
(setq board (make-array 16 :initial-element 1))
|
||||
(setq seq (make-array 14 :initial-element 0))
|
||||
(setq 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)))
|
||||
(setq 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)))
|
||||
(setq 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)))
|
||||
(setf (svref board 5) 0))
|
||||
|
||||
(defun last-position ()
|
||||
(do ((i 1 (the fixnum (+ i 1))))
|
||||
((= i 16) 0)
|
||||
(declare (fixnum i))
|
||||
(if (eq 1 (svref board i))
|
||||
(return i))))
|
||||
|
||||
(defun try (i depth)
|
||||
(declare (fixnum i depth))
|
||||
(cond ((= depth 14)
|
||||
(let ((lp (last-position)))
|
||||
(unless (member lp final :test #'eq)
|
||||
(push lp final)))
|
||||
(push (cdr (simple-vector-to-list seq))
|
||||
answer) t) ; this is a hack to replace LISTARRAY
|
||||
((and (eq 1 (svref board (svref a i)))
|
||||
(eq 1 (svref board (svref b i)))
|
||||
(eq 0 (svref board (svref c i))))
|
||||
(setf (svref board (svref a i)) 0)
|
||||
(setf (svref board (svref b i)) 0)
|
||||
(setf (svref board (svref c i)) 1)
|
||||
(setf (svref seq depth) i)
|
||||
(do ((j 0 (the fixnum (+ j 1)))
|
||||
(depth (the fixnum (+ depth 1))))
|
||||
((or (= j 36)
|
||||
(try j depth)) ())
|
||||
(declare (fixnum j depth)))
|
||||
(setf (svref board (svref a i)) 1)
|
||||
(setf (svref board (svref b i)) 1)
|
||||
(setf (svref board (svref c i)) 0) ())))
|
||||
|
||||
(defun simple-vector-to-list (seq)
|
||||
(do ((i (- (length seq) 1) (1- i))
|
||||
(res))
|
||||
((< i 0)
|
||||
res)
|
||||
(declare (fixnum i))
|
||||
(push (svref seq i) res)))
|
||||
|
||||
(defun gogogo (i)
|
||||
(let ((answer ())
|
||||
(final ()))
|
||||
(try i 1)))
|
||||
|
||||
(defun testtriang ()
|
||||
(triang-setup)
|
||||
(gogogo 22))
|
||||
Loading…
Add table
Add a link
Reference in a new issue