Skip to content

Instantly share code, notes, and snippets.

@llibra
Created Jun 18, 2012
Embed
What would you like to do?
Sorting algorithms written in Common 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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment