Sorting algorithms written in Common Lisp

sort.lisp

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :alexandria)
  (ql:quickload :fiveam))

(defpackage :sort
  (:use :cl)
  (:import-from :alexandria :iota)
  (:export :bubble-sort/naive :bubble-sort/not-enough :bubble-sort/knuth
           :selection-sort :insertion-sort :shellsort/tokuda-1992
           :shellsort/knuth-1973))
(in-package :sort)

(defun bubble-sort/naive (sequence)
  (let ((end (length sequence)))
    (labels ((compare-and-swap (index modified)
               (if (= index (1- end))
                   (if modified (compare-and-swap 0 nil) (values))
                   (let ((index+1 (1+ index)))
                     (if (> (elt sequence index) (elt sequence index+1))
                         (let ((x (elt sequence index)))
                           (setf (elt sequence index) (elt sequence index+1)
                                 (elt sequence index+1) x)
                           (compare-and-swap index+1 t))
                         (compare-and-swap index+1 modified))))))
      (unless (< end 2)
        (compare-and-swap 0 nil))
      sequence)))

(defun bubble-sort/not-enough (sequence)
  (labels ((compare-and-swap (index end)
             (cond ((= end 0) (values))
                   ((= index end) (compare-and-swap 0 (1- end)))
                   (t
                    (let ((index+1 (1+ index)))
                      (when (> (elt sequence index) (elt sequence index+1))
                        (let ((x (elt sequence index)))
                          (setf (elt sequence index) (elt sequence index+1)
                                (elt sequence index+1) x)))
                      (compare-and-swap index+1 end))))))
    (let ((end (length sequence)))
      (unless (< end 2)
        (compare-and-swap 0 (1- end)))
      sequence)))

(defun bubble-sort/knuth (sequence)
  (labels ((compare-and-swap (index end next-end)
             (cond ((= end 0) (values))
                   ((= index end) (compare-and-swap 0 next-end 0))
                   (t
                    (let ((index+1 (1+ index)))
                      (if (> (elt sequence index) (elt sequence index+1))
                          (let ((x (elt sequence index)))
                            (setf (elt sequence index) (elt sequence index+1)
                                  (elt sequence index+1) x)
                            (compare-and-swap index+1 end index))
                          (compare-and-swap index+1 end next-end)))))))
    (let ((end (length sequence)))
      (unless (< end 2)
        (compare-and-swap 0 (1- end) 0))
      sequence)))

(defun selection-sort (sequence)
  (let ((end (length sequence)))
    (labels ((position-of-minimum (index minimum result)
               (if (= index end)
                   result
                   (let ((x (elt sequence index)))
                     (if (< x minimum)
                         (position-of-minimum (1+ index) x index)
                         (position-of-minimum (1+ index) minimum result)))))
             (select-and-swap (start)
               (if (= start end)
                   (values)
                   (let* ((x (elt sequence start))
                          (position (position-of-minimum start x start)))
                     (if (= position start)
                         (select-and-swap (1+ start))
                         (progn
                           (setf (elt sequence start) (elt sequence position)
                                 (elt sequence position) x)
                           (select-and-swap (1+ start))))))))
      (unless (< end 2)
        (select-and-swap 0))
      sequence)))

(defun insertion-sort (sequence)
  (let ((end (length sequence)))
    (labels ((insert (x index)
               (if (minusp index)
                   (setf (elt sequence (1+ index)) x)
                   (let ((y (elt sequence index)))
                     (if (< x y)
                         (progn
                           (setf (elt sequence (1+ index)) y)
                           (insert x (1- index)))
                         (setf (elt sequence (1+ index)) x)))))
             (repeat-insertion (start)
               (if (= start end)
                   (values)
                   (progn
                     (insert (elt sequence start) (1- start))
                     (repeat-insertion (1+ start))))))
      (unless (< end 2)
        (repeat-insertion 1))
      sequence)))

