Some Sorting Methods in Scheme

sorting.scm

;; Uncomment the following line to run in racket.
;; #lang scheme/base

;;;;
;;;; A series of sorting algorimthms implemented in Scheme. The work in this
;;;; gist was inspired by the article "8 Must-Know Sorting Algorithms" by
;;;; Mangabo Kolawole at
;;;; https://dev.to/koladev/8-must-know-sorting-algorithms-5ja
;;;;
;;;; All of the examples shown here are non-destructive, that is, they leave
;;;; the original data (a list of random integers) intact and return the
;;;; sorted version as a new list.
;;;;
;;;; I have strived for ease of understanding rather than efficiency or
;;;; conciseness. All versions sort into ascending order. No optimizations.
;;;; No attempt to fix known weaknesses. No attempt to generalize for data
;;;; types other than integers.
;;;;

;;;----------------------------------------------------------------------------
;;; Stuff to print to console conveniently.

;; Print arguments.
(define (print . args)
  (for-each display args))

;; Print arguments with a space separating them.
(define (prints . args)
  (for-each (lambda (s)
              (display s)
              (display " ")) args))

;; Print arguments and a newline.
(define (println . args)
  (apply print args)
  (newline))

;; Print space-separated arguments and a newline.
(define (printsln . args)
  (apply prints args)
  (newline))

;;;----------------------------------------------------------------------------
;;; Generate a list of random integers to sort.

;; Use a small value for `top-of-range` to easily check for correct
;; handling of duplicate values.
(define top-of-range 99) ;(sub1 (expt 2 31)))

