Sorting algorithms/Heapsort
From Rosetta Code
You are encouraged to solve this task according to the task description, using any language you may know.
Sorting Algorithm
This is a sorting algorithm. It may be applied to a set of data in order to sort it.
Heapsort | Mergesort | Quicksort
O(n log2n) Sorts
Shell Sort
O(n2) Sorts
Bubble Sort | Cocktail Sort | Comb Sort | Gnome Sort | Insertion Sort | Selection Sort
Other Sorts
Bead Sort | Bogosort | Counting Sort | Pancake Sort | Permutation Sort | Stooge Sort
| This page uses content from Wikipedia. The original article was at Sorting algorithms/Heapsort. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU Free Documentation License. |
Pseudocode:
function heapSort(a, count) is input: an unordered array a of length count (first place a in max-heap order) heapify(a, count) end := count - 1 while end > 0 do (swap the root(maximum value) of the heap with the last element of the heap) swap(a[end], a[0]) (put the heap back in max-heap order) siftDown(a, 0, end-1) (decrement the size of the heap so that the previous max value will stay in its proper place) end := end - 1 function heapify(a,count) is (start is assigned the index in a of the last parent node) start := (count - 2) / 2 while start ≥ 0 do (sift down the node at index start to the proper place such that all nodes below the start index are in heap order) siftDown(a, start, count-1) start := start - 1 (after sifting down the root all nodes/elements are in heap order) function siftDown(a, start, end) is (end represents the limit of how far down the heap to sift) root := start while root * 2 + 1 ≤ end do (While the root has at least one child) child := root * 2 + 1 (root*2+1 points to the left child) (If the child has a sibling and the child's value is less than its sibling's...) if child + 1 ≤ end and a[child] < a[child + 1] then child := child + 1 (... then point to the right child instead) if a[root] < a[child] then (out of max-heap order) swap(a[root], a[child]) root := child (repeat to continue sifting down the child now) else return
Write a function to sort a collection of integers using heapsort.
Contents |
[edit] ActionScript
function heapSort(data:Vector.<int>):Vector.<int> {
for (var start:int = (data.length-2)/2; start >= 0; start--) {
siftDown(data, start, data.length);
}
for (var end:int = data.length - 1; end > 0; end--) {
var tmp:int=data[0];
data[0]=data[end];
data[end]=tmp;
siftDown(data, 0, end);
}
return data;
}
function siftDown(data:Vector.<int>, start:int, end:int):void {
var heapRoot:int=start;
while (heapRoot * 2+1 < end) {
var child:int=heapRoot*2+1;
if (child+1<end&&data[child]<data[child+1]) {
child++;
}
if (data[heapRoot]<data[child]) {
var tmp:int=data[heapRoot];
data[heapRoot]=data[child];
data[child]=tmp;
heapRoot=child;
} else {
return;
}
}
}
[edit] Ada
This implementation is a generic heapsort for unconstrained arrays.
generic
type Element_Type is private;
type Index_Type is (<>);
type Collection is array(Index_Type range <>) of Element_Type;
with function "<" (Left, right : element_type) return boolean is <>;
procedure Generic_Heapsort(Item : in out Collection);
procedure Generic_Heapsort(Item : in out Collection) is
procedure Swap(Left : in out Element_Type; Right : in out Element_Type) is
Temp : Element_Type := Left;
begin
Left := Right;
Right := Temp;
end Swap;
procedure Sift_Down(Item : in out Collection) is
Root : Integer := Index_Type'Pos(Item'First);
Child : Integer := Index_Type'Pos(Item'Last);
Last : Integer := Index_Type'Pos(Item'Last);
begin
while Root * 2 + 1 <= Last loop
Child := Root * 2 + 1;
if Child + 1 <= Last and then Item(index_Type'Val(Child)) < Item(Index_Type'Val(Child + 1)) then
Child := Child + 1;
end if;
if Item(Index_Type'Val(Root)) < Item(Index_Type'Val(Child)) then
Swap(Item(Index_Type'Val(Root)), Item(Index_Type'Val(Child)));
Root := Child;
else
exit;
end if;
end loop;
end Sift_Down;
procedure Heapify(Item : in out Collection) is
First_Pos : Integer := Index_Type'Pos(Index_Type'First);
Last_Pos : Integer := Index_Type'Pos(Index_type'Last);
Start : Index_type := Index_Type'Val((Last_Pos - First_Pos + 1) / 2);
begin
loop
Sift_Down(Item(Start..Item'Last));
if Start > Index_Type'First then
Start := Index_Type'Pred(Start);
else
exit;
end if;
end loop;
end Heapify;
Last_Index : Index_Type := Index_Type'Last;
begin
Heapify(Item);
while Last_Index > Index_Type'First loop
Swap(Item(Last_Index), Item(Item'First));
Last_Index := Index_Type'Pred(Last_Index);
Sift_Down(Item(Item'First..Last_Index));
end loop;
end Generic_Heapsort;
Demo code:
with Generic_Heapsort;
with Ada.Text_Io; use Ada.Text_Io;
procedure Test_Generic_Heapsort is
type Days is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);
type Days_Col is array(Days range <>) of Natural;
procedure Sort is new Generic_Heapsort(Natural, Days, Days_Col);
Week : Days_Col := (5, 2, 7, 3, 4, 9, 1);
begin
for I in Week'range loop
Put(Days'Image(I) & ":" & Natural'Image(Week(I)) & " ");
end loop;
New_Line;
Sort(Week);
for I in Week'range loop
Put(Days'Image(I) & ":" & Natural'Image(Week(I))& " ");
end loop;
New_Line;
end Test_Generic_Heapsort;
[edit] AutoHotkey
heapSort(a) {
Local end
end := %a%0
heapify(a,end)
While end > 1
%a%%end% := (%a%1 "", %a%1 := %a%%end%)
,siftDown(a, 1, --end)
}
heapify(a, count) {
Local start
start := count // 2
While start
siftDown(a, start--, count)
}
siftDown(a, start, end) {
Local child, c1
While start*2 <= end {
c1 := 1 + child := start*2
If (c1 <= end && %a%%child% < %a%%c1%)
child := c1
If (%a%%start% < %a%%child%)
%a%%start% := (%a%%child% "", %a%%child% := %a%%start%)
,start := child
Else Return
}
}
a = 1,5,2,7,3,4,6,8,1 ; ----- test -----
StringSplit a, a, `,
heapSort("a")
ListVars
MsgBox
[edit] BCPL
// This can be run using Cintcode BCPL freely available from www.cl.cam.ac.uk/users/mr10.
GET "libhdr.h"
LET heapify(v, k, i, last) BE
{ LET j = i+i // If there is a son (or two), j = subscript of first.
AND x = k // x will hold the larger of the sons if any.
IF j<=last DO x := v!j // j, x = subscript and key of first son.
IF j< last DO
{ LET y = v!(j+1) // y = key of the other son.
IF x<y DO x,j := y, j+1 // j, x = subscript and key of larger son.
}
IF k>=x DO
{ v!i := k // k is not lower than larger son if any.
RETURN
}
v!i := x
i := j
} REPEAT
AND heapsort(v, upb) BE
{ FOR i = upb/2 TO 1 BY -1 DO heapify(v, v!i, i, upb)
FOR i = upb TO 2 BY -1 DO
{ LET k = v!i
v!i := v!1
heapify(v, k, 1, i-1)
}
}
LET start() = VALOF {
LET v = VEC 1000
FOR i = 1 TO 1000 DO v!i := randno(1_000_000)
heapsort(v, 1000)
FOR i = 1 TO 1000 DO
{ IF i MOD 10 = 0 DO newline()
writef(" %i6", v!i)
}
newline()
}
[edit] C
#include <stdio.h>
#include <stdlib.h>
#define ValType double
#define IS_LESS(v1, v2) (v1 < v2)
void siftDown( ValType *a, int start, int count);
#define SWAP(r,s) do{ValType t=r; r=s; s=t; } while(0)
void heapsort( ValType *a, int count)
{
int start, end;
/* heapify */
for (start = (count-2)/2; start >=0; start--) {
siftDown( a, start, count);
}
for (end=count-1; end > 0; end--) {
SWAP(a[end],a[0]);
siftDown(a, 0, end);
}
}
void siftDown( ValType *a, int start, int end)
{
int root = start;
while ( root*2+1 < end ) {
int child = 2*root + 1;
if ((child + 1 < end) && IS_LESS(a[child],a[child+1])) {
child += 1;
}
if (IS_LESS(a[root], a[child])) {
SWAP( a[child], a[root] );
root = child;
}
else
return;
}
}
int main(int argc, char *argv[])
{
int ix;
double valsToSort[] = {
1.4, 50.2, 5.11, -1.55, 301.521, 0.3301, 40.17,
-18.0, 88.1, 30.44, -37.2, 3012.0, 49.2};
#define VSIZE (sizeof(valsToSort)/sizeof(valsToSort[0]))
heapsort(valsToSort, VSIZE);
printf("{");
for (ix=0; ix<VSIZE; ix++) printf(" %.3f ", valsToSort[ix]);
printf("}\n");
return 0;
}
[edit] C#
using System;
using System.Collections.Generic;
using System.Text;
public class HeapSortClass
{
public static void HeapSort<T>(T[] array)
{
HeapSort<T>(array, 0, array.Length, Comparer<T>.Default);
}
public static void HeapSort<T>(T[] array, int offset, int length, IComparer<T> comparer)
{
HeapSort<T>(array, offset, length, comparer.Compare);
}
public static void HeapSort<T>(T[] array, int offset, int length, Comparison<T> comparison)
{
// build binary heap from all items
for (int i = 0; i < length; i++)
{
int index = i;
T item = array[offset + i]; // use next item
// and move it on top, if greater than parent
while (index > 0 &&
comparison(array[offset + (index - 1) / 2], item) < 0)
{
int top = (index - 1) / 2;
array[offset + index] = array[offset + top];
index = top;
}
array[offset + index] = item;
}
for (int i = length - 1; i > 0; i--)
{
// delete max and place it as last
T last = array[offset + i];
array[offset + i] = array[offset];
int index = 0;
// the last one positioned in the heap
while (index * 2 + 1 < i)
{
int left = index * 2 + 1, right = left + 1;
if (right < i && comparison(array[offset + left], array[offset + right]) < 0)
{
if (comparison(last, array[offset + right]) > 0) break;
array[offset + index] = array[offset + right];
index = right;
}
else
{
if (comparison(last, array[offset + left]) > 0) break;
array[offset + index] = array[offset + left];
index = left;
}
}
array[offset + index] = last;
}
}
static void Main()
{
// usage
byte[] r = {5, 4, 1, 2};
HeapSort(r);
string[] s = { "-", "D", "a", "33" };
HeapSort(s, 0, s.Length, StringComparer.CurrentCultureIgnoreCase);
}
}
[edit] Clojure
(defn- swap [a i j]
(assoc a i (nth a j) j (nth a i)))
(defn- sift [a pred k l]
(loop [a a x k y (inc (* 2 k))]
(if (< (inc (* 2 x)) l)
(let [ch (if (and (< y (dec l)) (pred (nth a y) (nth a (inc y))))
(inc y)
y)]
(if (pred (nth a x) (nth a ch))
(recur (swap a x ch) ch (inc (* 2 ch)))
a))
a)))
(defn- heapify[pred a len]
(reduce (fn [c term] (sift (swap c term 0) pred 0 term))
(reduce (fn [c i] (sift c pred i len))
(vec a)
(range (dec (int (/ len 2))) -1 -1))
(range (dec len) 0 -1)))
(defn heap-sort
([a pred]
(let [len (count a)]
(heapify pred a len)))
([a]
(heap-sort a <)))
Example usage:
user> (heapsort [1 2 4 6 2 3 6])
[1 2 2 3 4 6 6]
user> (heapsort [1 2 4 6 2 3 6] >)
[6 6 4 3 2 2 1]
user> (heapsort (list 1 2 4 6 2 3 6))
[1 2 2 3 4 6 6]
[edit] Common Lisp
(defun make-heap (&optional (length 7))
(make-array length :adjustable t :fill-pointer 0))
(defun left-index (index)
(1- (* 2 (1+ index))))
(defun right-index (index)
(* 2 (1+ index)))
(defun parent-index (index)
(floor (1- index) 2))
(defun percolate-up (heap index predicate)
(if (zerop index) heap
(do* ((element (aref heap index))
(index index pindex)
(pindex (parent-index index)
(parent-index index)))
((zerop index) heap)
(if (funcall predicate element (aref heap pindex))
(rotatef (aref heap index) (aref heap pindex))
(return-from percolate-up heap)))))
(defun heap-insert (heap element predicate)
(let ((index (vector-push-extend element heap 2)))
(percolate-up heap index predicate)))
(defun percolate-down (heap index predicate)
(let ((length (length heap))
(element (aref heap index)))
(flet ((maybe-element (index)
"return the element at index or nil, and a boolean
indicating whether there was an element."
(if (< index length)
(values (aref heap index) t)
(values nil nil))))
(do ((index index swap-index)
(lindex (left-index index) (left-index index))
(rindex (right-index index) (right-index index))
(swap-index nil) (swap-child nil))
(nil)
;; Extact the left child if there is one. If there is not,
;; return the heap. Set the left child as the swap-child.
(multiple-value-bind (lchild lp) (maybe-element lindex)
(if (not lp) (return-from percolate-down heap)
(setf swap-child lchild
swap-index lindex))
;; Extract the right child, if any, and when better than the
;; current swap-child, update the swap-child.
(multiple-value-bind (rchild rp) (maybe-element rindex)
(when (and rp (funcall predicate rchild lchild))
(setf swap-child rchild
swap-index rindex))
;; If the swap-child is better than element, rotate them,
;; and continue percolating down, else return heap.
(if (not (funcall predicate swap-child element))
(return-from percolate-down heap)
(rotatef (aref heap index) (aref heap swap-index)))))))))
(defun heap-empty-p (heap)
(eql (length heap) 0))
(defun heap-delete-min (heap predicate)
(assert (not (heap-empty-p heap)) () "Can't pop from empty heap.")
(prog1 (aref heap 0)
(setf (aref heap 0) (vector-pop heap))
(unless (heap-empty-p heap)
(percolate-down heap 0 predicate))))
(defun heapsort (sequence predicate)
(let ((h (make-heap (length sequence))))
(map nil #'(lambda (e) (heap-insert h e predicate)) sequence)
(map-into sequence #'(lambda () (heap-delete-min h predicate)))))
Example usage:
(heapsort (vector 1 9 2 8 3 7 4 6 5) '<) ; #(1 2 3 4 5 6 7 8 9) (heapsort (list 9 8 1 2 7 6 3 4 5) '<) ; (1 2 3 4 5 6 7 8 9)
[edit] D
import std.stdio, std.algorithm;
/// In-place HeapSort
public static void heapSort(Tseq)(Tseq seq) {
static void siftDown(Tseq seq, size_t start, size_t end) {
for (size_t root = start; root * 2 + 1 <= end; ) {
auto child = root * 2 + 1;
if (child + 1 <= end && seq[child] < seq[child + 1])
child++;
if (seq[root] < seq[child]) {
swap(seq[root], seq[child]);
root = child;
} else
break;
}
}
if (seq.length > 1)
for (size_t start = (seq.length - 2) / 2 + 1; start > 0; start--)
siftDown(seq, start - 1, seq.length - 1);
for (size_t end = seq.length - 1; end > 0; end--) {
swap(seq[end], seq[0]);
siftDown(seq, 0, end - 1);
}
}
void main() {
auto arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0];
heapSort(arr);
writeln(arr);
}
[edit] E
Translation of: Python
def heapsort := {
def cswap(c, a, b) {
def t := c[a]
c[a] := c[b]
c[b] := t
# println(c)
}
def siftDown(array, start, finish) {
var root := start
while (var child := root * 2 + 1
child <= finish) {
if (child + 1 <= finish && array[child] < array[child + 1]) {
child += 1
}
if (array[root] < array[child]) {
cswap(array, root, child)
root := child
} else {
break
}
}
}
/** Heapsort (in-place). */
def heapsort(array) {
# in pseudo-code, heapify only called once, so inline it here
for start in (0..((array.size()-2)//2)).descending() {
siftDown(array, start, array.size()-1)
}
for finish in (0..(array.size()-1)).descending() {
cswap(array, 0, finish)
siftDown(array, 0, finish - 1)
}
}
}
[edit] F#
let inline swap (a: _ []) i j =
let temp = a.[i]
a.[i] <- a.[j]
a.[j] <- temp
let inline sift cmp (a: _ []) start count =
let rec loop root child =
if root * 2 + 1 < count then
let p = child < count - 1 && cmp a.[child] a.[child + 1] < 0
let child = if p then child + 1 else child
if cmp a.[root] a.[child] < 0 then
swap a root child
loop child (child * 2 + 1)
loop start (start * 2 + 1)
let inline heapsort cmp (a: _ []) =
let n = a.Length
for start = n/2 - 1 downto 0 do
sift cmp a start n
for term = n - 1 downto 1 do
swap a term 0
sift cmp a 0 term
[edit] Forth
This program assumes that return addresses simply reside as a single cell on the Return Stack. Most Forth compilers fulfill this requirement.
create example
70 , 61 , 63 , 37 , 63 , 25 , 46 , 92 , 38 , 87 ,
[UNDEFINED] r'@ [IF]
: r'@ r> r> r@ swap >r swap >r ;
[THEN]
defer precedes ( n1 n2 a -- f)
defer exchange ( n1 n2 a --)
: siftDown ( a e s -- a e s)
swap >r swap >r dup ( s r)
begin ( s r)
dup 2* 1+ dup r'@ < ( s r c f)
while ( s r c)
dup 1+ dup r'@ < ( s r c c+1 f)
if ( s r c c+1)
over over r@ precedes if swap then
then drop ( s r c)
over over r@ precedes ( s r c f)
while ( s r c)
tuck r@ exchange ( s r)
repeat then ( s r)
drop drop r> swap r> swap ( a e s)
;
: heapsort ( a n --)
over >r ( a n)
dup 1- 1- 2/ ( a c s)
begin ( a c s)
dup 0< 0= ( a c s f)
while ( a c s)
siftDown 1- ( a c s)
repeat drop ( a c)
1- 0 ( a e 0)
begin ( a e 0)
over 0> ( a e 0 f)
while ( a e 0)
over over r@ exchange ( a e 0)
siftDown swap 1- swap ( a e 0)
repeat ( a e 0)
drop drop drop r> drop
;
:noname >r cells r@ + @ swap cells r> + @ swap < ; is precedes
:noname >r cells r@ + swap cells r> + over @ over @ swap rot ! swap ! ; is exchange
: .array 10 0 do example i cells + ? loop cr ;
.array example 10 heapsort .array
[edit] Haskell
Using package fgl from HackageDB
import Data.Graph.Inductive.Internal.Heap(
Heap(..),insert,findMin,deleteMin)
-- heapsort is added in this module as an example application
build :: Ord a => [(a,b)] -> Heap a b
build = foldr insert Empty
toList :: Ord a => Heap a b -> [(a,b)]
toList Empty = []
toList h = x:toList r
where (x,r) = (findMin h,deleteMin h)
heapsort :: Ord a => [a] -> [a]
heapsort = (map fst) . toList . build . map (\x->(x,x))
e.g.
*Main> heapsort [[6,9],[2,13],[6,8,14,9],[10,7],[5]]
[[2,13],[5],[6,8,14,9],[6,9],[10,7]]
[edit] Icon and Unicon
[edit] Icon
procedure main() #: demonstrate various ways to sort a list and string
demosort(heapsort,[3, 14, 1, 5, 9, 2, 6, 3],"qwerty")
end
procedure heapsort(X,op) #: return sorted list ascending(or descending)
local head,tail
op := sortop(op,X) # select how and what we sort
every head := (tail := *X) / 2 to 1 by -1 do # work back from from last parent node
X := siftdown(X,op,head,tail) # sift down from head to make the heap
every tail := *X to 2 by -1 do { # work between the beginning and the tail to final positions
X[1] :=: X[tail]
X := siftdown(X,op,1,tail-1) # re-sift next (previous) branch after shortening the heap
}
return X
end
procedure siftdown(X,op,root,tail) #: the value @root is moved "down" the path of max(min) value to its level
local child
while (child := root * 2) <= tail do { # move down the branch from root to tail
if op(X[child],X[tail >= child + 1]) then # choose the larger(smaller)
child +:= 1 # ... child
if op(X[root],X[child]) then { # root out of order?
X[child] :=: X[root]
root := child # follow max(min) branch
}
else
return X
}
return X
end
Algorithm notes:
- This is a fairly straight forward implementation of the pseudo-code with 'heapify' coded in-line.
Implementation notes:
- Since this transparently sorts both string and list arguments the result must 'return' to bypass call by value (strings)
- Beware missing trailing 'returns' when translating pseudo-code. For amusement try comment out the return at the end of 'shiftdown'
Note: This example relies on the supporting procedures 'sortop', and 'demosort' in Bubble Sort.
Sample Output:Sorting Demo using procedure heapsort
on list : [ 3 14 1 5 9 2 6 3 ]
with op = &null: [ 1 2 3 3 5 6 9 14 ] (0 ms)
with op = "numeric": [ 1 2 3 3 5 6 9 14 ] (0 ms)
with op = "string": [ 1 14 2 3 3 5 6 9 ] (0 ms)
with op = ">>": [ 9 6 5 3 3 2 14 1 ] (0 ms)
with op = ">": [ 14 9 6 5 3 3 2 1 ] (0 ms)
with op = procedure cmp: [ 1 2 3 3 5 6 9 14 ] (0 ms)
with op = "cmp": [ 1 2 3 3 5 6 9 14 ] (0 ms)
on string : "qwerty"
with op = &null: "eqrtwy" (0 ms)
[edit] Unicon
The Icon solution works in Unicon.
[edit] J
Translation of the pseudocode
siftDown=: 4 : 0
's e'=. x
z=.y
c=.s
while. e > c=.1+2*s=.c do.
if. e > 1+c do. if. c <&({&z) c+1 do. c=.c+1 end. end.
if. s <&({&z) c do. z=. z {`(|.@[)`]}~ c,s else. break. end.
end.
z
)
heapSort =: 3 : 0
if. 1>: c=. # y do. y return. end.
z=. (] siftDown ~c,~[)&.>/ (<y),~]&.>i.1+<.-:c-2 NB. heapify
> (](] siftDown {`(|.@[)`]}~) 0,[)&.>/ z,~]&.>1+i.c-1
)
Examples
heapSort 1 5 2 7 3 9 4 6 8 1
1 1 2 3 4 5 6 7 8 9
heapSort &. (a.&i.) 'aqwcdhkij'
acdhijkqw
[edit] Java
Direct translation of the pseudocode.
public static void heapSort(int[] a){
int count = a.length;
//first place a in max-heap order
heapify(a, count);
int end = count - 1;
while(end > 0){
//swap the root(maximum value) of the heap with the
//last element of the heap
int tmp = a[end];
a[end] = a[0];
a[0] = tmp;
//put the heap back in max-heap order
siftDown(a, 0, end - 1);
//decrement the size of the heap so that the previous
//max value will stay in its proper place
end--;
}
}
public static void heapify(int[] a, int count){
//start is assigned the index in a of the last parent node
int start = (count - 2) / 2; //binary heap
while(start >= 0){
//sift down the node at index start to the proper place
//such that all nodes below the start index are in heap
//order
siftDown(a, start, count - 1);
start--;
}
//after sifting down the root all nodes/elements are in heap order
}
public static void siftDown(int[] a, int start, int end){
//end represents the limit of how far down the heap to sift
int root = start;
while((root * 2 + 1) <= end){ //While the root has at least one child
int child = root * 2 + 1; //root*2+1 points to the left child
//if the child has a sibling and the child's value is less than its sibling's...
if(child + 1 <= end && a[child] < a[child + 1])
child = child + 1; //... then point to the right child instead
if(a[root] < a[child]){ //out of max-heap order
int tmp = a[root];
a[root] = a[child];
a[child] = tmp;
root = child; //repeat to continue sifting down the child now
}else
return;
}
}
[edit] M4
divert(-1)
define(`randSeed',141592653)
define(`setRand',
`define(`randSeed',ifelse(eval($1<10000),1,`eval(20000-$1)',`$1'))')
define(`rand_t',`eval(randSeed^(randSeed>>13))')
define(`random',
`define(`randSeed',eval((rand_t^(rand_t<<18))&0x7fffffff))randSeed')
define(`set',`define(`$1[$2]',`$3')')
define(`get',`defn(`$1[$2]')')
define(`new',`set($1,size,0)')
dnl for the heap calculations, it's easier if origin is 0, so set value first
define(`append',
`set($1,get($1,size),$2)`'set($1,size,incr(get($1,size)))')
dnl swap(<name>,<j>,<name>[<j>],<k>) using arg stack for the temporary
define(`swap',`set($1,$2,get($1,$4))`'set($1,$4,$3)')
define(`deck',
`new($1)for(`x',1,$2,
`append(`$1',eval(random%100))')')
define(`show',
`for(`x',0,decr(get($1,size)),`get($1,x) ')')
define(`for',
`ifelse($#,0,``$0'',
`ifelse(eval($2<=$3),1,
`pushdef(`$1',$2)$4`'popdef(`$1')$0(`$1',incr($2),$3,`$4')')')')
define(`ifywork',
`ifelse(eval($2>=0),1,
`siftdown($1,$2,$3)`'ifywork($1,decr($2),$3)')')
define(`heapify',
`define(`start',eval((get($1,size)-2)/2))`'ifywork($1,start,
decr(get($1,size)))')
define(`siftdown',
`define(`child',eval($2*2+1))`'ifelse(eval(child<=$3),1,
`ifelse(eval(child+1<=$3),1,
`ifelse(eval(get($1,child)<get($1,incr(child))),1,
`define(`child',
incr(child))')')`'ifelse(eval(get($1,$2)<get($1,child)),1,
`swap($1,$2,get($1,$2),child)`'siftdown($1,child,$3)')')')
define(`sortwork',
`ifelse($2,0,
`',
`swap($1,0,get($1,0),$2)`'siftdown($1,0,decr($2))`'sortwork($1,
decr($2))')')
define(`heapsort',
`heapify($1)`'sortwork($1,decr(get($1,size)))')
divert
deck(`a',10)
show(`a')
heapsort(`a')
show(`a')
[edit] MATLAB
This function definition is an almost exact translation of the pseudo-code into MATLAB, but I have chosen to make the heapify function inline because it is only called once in the pseudo-code. Also, MATLAB uses 1 based array indecies, therefore all of the pseudo-code has been translated to reflect that difference.
function list = heapSort(list)
function list = siftDown(list,root,theEnd)
while (root * 2) <= theEnd
child = root * 2;
if (child + 1 <= theEnd) && (list(child) < list(child+1))
child = child + 1;
end
if list(root) < list(child)
list([root child]) = list([child root]); %Swap
root = child;
else
return
end
end %while
end %siftDown
count = numel(list);
%Because heapify is called once in pseudo-code, it is inline here
start = floor(count/2);
while start >= 1
list = siftDown(list, start, count);
start = start - 1;
end
%End Heapify
while count > 1
list([count 1]) = list([1 count]); %Swap
count = count - 1;
list = siftDown(list,1,count);
end
end
Sample Usage:
>> heapSort([4 3 1 5 6 2])
ans =
1 2 3 4 5 6
[edit] OCaml
let heapsort a =
let swap i j =
let t = a.(i) in a.(i) <- a.(j); a.(j) <- t in
let sift k l =
let rec check x y =
if 2*x+1 < l then
let ch =
if y < l-1 && a.(y) < a.(y+1) then y+1 else y in
if a.(x) < a.(ch) then (swap x ch; check ch (2*ch+1)) in
check k (2*k+1) in
let len = Array.length a in
for start = (len/2)-1 downto 0 do
sift start len;
done;
for term = len-1 downto 1 do
swap term 0;
sift 0 term;
done;;
Usage:
let a = [|3;1;4;1;5;9;2;6;5;3;5;8;97;93;23;84;62;64;33;83;27;95|] in
heapsort a;
Array.iter (Printf.printf "%d ") a;;
print_newline ();;
let s = "Just to show this is a type-checked polymorphic function" in
let b = Array.init (String.length s) (String.get s) in
heapsort b;
Array.iter print_char b;;
print_newline ();;
Output:
1 1 2 3 3 4 5 5 5 6 8 9 23 27 33 62 64 83 84 93 95 97
-Jaccccdeeefhhhhiiiiklmnnoooooppprsssstttttuuwyy
[edit] Oz
A faithful translation of the pseudocode, adjusted to the fact that Oz arrays can start with an arbitrary index, not just 0 or 1.
declare
proc {HeapSort A}
Low = {Array.low A}
High = {Array.high A}
Count = High-Low+1
%% heapify
LastParent = Low + (Count-2) div 2
in
for Start in LastParent..Low;~1 do
{Siftdown A Start High}
end
%% repeatedly put the maximum element to the end
%% and re-heapify the rest
for End in High..Low+1;~1 do
{Swap A End Low}
{Siftdown A Low End-1}
end
end
proc {Siftdown A Start End}
Low = {Array.low A}
fun {FirstChildOf I} Low+(I-Low)*2+1 end
Root = {NewCell Start}
in
for while:{FirstChildOf @Root} =< End
break:Break
do
Child = {NewCell {FirstChildOf @Root}}
in
if @Child + 1 =< End andthen A.@Child < A.(@Child + 1) then
Child := @Child + 1
end
if A.@Root < A.@Child then
{Swap A @Root @Child}
Root := @Child
else
{Break}
end
end
end
proc {Swap A I J}
A.J := (A.I := A.J)
end
%% create array with indices ~1..7 and fill it
Arr = {Array.new ~1 7 0}
{Record.forAllInd unit(~1:3 0:1 4 1 5 9 2 6 5)
proc {$ I V}
Arr.I := V
end}
in
{HeapSort Arr}
{Show {Array.toRecord unit Arr}}
[edit] Perl
Translation of the pseudocode.
my @my_list = (2,3,6,23,13,5,7,3,4,5);
heap_sort(\@my_list);
print "@my_list\n";
exit;
sub heap_sort
{
my($list) = @_;
my $count = scalar @$list;
heapify($count,$list);
my $end = $count - 1;
while($end > 0)
{
@$list[0,$end] = @$list[$end,0];
sift_down(0,$end-1,$list);
$end--;
}
}
sub heapify
{
my ($count,$list) = @_;
my $start = ($count - 2) / 2;
while($start >= 0)
{
sift_down($start,$count-1,$list);
$start--;
}
}
sub sift_down
{
my($start,$end,$list) = @_;
my $root = $start;
while($root * 2 + 1 <= $end)
{
my $child = $root * 2 + 1;
$child++ if($child + 1 <= $end && $list->[$child] < $list->[$child+1]);
if($list->[$root] < $list->[$child])
{
@$list[$root,$child] = @$list[$child,$root];
$root = $child;
}else{ return }
}
}
[edit] PureBasic
Declare heapify(Array a(1), count)
Declare siftDown(Array a(1), start, ending)
Procedure heapSort(Array a(1), count)
Protected ending=count-1
heapify(a(), count)
While ending>0
Swap a(ending),a(0)
siftDown(a(), 0, ending-1)
ending-1
Wend
EndProcedure
Procedure heapify(Array a(1), count)
Protected start=(count-2)/2
While start>=0
siftDown(a(),start,count-1)
start-1
Wend
EndProcedure
Procedure siftDown(Array a(1), start, ending)
Protected root=start, child
While (root*2+1)<=ending
child=root*2+1
If child+1<=ending And a(child)<a(child+1)
child+1
EndIf
If a(root)<a(child)
Swap a(root), a(child)
root=child
Else
Break
EndIf
Wend
EndProcedure
[edit] Python
def heapsort(lst):
''' Heapsort. Note: this function sorts in-place (it mutates the list). '''
# in pseudo-code, heapify only called once, so inline it here
for start in range((len(lst)-2)/2, -1, -1):
siftdown(lst, start, len(lst)-1)
for end in range(len(lst)-1, 0, -1):
lst[end], lst[0] = lst[0], lst[end]
siftdown(lst, 0, end - 1)
return lst
def siftdown(lst, start, end):
root = start
while True:
child = root * 2 + 1
if child > end: break
if child + 1 <= end and lst[child] < lst[child + 1]:
child += 1
if lst[root] < lst[child]:
lst[root], lst[child] = lst[child], lst[root]
root = child
else:
break
Testing:
>>> ary = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0] >>> heapsort(ary) [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
[edit] Ruby
class Array
def heapsort
self.dup.heapsort!
end
def heapsort!
# in pseudo-code, heapify only called once, so inline it here
((length - 2) / 2).downto(0) {|start| siftdown(start, length - 1)}
# "end" is a ruby keyword
(length - 1).downto(1) do |end_|
self[end_], self[0] = self[0], self[end_]
siftdown(0, end_ - 1)
end
self
end
def siftdown(start, end_)
root = start
loop do
child = root * 2 + 1
break if child > end_
if child + 1 <= end_ and self[child] < self[child + 1]
child += 1
end
if self[root] < self[child]
self[root], self[child] = self[child], self[root]
root = child
else
break
end
end
end
end
Testing:
irb(main):035:0> ary = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0] => [7, 6, 5, 9, 8, 4, 3, 1, 2, 0] irb(main):036:0> ary.heapsort => [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
[edit] Scala
Works with: Scala version 2.8
This code is not written for maximum performance, though, of course, it preserves the O(n log n) characteristic of heap sort.
def heapSort[T](a: Array[T])(implicit ord: Ordering[T]) {
import scala.annotation.tailrec // Ensure functions are tail-recursive
import ord._
val indexOrdering = Ordering by a.apply
def numberOfLeaves(heapSize: Int) = (heapSize + 1) / 2
def children(i: Int, heapSize: Int) = {
val leftChild = i * 2 + 1
leftChild to leftChild + 1 takeWhile (_ < heapSize)
}
def swap(i: Int, j: Int) = {
val tmp = a(i)
a(i) = a(j)
a(j) = tmp
}
// Maintain partial ordering by bubbling down elements
@tailrec
def siftDown(i: Int, heapSize: Int) {
val childrenOfI = children(i, heapSize)
if (childrenOfI nonEmpty) {
val biggestChild = childrenOfI max indexOrdering
if (a(i) < a(biggestChild)) {
swap(i, biggestChild)
siftDown(biggestChild, heapSize)
}
}
}
// Prepare heap by sifting down all non-leaf elements
for (i <- a.indices.reverse drop numberOfLeaves(a.size)) siftDown(i, a.size)
// Sort from the end of the array forward, by swapping the highest element,
// which is always the top of the heap, to the end of the unsorted array
for (i <- a.indices.reverse) {
swap(0, i)
siftDown(0, i)
}
}
[edit] Scheme
Works with: Scheme version R5RS
; 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 (iter v start)
(if (>= start 0)
(begin (sift-down! v start (- (vector-length v) 1))
(iter v (- start 1)))
'done))
; start sifting with final parent node of v
(iter v (quotient (- (vector-length v) 2) 2)))
(define (heapsort v)
; 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
(heapify v)
; start swapping with root and final node
(iter v (- (vector-length v) 1))))
; testing
(define uriah (list->vector '(3 5 7 9 0 8 1 4 2 6)))
(heapsort uriah)
uriah
Output:
done
#(0 1 2 3 4 5 6 7 8 9)
[edit] Seed7
const proc: downheap (inout array elemType: arr, in var integer: k, in integer: n) is func
local
var elemType: help is elemType.value;
var integer: j is 0;
begin
if k <= n div 2 then
help := arr[k];
repeat
j := 2 * k;
if j < n and arr[j] < arr[succ(j)] then
incr(j);
end if;
if help < arr[j] then
arr[k] := arr[j];
k := j;
end if;
until help >= arr[j] or k > n div 2;
arr[k] := help;
end if;
end func;
const proc: heapSort (inout array elemType: arr) is func
local
var integer: n is 0;
var integer: k is 0;
var elemType: help is elemType.value;
begin
n := length(arr);
for k range n div 2 downto 1 do
downheap(arr, k, n);
end for;
repeat
help := arr[1];
arr[1] := arr[n];
arr[n] := help;
decr(n);
downheap(arr, 1, n);
until n <= 1;
end func;
Original source: [1]
[edit] Tcl
Based on the algorithm from Wikipedia:
Works with: Tcl version 8.5
package require Tcl 8.5
proc heapsort {list {count ""}} {
if {$count eq ""} {
set count [llength $list]
}
for {set i [expr {$count/2 - 1}]} {$i >= 0} {incr i -1} {
siftDown list $i [expr {$count - 1}]
}
for {set i [expr {$count - 1}]} {$i > 0} {} {
swap list $i 0
incr i -1
siftDown list 0 $i
}
return $list
}
proc siftDown {varName i j} {
upvar 1 $varName a
while true {
set child [expr {$i*2 + 1}]
if {$child > $j} {
break
}
if {$child+1 <= $j && [lindex $a $child] < [lindex $a $child+1]} {
incr child
}
if {[lindex $a $i] >= [lindex $a $child]} {
break
}
swap a $i $child
set i $child
}
}
proc swap {varName x y} {
upvar 1 $varName a
set tmp [lindex $a $x]
lset a $x [lindex $a $y]
lset a $y $tmp
}
Demo code:
puts [heapsort {1 5 3 7 9 2 8 4 6 0}]
Output:
0 1 2 3 4 5 6 7 8 9
[edit] TI-83 BASIC
Store list with a dimension of 7 or less into L1 (if less input will be padded with zeros), run prgmSORTHEAP, look into L2 for the sorted version of L1. It is possible to do this without L3 (thus, in place), but I coded this when I was paying attention to a math lecture. Could you make a better version that accepts any input, without having to use my clunky If structure? Could you make it in-place?
:If dim(L1)>7
:Then
:Disp "ERR:7"
:Stop
:End
:If dim(L1)<7
:Then
:For(A,1,7)
:If A>dim(L1)
:0→L1(A)
:End
:End
:{0}→L2
:For(B,2,7)
:0→L2(B)
:End
:L1→L3
:For(B,0,6)
:If L3(4)>L3(2)
:Then
:L3(2)→A
:L3(4)→L3(2)
:A→L3(4)
:End
:If L3(5)>L3(2)
:Then
:L3(2)→A
:L3(5)→L3(2)
:A→L3(5)
:End
:If L3(6)>L3(3)
:Then
:L3(3)→A
:L3(6)→L3(3)
:A→L3(6)
:End
:If L3(7)>L3(3)
:Then
:L3(3)→A
:L3(7)→L3(3)
:A→L3(7)
:End
:If L3(2)>L3(1)
:Then
:L3(1)→A
:L3(2)→L3(1)
:A→L3(2)
:End
:If L3(3)>L3(1)
:Then
:L3(1)→A
:L3(3)→L3(1)
:A→L3(3)
:End
:L3(1)→L2(7-B)
:If L3(2)>L3(3)
:Then
:L3(2)→L3(1)
:0→L3(2)
:Else
:L3(3)→L3(1)
:0→L3(3)
:End
:End
:DelVar A
:DelVar B
:DelVar L3
:Return
Categories: Programming Tasks | Sorting Algorithms | WikipediaSourced | ActionScript | Ada | AutoHotkey | BCPL | C | C sharp | Clojure | Common Lisp | D | E | F | Forth | Haskell | Icon | Unicon | J | Java | M4 | MATLAB | OCaml | Oz | Perl | PureBasic | Python | Ruby | Scala | Scheme | Seed7 | Tcl | TI-83 BASIC