(defun shellsort (gap-sequence-fn sequence)
  (let ((len (length sequence)))
    (unless (< len 2)
      (mapc (lambda (gap)
              (labels ((insert (x index)
                         (if (minusp index)
                             (setf (elt sequence (+ index gap)) x)
                             (let ((y (elt sequence index)))
                               (if (< x y)
                                   (progn
                                     (setf (elt sequence (+ index gap)) y)
                                     (insert x (- index gap)))
                                   (setf (elt sequence (+ index gap)) x)))))
                       (repeat-insertion (index)
                         (if (>= index len)
                             (values)
                             (progn
                               (insert (elt sequence index) (- index gap))
                               (repeat-insertion (+ index gap)))))
                       (h-sorting (h)
                         (if (zerop h)
                             (values)
                             (progn
                               (repeat-insertion (1- (+ h gap)))
                               (h-sorting (1- h))))))
                (h-sorting gap)))
            (funcall gap-sequence-fn len)))
    sequence))

(defun term/knuth-1973 (k)
  (/ (1- (expt 3 k)) 2))

(let* ((seq (mapcar #'term/knuth-1973 (iota 10 :start 10 :step -1)))
       (len (length seq)))
  (defun gap-sequence/knuth-1973 (n)
    (let ((max (ceiling (/ n 3))))
      (if (< max (car seq))
          (member-if (lambda (x) (or (= x 1) (<= x max))) seq)
          (let ((next-term (term/knuth-1973 (1+ len))))
            (push next-term seq)
            (incf len)
            (if (< next-term max)
                (gap-sequence/knuth-1973 n)
                (cdr seq)))))))

(defun shellsort/knuth-1973 (sequence)
  (shellsort #'gap-sequence/knuth-1973 sequence))

(defun term/tokuda-1992 (k)
  (ceiling (/ (- (expt 9 k) (expt 4 k)) (* 5 (expt 4 (1- k))))))

(let* ((seq (mapcar #'term/tokuda-1992 (iota 10 :start 10 :step -1)))
       (len (length seq)))
  (defun gap-sequence/tokuda-1992 (n)
    (if (< n (car seq))
        (member-if (lambda (x) (or (< x n) (= x 1))) seq)
        (let ((next-term (term/tokuda-1992 (1+ len))))
          (push next-term seq)
          (incf len)
          (if (< next-term n)
              (gap-sequence/tokuda-1992 n)
              (cdr seq))))))

(defun shellsort/tokuda-1992 (sequence)
  (shellsort #'gap-sequence/tokuda-1992 sequence))

(defpackage :sort.test (:use :cl :sort))
(in-package :sort.test)

(5am:test array
  (flet ((f (expected src)
           (do-external-symbols (s :sort)
             (5am:is (equalp expected (funcall s src))))))
    (f #() #())
    (f #(5) #(5))
    (f #(2 5) #(5 2))
    (f #(1 2 4 5 8) #(5 1 4 2 8))
    (f #(0 1 2 4 5) #(5 1 4 2 0))
    (f #(1 2 3 4 5) #(1 2 3 4 5))
    (f #(0 1 2 2 5) #(5 2 1 2 0))
    (f #(11 12 22 25 64) #(64 25 12 22 11))))

(defpackage :sort.time (:use :cl :sort))
(in-package :sort.time)

(defparameter *limit* 10000)
(defparameter *sequence-size* 10000)

(defun measure-algorithm-speed ()
  (labels ((body (src)
             (do-external-symbols (fn :sort)
               (let ((seq (copy-seq src)))
                 (print fn)
                 (time (funcall fn seq)))))
           (array ()
             (format t "~&Array~%=====~%")
             (let ((src (make-array *sequence-size*)))
               (map-into src
                         (lambda (_)
                           (declare (ignore _))
                           (random *limit* (make-random-state t)))
                         src)
               (body src))))
    (array)))