;;; -*- mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/shiva-0/RCS/shell.lisp,v 395.1 2008/04/20 17:25:51 gene Exp $
;;;
;;; Shell sort in Lisp
;;;

(defvar *sedgewick-sequence* 
  (delete-duplicates
   (sort
    (loop for i from 0 to 5
	  collect (+ (* 9 (expt 4 i)) (* -9 (expt 2 i)) 1)
	  collect (+ (expt 4 i) (* 3 (expt 2 i)) 1))
    #'>)))

(defun shell-ksort (ar lessp copyfn k)
  (let ((len (length ar)))
    (do ((i k (1+ i)))
	((>= i len) ar)
	(funcall copyfn)                ; for the let tmp we're about to do
	(let ((tmp (aref ar i)))
	  (funcall copyfn)              ; for the next setf
	  (setf (aref ar (do ((j i (- j k)))
			     ((or (< j k)
				  (funcall lessp
					   (aref ar (- j k))
					   tmp))
			      j)
                             (funcall copyfn) ; for the next setf
			     (setf (aref ar j)
				   (aref ar (- j k)))))
		tmp)))))

(defun shell-sort (ar lessp &optional copyfn (sequence *sedgewick-sequence*))
  (when (null copyfn)
    (setq copyfn #'(lambda () nil)))
  (loop for i in sequence
	do (shell-ksort ar lessp copyfn i))
  ar)

;;;
;;; Returns the cost of sorting the array using Shell
;;; sort with the indicated sequence.  The array itself
;;; is not altered.
;;;
(defun cost-of-sequence (increments arr)
  (let ((count 0))
    (shell-sort (copy-seq arr)
		#'(lambda (x y) (incf count) (< x y)) ; lessp
		#'(lambda () (incf count))            ; copy-fn
		increments)
    count))

;;; --- end of file ---