(define (random-integers-list how-long)
  (cond
    ((<= how-long 0) '())
    (else (cons (random top-of-range) (random-integers-list (- how-long 1))))))

(define data-length 15)

(define data-to-sort (random-integers-list data-length))

(println "top-of-range         : " top-of-range ", data-length: " data-length)

(println "data-to-sort         : " data-to-sort)

;;;----------------------------------------------------------------------------
;;; Sorting algorithms.

;; Bubble Sort
;;
;; Conceptually the simplest, but the slowest as well. Repeatedly start from
;; the beginning of the list and move the largest element up the list until it
;; runs into the end of the list or a larger element.

;; Bubble up one item. Take the largest value in the unsorted area of the
;; list to the highest position it can occupy.
(define (bubble-one l)
  (if (null? (cdr l))
      l
      (if (> (car l) (cadr l))
          (cons (cadr l) (bubble-one (cons (car l) (cddr l))))
          (cons (car l) (bubble-one (cdr l))))))

;; Iterate the bubbling process .Repeat for the number of elements in the list.
(define (bubble-times ls len)
  (if (= 1 len)
      ls
      (bubble-times  (bubble-one ls) (- len 1))))

;; Sort the list using the bubble sort algorithm. Return a new
;; sorted list. The original list is not changed.
(define (bubble-sort lst)
  (bubble-times lst (length lst)))

(println "Bubble Sort Result   : " (bubble-sort data-to-sort))

;; Selection Sort
;;
;; Slightly fewer swaps than bubble sort. Make multiple passes through the list
;; putting the smallest element from the unsorted region at the beginning of
;; the output sorted list.

;; Delete the first element from the list that matches `item`. Deleting just
;; one preserves duplicate values in the list as opposed to something simpler,
;; like using the `filter` function.
(define (delete-one item lst)
  (cond
    ((equal? item (car lst)) (cdr lst))
    (else (cons (car lst) (delete-one item (cdr lst))))))

(define (select-smallest lst)
  (if (null? (cdr lst))
      (car lst)
      (let ((s (select-smallest (cdr lst))))
        (if (< (car lst) s)
            (car lst)
            s))))

(define (selection-sort lst)
  (if (null? lst)
      lst
      (let ((s (select-smallest lst)))
        (cons s (selection-sort (delete-one s lst))))))

(println "Selection Sort Result: " (selection-sort data-to-sort))

;; Insertion Sort
;;
;; Remove one element from the list at a time and insert it into the correct
;; position in the output list.
;;
;; Can't think of a case in general programming where this would never be
;; superior to bubble or selection sort.

(define (insert x lst)
  (if (null? lst)
      (list x)
      (let ((y (car lst))
            (ys (cdr lst)))
        (if (<= x y)
            (cons x lst)
            (cons y (insert x ys))))))

(define (insertion-sort lst)
  (if (null? lst)
      '()
      (insert (car lst) (insertion-sort (cdr lst)))))

(println "Insertion Sort Result: " (insertion-sort data-to-sort))

;; QuickSort
;;
;; Break the list down into portions above and below a "pivot" value.
;; Recursively sort the lists above and below. Very good average performance.
;; Worst-case performance occurs when the list is already sorted. The ease
;; of constructing worst-case inputs means the algorithm could be a
;; security risk and it is no longer the automatic, "go-to" algorithm
;; for sorting.
;;
;; It seems from the literature that long ago there was a considerable
;; effort devoted to picking the "best" pivot value. I think it didn't
;; make much difference in the end -- any value will do, like the first
;; element of the list used here.

;;
;; Split the list `l` around the pivot determined by the predicate
;; `p`. Use the funcion `k`  to sort the high and low sublists and
;; reconstruct a list containing the
;; low elements, followed by the pivot, followed by the high elements.
(define (split-by l p k)
  (let loop ((low '())
             (high '())
             (l l))
    (cond
      ((null? l)
       (k low high))
      ((p (car l))
       (loop low (cons (car l) high) (cdr l)))
      (else
       (loop (cons (car l) low) high (cdr l))))))

(define (quicksort lst)
  (if (null? lst)
      '()
      (split-by
       ;; The list to be partitioned and sorted.
       (cdr lst)
       ;; The predicate to be used to determine if an element is
       ;; lower or higher than the pivot.
       (lambda (x) (> x (car lst)))
       ;; The function to sort the lower and higher sublists
       ;; and reconstruct them around to pivot value.
       (lambda (low high)
         (append (quicksort low)
                 (list (car lst))
                 (quicksort high))))))

(println "QuickSort Result     : " (quicksort data-to-sort))

;; Merge Sort
;;
;; This is just such a lovely algorithm IMHO. It has very good performance, is
;; easily understandable (in its recursive form at least), stable,
;; externalizable, and can be (relatively) easily parallelized. Its least
;; attractive characteristic is that it can have high memory requirements. See
;; Wikipedia for a very good description.

;; Return a list containing the first `n` items in `lst`.
(define (take lst n)
  (if (zero? n)
      (list)
      (cons (car lst)
            (take (cdr lst) (- n 1)))))

;; Merge the two halves back together in sorted order.
(define (merge left right)
  (cond
    ((null? left)
     right)
    ((null? right)
     left)
    ((> (car left) (car right))
     (cons (car right)
           (merge left (cdr right))))
    (else
     (cons (car left)
           (merge (cdr left) right)))))

;; Divide the list in two and sort each half recursively, the merge the
;; sorted pieces in the correct order.
(define (merge-sort lst)
  (let ((half (quotient (length lst) 2)))
    (if (zero? half)
        lst
        (merge (merge-sort (take      lst half))
               (merge-sort (list-tail lst half))))))

(println "Merge Sort Result    : " (merge-sort data-to-sort))

;; Bucket Sort
;;
;; Bucket sort was included in the article but I haven't included it here
;; because it needs a bunch of auxilliary tuning, like how many buckets
;; to use and which algorithm to use when sorting bucket contents.

;; Shell Sort
;;
;; Also known as the Shell-Metzner sort, it is similar to an insertion sort but
;; does comparisons of elements far apart in the original list.
;;
;; Similar to the Bucket sort, it is sensitive to parameters that need some
;; analysis, such as the gap between the elements being compared (gap
;; sequences). It is not covered here.

;; Heapsort
;;
;; Heapsort first builds a heap from its data. Once in a heap, the sorted list
;; is formed by repeatedly removing the largest item from the heap.
;;
;; By its nature, heapsort is an in-place sort. This implementation makes a
;; copy of the input list in a newly created vector then copies sorted result
;; out to a new list at the end.
;;
;; Heapsort requires swapping elements of the list as well, something not
;; naturally done with list data structures. Hence the internal conversion to
;; a vector.
;;
;; This version is almost completely stolen from Rosetta Code.

;; Swap two elements of a vector.
(define (swap! v i j)
  (define temp (vector-ref v i))
  (vector-set! v i (vector-ref v j))
  (vector-set! v j temp))

;; Sift element at node start into place.
(define (sift-down! v start end)
  (let ((child (+ (* start 2) 1)))
    (cond
      ((> child end) 'done) ;; Start has no children.
      (else
       (begin
         ;; If child has a sibling node whose value is greater ...
         (and (and (<= (+ child 1) end)
                   (< (vector-ref v child) (vector-ref v (+ child 1))))
              ;; ... then we'll look at the sibling instead.
              (set! child (+ child 1)))
         (if (< (vector-ref v start) (vector-ref v child))
             (begin
               (swap! v start child)
               (sift-down! v child end))
             'done))))))

;; Transform v into a binary max-heap.
(define (heapify! v)
  (define (iterate v start)
    (if (>= start 0)
        (begin (sift-down! v start (- (vector-length v) 1))
               (iterate v (- start 1)))
        'done))
  ;; Start sifting with final parent node of v.
  (iterate v (quotient (- (vector-length v) 2) 2)))

(define (heapsort lst)
  ;; Swap root and end node values,
  ;; sift the first element into place
  ;; and recurse with new root and next-to-end node.
  (define (iter! v end)
    (if (zero? end)
        'done
        (begin
          (swap! v 0 end)
          (sift-down! v 0 (- end 1))
          (iter! v (- end 1)))))
  (begin
    (let ((v (list->vector lst)))
      (heapify! v)
      ;; Start swapping with root and final node.
      (iter! v (- (vector-length v) 1))
      (vector->list v))))

(println "Heapsort Result      : " (heapsort data-to-sort))

;; Just to prove that we didn't mess up the original data.
(println "data-to-sort         : " data-to-sort)