Skip to content

Instantly share code, notes, and snippets.

@llibra llibra/sort.lisp
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
You can’t perform that action at this time.