Commit 399189fe authored by ram's avatar ram

Initial revision

parent b4d8e8d3
This diff is collapsed.
This diff is collapsed.
(in-package "USER")
;;; CTAK -- A version of the TAKeuchi function that uses the CATCH/THROW facility.
(defun ctak (x y z)
(declare (fixnum 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 time-ctak ()
(time (ctak 18 12 6)))
(in-package "USER")
(proclaim '(optimize (safety 0) (speed 3) (space 0)))
;;; FFT -- This is an FFT benchmark written by Harry Barrow. It tests a
;;; variety of floating point operations, including array references.
(defvar re (make-array 1025. :element-type 'single-float :initial-element 0.0))
(defvar im (make-array 1025. :element-type 'single-float :initial-element 0.0))
;areal = real part
;aimag = imaginary part
(defun fft (areal aimag)
(declare (type (simple-array single-float (1025)) areal aimag))
(prog ((ar areal)
(ai aimag)
(i 0)
(j 0)
(k 0)
(m 0)
(n 0)
(le 0)
(le1 0)
(ip 0)
(nv2 0)
(ur 0.0)
(ui 0.0)
(wr 0.0)
(wi 0.0)
(tr 0.0)
(ti 0.0))
(declare (fixnum i j k m n le le1 ip nv2)
(single-float ur ui wr wi tr ti))
(setq n (array-dimension ar 0)
n (1- n)
nv2 (floor n 2)
m 0 ;compute m = log(n)
i 1)
l1 (cond ((< i n)
(setq m (1+ m)
i (+ i i))
(go l1)))
(cond ((not (equal n (expt 2 m)))
(princ "error ... array size not a power of two.")
(read)
(return (terpri))))
(setq j 1 ;interchange elements
i 1) ;in bit-reversed order
l3 (cond ((< i j)
(setq tr (aref ar j)
ti (aref ai j))
(setf (aref ar j) (aref ar i))
(setf (aref ai j) (aref ai i))
(setf (aref ar i) tr)
(setf (aref ai i) ti)))
(setq k nv2)
l6 (cond ((< k j)
(setq j (- j k)
k (/ k 2))
(go l6)))
(setq j (+ j k)
i (1+ i))
(cond ((< i n)
(go l3)))
(do ((l 1 (1+ l)))
((> l m)) ;loop thru stages
(declare (fixnum l))
(setq le (expt 2 l)
le1 (floor le 2)
ur 1.0
ui 0.0
wr (cos (/ 3.14159265 (float le1)))
wi (sin (/ 3.14159265 (float le1))))
(do ((j 1 (1+ j)))
((> j le1)) ;loop thru butterflies
(declare (fixnum j))
(do ((i j (+ i le)))
((> i n)) ;do a butterfly
(declare (fixnum i))
(setq ip (+ i le1)
tr (- (* (aref ar ip) ur)
(* (aref ai ip) ui))
ti (+ (* (aref ar ip) ui)
(* (aref ai ip) ur)))
(setf (aref ar ip) (- (aref ar i) tr))
(setf (aref ai ip) (- (aref ai i) ti))
(setf (aref ar i) (+ (aref ar i) tr))
(setf (aref ai i) (+ (aref ai i) ti))))
(setq tr (- (* ur wr) (* ui wi))
ti (+ (* ur wi) (* ui wr))
ur tr
ui ti))
(return t)))
(defmacro fft-bench ()
'(do ((ntimes 0 (1+ ntimes)))
((= ntimes 10.))
(declare (fixnum ntimes))
(fft re im)))
(defun time-fft ()
(time (fft-bench)))
# define size 511
# define classMax 3
# define typeMax 12
# define d 8
# define true 1
# define false 0
static int class[typeMax+1];
static int pieceCount[classMax+1];
static int pieceMax[typeMax+1];
static int puzzle[size+1];
static int p[typeMax+1][size+1];
static int kount,clock;
fit(i,j)
int i,j;
{
register k,plim;
plim = pieceMax[i];
for (k=0; k <= plim; k++)
{
if (p[i][k])
{
if (puzzle[j+k]) return (false);
}
}
return(true);
}
int place (i,j)
int i,j;
{
register k,plim;
plim = pieceMax[i];
for (k = 0; k <= plim; k++)
if (p[i][k]) puzzle[j+k] = true;
pieceCount[class[i]] = pieceCount[class[i]] - 1;
for (k=j; k <= size; k++)
if (!puzzle[k])
{
return(k);
}
printf("Puzzle filled.\n");
return(0);
}
remove(i,j)
int i,j;
{
register k,plim;
plim = pieceMax[i];
for (k=0; k<=plim; k++)
if (p[i][k]) puzzle[j+k] = false;
pieceCount[class[i]] = pieceCount[class[i]] + 1;
}
trial(j)
int j;
{
register i,k;
for (i = 0; i <= typeMax; i++)
if (pieceCount[class[i]] != 0)
if (fit (i, j))
{
k = place (i, j);
if (trial(k)||(k == 0))
{
/* printf("piece %d at %d\n",i+1,k+1); */
kount = kount + 1;
return(true);
}
else remove (i, j);
}
kount = kount + 1;
return(false);
}
main()
{
register i,j,k,m,n;
/* printf("starting\n"); */
for (m = 0; m<=size; m++)
puzzle[m] = true;
for (i=1; i <= 5; i++)
for (j=1; j<=5; j++)
for (k=1; k<=5 ; k++)
puzzle[i+d*(j+d*k)] = false;
for (i=0;i<=typeMax;i++)
for (j=0;j<=size;j++)
p[i][j] = false;
for (i=0;i<=3;i++)
for (j=0;j<=1;j++)
for (k = 0;k<=0;k++)
p[0][i+d*(j+d*k)] = true;
class[0] = 0;
pieceMax[0] = 3+d*1+d*d*0;
for (i=0;i<=1;i++)
for (j=0;j<=0;j++)
for (k=0;k<=3;k++)
p[1][i+d*(j+d*k)] = true;
class[1] = 0;
pieceMax[1] = 1+d*0+d*d*3;
for (i=0;i<=0;i++)
for (j=0;j<=3;j++)
for (k=0;k<=1;k++)
p[2][i+d*(j+d*k)] = true;
class[2] = 0;
pieceMax[2] = 0+d*3+d*d*1;
for (i=0;i<=1;i++)
for (j=0;j<=3;j++)
for (k=0;k<=0;k++)
p[3][i+d*(j+d*k)] = true;
class[3] = 0;
pieceMax[3] = 1+d*3+d*d*0;
for (i=0;i<=3;i++)
for (j=0;j<=0;j++)
for (k=0;k<=1;k++)
p[4][i+d*(j+d*k)] = true;
class[4] = 0;
pieceMax[4] = 3+d*0+d*d*1;
for (i=0;i<=0;i++)
for (j=0;j<=1;j++)
for (k=0;k<=3;k++)
p[5][i+d*(j+d*k)] = true;
class[5] = 0;
pieceMax[5] = 0+d*1+d*d*3;
for (i=0;i<=2;i++)
for (j=0;j<=0;j++)
for (k=0;k<=0;k++)
p[6][i+d*(j+d*k)] = true;
class[6] = 1;
pieceMax[6] = 2+d*0+d*d*0;
for (i=0;i<=0;i++)
for (j=0;j<=2;j++)
for (k=0;k<=0;k++)
p[7][i+d*(j+d*k)] = true;
class[7] = 1;
pieceMax[7] = 0+d*2+d*d*0;
for (i=0;i<=0;i++)
for (j=0;j<=0;j++)
for (k=0;k<=2;k++)
p[8][i+d*(j+d*k)] = true;
class[8] = 1;
pieceMax[8] = 0+d*0+d*d*2;
for (i=0;i<=1;i++)
for (j=0;j<=1;j++)
for (k=0;k<=0;k++)
p[9][i+d*(j+d*k)] = true;
class[9] = 2;
pieceMax[9] = 1+d*1+d*d*0;
for (i=0;i<=1;i++)
for (j=0;j<=0;j++)
for (k=0;k<=1;k++)
p[10][i+d*(j+d*k)] = true;
class[10] = 2;
pieceMax[10] = 1+d*0+d*d*1;
for (i=0;i<=0;i++)
for (j=0;j<=1;j++)
for (k=0;k<=1;k++)
p[11][i+d*(j+d*k)] = true;
class[11] = 2;
pieceMax[11] = 0+d*1+d*d*1;
for (i=0;i<=1;i++)
for (j=0;j<=1;j++)
for (k=0;k<=1;k++)
p[12][i+d*(j+d*k)] = true;
class[12] = 3;
pieceMax[12] = 1+d*1+d*d*1;
pieceCount[0] = 13;
pieceCount[1] = 3;
pieceCount[2] = 1;
pieceCount[3] = 1;
m = 1+d*(1+d*1);
kount = 0;
if (fit(0, m))
{
n = place(0, m) ;
}
else
{
printf("error 1\n");
}
/* printf("n = %d n\n",n); */
if (trial(n))
{
printf("success in %d trials\n", kount);
}
else
{
printf("failure\n");
}
/* printf("elapsed user time:\n"); */
}
;;;; -*- Mode: Lisp; Package: User -*-
;;;;
(in-package "USER")
(proclaim '(optimize (safety 0) (speed 3)))
;;; PUZZLE -- Forest Baskett's Puzzle benchmark, originally written in Pascal.
(defconstant size 511)
(defconstant classmax 3)
(defconstant typemax 12)
(defvar iii 0)
(defvar kount 0)
(defconstant dee 8)
(proclaim '(type fixnum size classmax typemax iii kount dee))
(defvar piececount (make-array (1+ classmax) :initial-element 0))
(defvar class (make-array (1+ typemax) :initial-element 0))
(defvar piecemax (make-array (1+ typemax) :initial-element 0))
(defvar puzzle (make-array (1+ size)))
(defvar p (make-array (list (1+ typemax) (1+ size))))
(proclaim '(type simple-vector piececount class piecemax puzzle))
(defun fit (i j)
(declare (fixnum i j))
(let ((end (svref piecemax i)))
(do ((k 0 (1+ k)))
((> k end) t)
(declare (fixnum k))
(cond ((aref p i k)
(cond ((svref puzzle (+ j k))
(return nil))))))))
(defun place (i j)
(declare (fixnum i j))
(let ((end (svref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(declare (fixnum k))
(cond ((aref p i k)
(setf (svref puzzle (+ j k)) t))))
(setf (svref piececount (svref class i))
(- (svref piececount (svref class i)) 1))
(do ((k j (1+ k)))
((> k size)
; (terpri)
; (princ "Puzzle filled")
0)
(declare (fixnum k))
(cond ((not (svref puzzle k))
(return k))))))
(defun puzzle-remove (i j)
(declare (fixnum i j))
(let ((end (svref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(declare (fixnum k))
(cond ((aref p i k)
(setf (svref puzzle (+ j k)) nil))))
(setf (svref piececount (svref class i))
(+ (svref piececount (svref class i)) 1))))
(defun trial (j)
(declare (fixnum j))
(let ((k 0))
(declare (fixnum k))
(do ((i 0 (1+ i)))
((> i typemax) (setq kount (1+ kount)) nil)
(declare (fixnum i))
(cond ((not (= (svref piececount (svref class i)) 0))
(cond ((fit i j)
(setq k (place i j))
(cond ((or (trial k)
(= k 0))
; (format t "~%Piece ~4D at ~4D." (+ i 1) (+ k 1))
(setq kount (+ kount 1))
(return t))
(t (puzzle-remove i j))))))))))
(defun definepiece (iclass ii jj kk)
(declare (fixnum ii jj kk))
(let ((index 0))
(do ((i 0 (1+ i)))
((> i ii))
(declare (fixnum i))
(do ((j 0 (1+ j)))
((> j jj))
(declare (fixnum j))
(do ((k 0 (1+ k)))
((> k kk))
(declare (fixnum k))
(setq index (+ i (* dee (+ j (* dee k)))))
(setf (aref p iii index) t))))
(setf (svref class iii) iclass)
(setf (svref piecemax iii) index)
(cond ((not (= iii typemax))
(setq iii (+ iii 1))))))
(defun puzzle ()
(do ((m 0 (1+ m)))
((> m size))
(declare (fixnum m))
(setf (svref puzzle m) t))
(do ((i 1 (1+ i)))
((> i 5))
(declare (fixnum i))
(do ((j 1 (1+ j)))
((> j 5))
(declare (fixnum j))
(do ((k 1 (1+ k)))
((> k 5))
(declare (fixnum k))
(setf (svref puzzle (+ i (* dee (+ j (* dee k))))) nil))))
(do ((i 0 (1+ i)))
((> i typemax))
(declare (fixnum i))
(do ((m 0 (1+ m)))
((> m size))
(declare (fixnum m))
(setf (aref p i m) nil)))
(setq iii 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definePiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(setf (svref pieceCount 0) 13.)
(setf (svref pieceCount 1) 3)
(setf (svref pieceCount 2) 1)
(setf (svref pieceCount 3) 1)
(let ((m (+ 1 (* dee (+ 1 dee))))
(n 0)
(kount 0))
(declare (fixnum m n kount))
(cond ((fit 0 m) (setq n (place 0 m)))
(t
(write-string "
Error.")))
(cond ((trial n)
(write-string "
Success in ")
(print kount)
(write-string " trials."))
(t
(write-string "
Failure.")
))))
(defun time-puzzle ()
(time (puzzle)))
;;; TAK -- A vanilla version of the TAKeuchi function.
(in-package "USER")
(proclaim '(optimize (speed 1) (safety 1) (brevity 0)))
(defun tak (x y z)
(declare (fixnum x y z))
(if (not (< y x))
z
(tak (tak (the fixnum (1- x)) y z)
(tak (the fixnum (1- y)) z x)
(tak (the fixnum (1- z)) x y))))
(defun time-tak ()
(time (tak 18 12 6)))
(proclaim '(optimize (speed 3) (safety 0)))
(defun fast-tak (x y z)
(declare (fixnum x y z))
(if (not (< y x))
z
(fast-tak (fast-tak (the fixnum (1- x)) y z)
(fast-tak (the fixnum (1- y)) z x)
(fast-tak (the fixnum (1- z)) x y))))
(defun time-fast-tak ()
(time (fast-tak 18 12 6)))
;;; TRIANG -- Board game benchmark.
(defvar board (make-array 16. :initial-element 1))
(setf (aref board 5) 0)
(defvar sequence (make-array 14. :initial-element 0))
(defvar a (make-array 37. :initial-contents '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4 7 11 8 12
13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6 6)))
(defvar b (make-array 37. :initial-contents '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5 5)))
(defvar c (make-array 37. :initial-contents '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4 4)))
(defvar answer)
(defvar final)
(proclaim '(type simple-vector board sequence a b c))
(defun last-position ()
(do ((i 1 (1+ i)))
((= i 16.) 0)
(declare (fixnum i))
(if (= 1 (the fixnum (aref board i)))
(return i))))
(defun try (i depth)
(declare (fixnum i depth))
(cond ((= depth 14)
(let ((lp (last-position)))
(unless (member lp final)
(push lp final)))
(push (cdr (coerce (the simple-vector sequence) 'list))
answer) t) ; this is a hack to replace LISTARRAY
((and (= 1 (the fixnum (aref board (aref a i))))
(= 1 (the fixnum (aref board (aref b i))))