[Shootout-list] fannkuch in Lisp

[Dima Dorfman]

--sdtB3X0nJg68CQEu
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

Attached is a Lisp implementation of fannkuch. Type declarations
present where appropriate. Tested only on CMLCL, but the argument
handling is copied from takfp, so it presumably works on SBCL and GCJ
too.

Dima.

--sdtB3X0nJg68CQEu
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="fannkuch.lisp"

;;; fannkuch benchmark for The Computer Language Shootout
;;; Written by Dima Dorfman, 2005

(defun swap! (a i j)
  (let ((temp (aref a i)))
    (setf (aref a i) (aref a j))
    (setf (aref a j) temp)))

(defun reverse-slice! (a i j)
  (declare
   (type (simple-array (unsigned-byte 8)) a)
   (type fixnum i j))
  (when (< i j)
    (swap! a i (1- j))
    (reverse-slice! a (1+ i) (1- j))))

(defun count-flips (p)
  (let ((p (copy-seq p)))
    (loop until (= (aref p 0) 1)
	  do (reverse-slice! p 0 (aref p 0))
	  count t)))

(defun folding-flips (z p)
  (declare (type fixnum z))
  (max (count-flips p) z))

(defun fold-permutations (f z n)
  (declare (type (unsigned-byte 8) n))
  (let ((p (make-array (list n) :element-type '(unsigned-byte 8)
		       :initial-contents (loop for i from 1 to n collect i))))
    (labels ((another (z)
	       (let ((i (loop for i from (- n 2) downto 0
			      when (> (aref p (1+ i)) (aref p i)) return i)))
		 (if (null i)
		     z
		   (let ((j (loop for j from (1- n) downto 0
				  when (> (aref p j) (aref p i)) return j)))
		     (swap! p i j)
		     (reverse-slice! p (1+ i) n)
		     (another (funcall f z p)))))))
      (another z))))

(defun fannkuch (n)
  (fold-permutations #'folding-flips 0 n))

(defun main ()
  (let* ((args #+sbcl sb-ext:*posix-argv*
	       #+cmu extensions:*command-line-strings*
	       #+gcl si::*command-args*)
	 (n (parse-integer (car (last args)))))
    (format t "fannkuck(~d) = ~d~%" n (fannkuch n))))

--sdtB3X0nJg68CQEu--