A binary queue and heap sort in Clojure

clojure-heap.clj

;;; An implementation of a binary heap in Clojure
;;; This is an algorithm used for efficiently taking the
;;; largest value from a collection. Commonly used to implement
;;; a priority queue
;;; The heap itself is stored as a vector. For convenience with
;;; array indexing the first element is set to nil and not used
;;; I wrote this as a learning experience not to be used to land
;;; jet aircraft or manage a nuclear reactor.
;;; Should be reasonably efficient though.

(defn greater[a b]
  "return true if a is the larger of two comparable objects"
  (> (compare a b) 0))

(defn greatest
  "Copied from built in max but uses comparable interface to find the largest
whereas max only works with numbers"
  ([x] x)
  ([x y] (if (greater x y) x y))
  ([x y z & rest]
     (reduce greatest (if (greater x y) x y) rest)))

(defn parent-index[n]
  "calculate the parent index of a given index"
  (int (/ n 2)))

(defn left-child-index[n]
  (* n 2))

(defn right-child-index[n]
  (inc (* n 2)))

(defn print-node[h node]
  "print out a node to stdout
  assumes in bounds due to use case
  show exclaimed if violates max-oriented heap order"
  (if (> node 1)
    (let [this-val (nth h node)
          parent-val (nth h (parent-index node))]
      (if (greater this-val parent-val)
        (println (str (nth h node) "!"))
        (println (nth h node))))
    (println (nth h node))))

(defn show-heap[h node]
  (if (< node (count h))
    (do
      (print (apply str (repeat (int (parent-index node)) ".")))
      (print-node h node)
      (show-heap h (left-child-index node))
      (show-heap h (right-child-index node)))))

(defn get-children [h i]
  "get children values or null for terminal nodes of a node"
  (let [child-index (* i 2)
        len (count h)
        left-child (if (< child-index len) (nth h child-index) nil)
        right-child (if (< (inc child-index) len) (nth h (inc child-index)) nil)
        ]
    [left-child right-child]))

(defn swap [h a b]
  "swap two nodes by index"
  (let [temp (nth h a)]
    (assoc (assoc h a (nth h b)) b temp)))

(defn sink [h i]
  "sink the node at index h. this is done to maintain heap order
when a node is popped and the last node is put at root"
  (let [len (count h)]
    (if (< i len)
      (let [[left right] (get-children h i)
            parent (nth h i)]
        (if (= (greatest left right parent) parent)
          h
          (if (greater left right)
            (sink (swap h (left-child-index i) i)  (left-child-index i))
            (sink (swap h (right-child-index i) i) (right-child-index i))))))))

(defn heap-remove-max [h]
  "return the item in slot 1
then swap the end item to that position
finally sink it down
returns the removed value and the new heap
in a vector"
  (let [len (count h)]
    (if (<= len 1)
      [nil h]
      (let [val (nth h 1)]
        [val 
         (-> h
             (swap 1 (dec len))
             (subvec 0 (dec len))
             (sink 1))]))))

(defn float-up [h i]
  "float the node at index i
up as far as it needs to to maintain
heap order"
  (if (<= i 1)
    h ;; terminate at the top
    (let [parent (nth h (parent-index i))
          me (nth h i)]
      (if (greater me parent)
        (float-up (swap h (parent-index i) i)  (parent-index i))
        h))))

(defn heap-add [h val]
  "add to heap
add as last item
float it up"
  (let [h' (conj h val)
        len (count h')]
    (float-up h' (dec len))))

(defn lazy-heap-sequence [h]
  "make a heap into a lazy sequence so you iterate over it"
  (let [[val new-heap] (heap-remove-max h)]
    (if (nil? val)
      nil
      (cons val
            (lazy-seq
             (lazy-heap-sequence new-heap))))))

(defn create-heap []
  [nil])

(defn heap-sort [s]
  "heap sort
add the items to the heap then pop them off"
  (let [heap (reduce heap-add (create-heap) s)]
    (lazy-heap-sequence heap)))

;; creating and using the heap
;; (create-heap)
;; (heap-add (create-heap) 10)
;; (heap-add (heap-add (create-heap)) 20)

;; heap sort 100 random single character strings
;; (heap-sort (repeatedly 100 #(str (char (+ 97 (rand-int 26))))))
;; heap sort 1000 random integers
;; (heap-sort (repeatedly 1000 #(rand-int 100)))
;; sort the source file
;; (heap-sort (re-seq #"\w+" (slurp "./binary-heap.clj")))