(defparameter re (make-array 1025 :initial-element 0.0))
(defparameter im (make-array 1025 :initial-element 0.0))

#+kcl
(defmacro while (cond &rest body)
   `(do ()
        ((not ,cond))
	. ,body))

(defun fft (areal aimag)
   (let (ar ai i j k m n le le1 ip nv2 nm1 ur ui wr wi tr ti)
      (declare (type float ur ui wr wi tr ti)
;	       (type float-vector ar ai)
	       (type fixnum i j m n ip nv2 nm1 le1))
      ;; initialize
      (setq ar areal
	    ai aimag
	    n (length ar)
	    n (1- n)
	    nv2 (floor (/ n 2))
	    nm1 (1- n)
	    m 0
	    i 1)

      (while (< i n) (setq m (1+ m) i (+ i i)))
      (when (not (equal n (expt 2 m)))
	 (error "array size is not a power of 2"))
      ;; interchange elements in bit-reversal order
      (setq j 1 i 1)
      (while (< i n)
	 (when (< 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)
	 (while (< k j)
	    (setq j (- j k)  k (/ k 2)))
	 (setq j (+ j k)  i (1+ i))
	 )
      (format t "n=~d~%" n)
      (do ((l 1 (1+ l)))
	  ((> l m))
	  (setq le (expt 2 l)
		le1 (floor (/ le 2))
		ur  1.0
		ui  0.0
		wr  (cos (/ pi (float le1)))
		wi  (sin (/ pi (float le1))))
	  ;; repeat butterflies
	  (do ((j 1 (1+ j)))
	      ((> j le1))
	      ;; do a butterfly
	      (do ((i j (+ i le)))
		  ((> i n))
		  (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))
      t))

(defmacro fft-bench ()
   `(dotimes (i 10) (fft re im)))

(defun  deriv-aux (a) (list '/ (deriv a) a))

(defun deriv (a)
  (cond
     ((atom a)
	(cond ((eq a 'x) 1) (t 0)))
     ((eq (car a) '+)
	(cons '+ (mapcar #'deriv (cdr a))))
     ((eq (car a) '-)
	(cons '- (mapcar #'deriv (cdr a))))
     ((eq (car a) '*)
	(list '*
	      a
	      (cons '+ (mapcar #'deriv-aux (cdr a)))))
     ((eq (car a) '/)
	(list '-
	      (list '/
		    (deriv (cadr a))
		    (caddr a))
	      (list '/
		    (cadr a)
		    (list '*
			  (caddr a)
			  (caddr a)
			  (deriv (caddr a))))))
     (t 'error)))

(defun run ()
  (dotimes (i 1000.)
      (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))))

;;;
;;; PUZZLE
;;;
(eval-when (compile load eval)
   (defconstant size 511)
   (defconstant classmax 3)
   (defconstant typemax 12))
(defvar *iii* 0)
(defvar *kount* 0)
(defvar *d* 8.)
(defvar piececount (make-array (1+ classmax) :initial-element 0))
(defvar class (make-array (1+ typemax) :initial-element 0))
(defvar piecemax (make-array (1+ typemax) :initial-element 0))
(defvar puzzle (make-array (1+ size)))
(defvar p (make-array (list (1+ typemax) (1+ size))))
(defun fit (i j)
   (let ((end (aref piecemax i)))
      (do ((k 0 (1+ k)))
	  ((> k end) t)
	(cond ((aref p i k)
		(cond ((aref puzzle (+ j k))
		       (return nil))))))))

(defun place (i j)
   (let ((end (aref piecemax i)))
      (do (( k 0 (1+ k)))
	  ((> k end))
	(cond ((aref p i k)
	       (setf (aref puzzle (+ j k)) t))))
      (setf (aref piececount (aref class i))
	    (- (aref piececount (aref class i)) 1))
      (do ((k j (1+ k)))
	  ((> k size) (print "Puzzle filled") 0)
	(unless (aref puzzle k) (return k)))))

(defun puzzle-remove (i j)
  (let ((end (aref piecemax i)))
      (do ((k 0 (1+ k)))
	  ((> k end))
	(cond ((aref p i k)
		(setf (aref puzzle (+ j k)) nil))))
      (setf (aref piececount (aref class i))
	    (+ (aref piececount (aref class i)) 1))))

(defun trial (j)
   (let ((k 0) (hhh))
      (do ((i 0 (1+ i)))
	  ((> i typemax) (setq *kount* (1+ *kount*)) nil)
	(cond ((not (= (aref piececount (aref class i)) 0))
		(cond
		  ((fit i j)
		   (setq k (place i j))
;		   (print k)
		   (cond
			((or (setq hhh  (trial k)) (= k 0)) 
			 (format t "~%Piece ~4d at ~4d kount=~4d k=~d trial=~a."
					 (+ i 1) (+ k 1) (incf *kount*) k  hhh)
			 (return-from trial t))
			(t (puzzle-remove i j))))))))))	

(defun definepiece (iclass ii jj kk)
   (let ((index 0))
      (do ((i 0 (1+ i)))
	  ((> i ii))
	(do ((j 0 (1+ j)))
	    ((> j jj))
	   (do ((k 0 (1+ k)))
	        ((> k kk))
	      (setq index (+ i (* *d* (+ j (* *d* k)))))
	      (setf (aref p *iii* index) t))))
      (setf (aref class *iii*) iclass)
      (setf (aref piecemax *iii*) index)
      (cond ((not (= *iii* typemax))
	     (setq *iii* (+ *iii* 1))))))

(defun start ()
   (do ((m 0 (1+ m)))
       ((> m size))
      (setf (aref puzzle m) t))
   (do ((i 1 (1+ i)))
       ((> i 5))
     (do ((j 1 (1+ j)))
	 ((> j 5))
       (do ((k 1 (1+ k)))
	   ((> k 5))
	 (setf (aref puzzle (+ i (* *d* (+ j (* *d* k)))))
	       nil))))
   (do ((i 0 (1+ i)))
       ((> i typemax))
     (do ((m 0 (1+ m)))
	 ((> m size ))
	(setf (aref p i m) nil)))
   (setq *iii* 0)
   (definepiece 0 3 1 0)
   (definepiece 0 1 0 3)
   (definepiece 0 0 3 1)
   (definepiece 0 1 3 0)
   (definepiece 0 3 0 1)
   (definepiece 0 0 1 3)
   (definepiece 1 2 0 0)
   (definepiece 1 0 2 0)
   (definepiece 1 0 0 2)
   (definepiece 2 1 1 0)
   (definepiece 2 1 0 1)
   (definepiece 2 0 1 1)
   (definepiece 3 1 1 1)
   (setf (aref piececount 0) 13.)
   (setf (aref piececount 1) 3)
   (setf (aref piececount 2) 1)
   (setf (aref piececount 3) 1)
   (let ((m (+ 1 (* *d* (1+ *d*))))
	 (n 0) (*kount* 0))
      (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.")))))

