CloudFlare suffered a massive security issue affecting all of its customers, including Rosetta Code. All passwords not changed since February 19th 2017 have been expired, and session cookie longevity will be reduced until late March.--Michael Mol (talk) 05:15, 25 February 2017 (UTC)

Sorting algorithms/Heapsort

From Rosetta Code
Task
Sorting algorithms/Heapsort
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.

For other sorting algorithms, see Category:Sorting Algorithms, or:
O(n logn) Sorts
Heapsort | Mergesort | Quicksort
O(n log2n) Sorts
Shell Sort
O(n2) Sorts
Bubble sort | Cocktail sort | Comb sort | Gnome sort | Insertion sort | Selection sort | Strand sort
Other Sorts
Bead sort | Bogosort | Counting sort | Pancake sort | Permutation sort | Radix sort | Sleep sort | Stooge sort
This page uses content from Wikipedia. The original article was at 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 FDL. (See links for details on variance)


Heapsort is an in-place sorting algorithm with worst case and average complexity of   O(n logn).

The basic idea is to turn the array into a binary heap structure, which has the property that it allows efficient retrieval and removal of the maximal element.

We repeatedly "remove" the maximal element from the heap, thus building the sorted list from back to front.

Heapsort requires random access, so can only be used on an array-like data structure.

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])
      (decrement the size of the heap so that the previous
       max value will stay in its proper place)
      end := end - 1
      (put the heap back in max-heap order)
      siftDown(a, 0, end)


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.

360 Assembly[edit]

Translation of: PL/I

The program uses ASM structured macros and two ASSIST macros (XDECO, XPRNT) to keep the code as short as possible.

*        Heap sort                     22/06/2016
HEAPS CSECT
USING HEAPS,R13 base register
B 72(R15) skip savearea
DC 17F'0' savearea
STM R14,R12,12(R13) prolog
ST R13,4(R15) "
ST R15,8(R13) "
LR R13,R15 "
L R1,N n
BAL R14,HEAPSORT call heapsort(n)
LA R3,PG pgi=0
LA R6,1 i=1
DO WHILE=(C,R6,LE,N) for i=1 to n
LR R1,R6 i
SLA R1,2 .
L R2,A-4(R1) a(i)
XDECO R2,XDEC edit a(i)
MVC 0(4,R3),XDEC+8 output a(i)
LA R3,4(R3) pgi=pgi+4
LA R6,1(R6) i=i+1
ENDDO , end for
XPRNT PG,80 print buffer
L R13,4(0,R13) epilog
LM R14,R12,12(R13) "
XR R15,R15 "
BR R14 exit
PG DC CL80' ' local data
XDEC DS CL12 "
*------- heapsort(icount)----------------------------------------------
HEAPSORT ST R14,SAVEHPSR save return addr
ST R1,ICOUNT icount
BAL R14,HEAPIFY call heapify(icount)
MVC IEND,ICOUNT iend=icount
DO WHILE=(CLC,IEND,GT,=F'1') while iend>1
L R1,IEND iend
LA R2,1 1
BAL R14,SWAP call swap(iend,1)
LA R1,1 1
L R2,IEND iend
BCTR R2,0 -1
ST R2,IEND iend=iend-1
BAL R14,SIFTDOWN call siftdown(1,iend)
ENDDO , end while
L R14,SAVEHPSR restore return addr
BR R14 return to caller
SAVEHPSR DS A local data
ICOUNT DS F "
IEND DS F "
*------- heapify(count)------------------------------------------------
HEAPIFY ST R14,SAVEHPFY save return addr
ST R1,COUNT count
SRA R1,1 /2
ST R1,ISTART istart=count/2
DO WHILE=(C,R1,GE,=F'1') while istart>=1
L R1,ISTART istart
L R2,COUNT count
BAL R14,SIFTDOWN call siftdown(istart,count)
L R1,ISTART istart
BCTR R1,0 -1
ST R1,ISTART istart=istart-1
ENDDO , end while
L R14,SAVEHPFY restore return addr
BR R14 return to caller
SAVEHPFY DS A local data
COUNT DS F "
ISTART DS F "
*------- siftdown(jstart,jend)-----------------------------------------
SIFTDOWN ST R14,SAVESFDW save return addr
ST R1,JSTART jstart
ST R2,JEND jend
ST R1,ROOT root=jstart
LR R3,R1 root
SLA R3,1 root*2
DO WHILE=(C,R3,LE,JEND) while root*2<=jend
ST R3,CHILD child=root*2
MVC SW,ROOT sw=root
L R1,SW sw
SLA R1,2 .
L R2,A-4(R1) a(sw)
L R1,CHILD child
SLA R1,2 .
L R3,A-4(R1) a(child)
IF CR,R2,LT,R3 THEN if a(sw)<a(child) then
MVC SW,CHILD sw=child
ENDIF , end if
L R2,CHILD child
LA R2,1(R2) +1
L R1,SW sw
SLA R1,2 .
L R3,A-4(R1) a(sw)
L R1,CHILD child
LA R1,1(R1) +1
SLA R1,2 .
L R4,A-4(R1) a(child+1)
IF C,R2,LE,JEND,AND, if child+1<=jend and X
CR,R3,LT,R4 THEN a(sw)<a(child+1) then
L R2,CHILD child
LA R2,1(R2) +1
ST R2,SW sw=child+1
ENDIF , end if
IF CLC,SW,NE,ROOT THEN if sw^=root then
L R1,ROOT root
L R2,SW sw
BAL R14,SWAP call swap(root,sw)
MVC ROOT,SW root=sw
ELSE , else
B RETSFDW return
ENDIF , end if
L R3,ROOT root
SLA R3,1 root*2
ENDDO , end while
RETSFDW L R14,SAVESFDW restore return addr
BR R14 return to caller
SAVESFDW DS A local data
JSTART DS F "
ROOT DS F "
JEND DS F "
CHILD DS F "
SW DS F "
*------- swap(x,y)-----------------------------------------------------
SWAP SLA R1,2 x
LA R1,A-4(R1) @a(x)
SLA R2,2 y
LA R2,A-4(R2) @a(y)
L R3,0(R1) temp=a(x)
MVC 0(4,R1),0(R2) a(x)=a(y)
ST R3,0(R2) a(y)=temp
BR R14 return to caller
*------- ------ -------------------------------------------------------
A DC F'4',F'65',F'2',F'-31',F'0',F'99',F'2',F'83',F'782',F'1'
DC F'45',F'82',F'69',F'82',F'104',F'58',F'88',F'112',F'89',F'74'
N DC A((N-A)/L'A) number of items
YREGS
END HEAPS
Output:
 -31   0   1   2   2   4  45  58  65  69  74  82  82  83  88  89  99 104 112 782

ActionScript[edit]

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;
}
}
}

Ada[edit]

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;

ALGOL 68[edit]

#--- Swap function ---#
PROC swap = (REF []INT array, INT first, INT second) VOID:
(
INT temp := array[first];
array[first] := array[second];
array[second]:= temp
);
 
#--- Heap sort Move Down ---#
PROC heapmove = (REF []INT array, INT i, INT last) VOID:
(
INT index := i;
INT larger := (index*2);
 
WHILE larger <= last DO
IF larger < last THEN IF array[larger] < array[larger+1] THEN
larger +:= 1
FI FI;
IF array[index] < array[larger] THEN
swap(array, index, larger)
FI;
index := larger;
larger := (index*2)
OD
);
 
#--- Heap sort ---#
PROC heapsort = (REF []INT array) VOID:
(
FOR i FROM ENTIER((UPB array) / 2) BY -1 WHILE
heapmove(array, i, UPB array);
i > 1 DO SKIP OD;
 
FOR i FROM UPB array BY -1 WHILE
swap(array, 1, i);
heapmove(array, 1, i-1);
i > 1 DO SKIP OD
);
#***************************************************************#
main:
(
[10]INT a;
FOR i FROM 1 TO UPB a DO
a[i] := ROUND(random*100)
OD;
 
print(("Before:", a));
print((newline, newline));
heapsort(a);
print(("After: ", a))
 
)
Output:
Before:       +633       +972       +136       +494       +720       +326       +813       +980       +784       +760
                                                                                                                     
After:        +136       +326       +494       +633       +720       +760       +784       +813       +972       +980

AutoHotkey[edit]

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

BBC BASIC[edit]

      DIM test(9)
test() = 4, 65, 2, -31, 0, 99, 2, 83, 782, 1
PROCheapsort(test())
FOR i% = 0 TO 9
PRINT test(i%) ;
NEXT
PRINT
END
 
DEF PROCheapsort(a())
LOCAL e%
PROCheapify(a())
FOR e% = DIM(a(),1) TO 1 STEP -1
SWAP a(e%), a(0)
PROCsiftdown(a(), 0, e%-1)
NEXT
ENDPROC
 
DEF PROCheapify(a())
LOCAL s%, m%
m% = DIM(a(),1)
FOR s% = (m% - 1) / 2 TO 0 STEP -1
PROCsiftdown(a(), s%, m%)
NEXT
ENDPROC
 
DEF PROCsiftdown(a(), s%, e%)
LOCAL c%, r%
r% = s%
WHILE r% * 2 + 1 <= e%
c% = r% * 2 + 1
IF c% + 1 <= e% IF a(c%) < a(c% + 1) c% += 1
IF a(r%) < a(c%) SWAP a(r%), a(c%) : r% = c% ELSE ENDPROC
ENDWHILE
ENDPROC
Output:
       -31         0         1         2         2         4        65        83        99       782

BCPL[edit]

// 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()
}

C[edit]

#include <stdio.h>
 
int max (int *a, int n, int i, int j, int k) {
int m = i;
if (j < n && a[j] > a[m]) {
m = j;
}
if (k < n && a[k] > a[m]) {
m = k;
}
return m;
}
 
void downheap (int *a, int n, int i) {
while (1) {
int j = max(a, n, i, 2 * i + 1, 2 * i + 2);
if (j == i) {
break;
}
int t = a[i];
a[i] = a[j];
a[j] = t;
i = j;
}
}
 
void heapsort (int *a, int n) {
int i;
for (i = (n - 2) / 2; i >= 0; i--) {
downheap(a, n, i);
}
for (i = 0; i < n; i++) {
int t = a[n - i - 1];
a[n - i - 1] = a[0];
a[0] = t;
downheap(a, n - i - 1, 0);
}
}
 
int main () {
int a[] = {4, 65, 2, -31, 0, 99, 2, 83, 782, 1};
int n = sizeof a / sizeof a[0];
int i;
for (i = 0; i < n; i++)
printf("%d%s", a[i], i == n - 1 ? "\n" : " ");
heapsort(a, n);
for (i = 0; i < n; i++)
printf("%d%s", a[i], i == n - 1 ? "\n" : " ");
return 0;
}
 

C++[edit]

Uses C++11. Compile with

g++ -std=c++11 heap.cpp
#include <algorithm>
#include <iterator>
#include <iostream>
 
template<typename RandomAccessIterator>
void heap_sort(RandomAccessIterator begin, RandomAccessIterator end) {
std::make_heap(begin, end);
std::sort_heap(begin, end);
}
 
int main() {
int a[] = {100, 2, 56, 200, -52, 3, 99, 33, 177, -199};
heap_sort(std::begin(a), std::end(a));
copy(std::begin(a), std::end(a), std::ostream_iterator<int>(std::cout, " "));
std::cout << "\n";
}
Output:
-199 -52 2 3 33 56 99 100 177 200
Translation of: CoffeeScript

Uses C++11. Compile with

 g++ -std=c++11
 
#include <iostream>
#include <vector>
 
using namespace std;
 
void shift_down(vector<int>& heap,int i, int max) {
int i_big, c1, c2;
while(i < max) {
i_big = i;
c1 = (2*i) + 1;
c2 = c1 + 1;
if( c1<max && heap[c1]>heap[i_big] )
i_big = c1;
if( c2<max && heap[c2]>heap[i_big] )
i_big = c2;
if(i_big == i) return;
swap(heap[i],heap[i_big]);
i = i_big;
}
}
 
void to_heap(vector<int>& arr) {
int i = (arr.size()/2) - 1;
while(i >= 0) {
shift_down(arr, i, arr.size());
--i;
}
}
 
void heap_sort(vector<int>& arr) {
to_heap(arr);
int end = arr.size() - 1;
while (end > 0) {
swap(arr[0], arr[end]);
shift_down(arr, 0, end);
--end;
}
}
 
int main() {
vector<int> data = {
12, 11, 15, 10, 9, 1, 2,
3, 13, 14, 4, 5, 6, 7, 8
};
heap_sort(data);
for(int i : data) cout << i << " ";
}
Output:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

C#[edit]

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);
}
}

Clojure[edit]

(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]

COBOL[edit]

Works with: GnuCOBOL
        >>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
*> This is GNUCOBOL 2.0
identification division.
program-id. heapsort.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01 filler.
03 a pic 99.
03 a-start pic 99.
03 a-end pic 99.
03 a-parent pic 99.
03 a-child pic 99.
03 a-sibling pic 99.
03 a-lim pic 99 value 10.
03 array-swap pic 99.
03 array occurs 10 pic 99.
procedure division.
start-heapsort.
 
*> fill the array
compute a = random(seconds-past-midnight)
perform varying a from 1 by 1 until a > a-lim
compute array(a) = random() * 100
end-perform
 
perform display-array
display space 'initial array'
 
*>heapify the array
move a-lim to a-end
compute a-start = (a-lim + 1) / 2
perform sift-down varying a-start from a-start by -1 until a-start = 0
 
perform display-array
display space 'heapified'
 
*> sort the array
move 1 to a-start
move a-lim to a-end
perform until a-end = a-start
move array(a-end) to array-swap
move array(a-start) to array(a-end)
move array-swap to array(a-start)
subtract 1 from a-end
perform sift-down
end-perform
 
perform display-array
display space 'sorted'
 
stop run
.
sift-down.
move a-start to a-parent
perform until a-parent * 2 > a-end
compute a-child = a-parent * 2
compute a-sibling = a-child + 1
if a-sibling <= a-end and array(a-child) < array(a-sibling)
*> take the greater of the two
move a-sibling to a-child
end-if
if a-child <= a-end and array(a-parent) < array(a-child)
*> the child is greater than the parent
move array(a-child) to array-swap
move array(a-parent) to array(a-child)
move array-swap to array(a-parent)
end-if
*> continue down the tree
move a-child to a-parent
end-perform
.
display-array.
perform varying a from 1 by 1 until a > a-lim
display space array(a) with no advancing
end-perform
.
end program heapsort.
Output:
prompt$ cobc -xj heapsort.cob
 20 26 47 88 97 39 07 77 35 98 initial array
 98 97 47 88 26 39 07 77 35 20 heapified
 07 20 26 35 39 47 77 88 97 98 sorted


CoffeeScript[edit]

# Do an in-place heap sort.
heap_sort = (arr) ->
put_array_in_heap_order(arr)
end = arr.length - 1
while end > 0
[arr[0], arr[end]] = [arr[end], arr[0]]
sift_element_down_heap arr, 0, end
end -= 1
 
put_array_in_heap_order = (arr) ->
i = arr.length / 2 - 1
i = Math.floor i
while i >= 0
sift_element_down_heap arr, i, arr.length
i -= 1
 
sift_element_down_heap = (heap, i, max) ->
while i < max
i_big = i
c1 = 2*i + 1
c2 = c1 + 1
if c1 < max and heap[c1] > heap[i_big]
i_big = c1
if c2 < max and heap[c2] > heap[i_big]
i_big = c2
return if i_big is i
[heap[i], heap[i_big]] = [heap[i_big], heap[i]]
i = i_big
 
do ->
arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8]
heap_sort arr
console.log arr
Output:
> coffee heap.coffee 
[ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 ]

Common Lisp[edit]

(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)

D[edit]

import std.stdio, std.container;
 
void heapSort(T)(T[] data) /*pure nothrow @safe @nogc*/ {
for (auto h = data.heapify; !h.empty; h.removeFront) {}
}
 
void main() {
auto items = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0];
items.heapSort;
items.writeln;
}

A lower level implementation:

import std.stdio, std.algorithm;
 
void heapSort(R)(R seq) pure nothrow @safe @nogc {
static void siftDown(R seq, in size_t start,
in size_t end) pure nothrow @safe @nogc {
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)
foreach_reverse (immutable start; 1 .. (seq.length - 2) / 2 + 2)
siftDown(seq, start - 1, seq.length - 1);
 
foreach_reverse (immutable end; 1 .. seq.length) {
swap(seq[end], seq[0]);
siftDown(seq, 0, end - 1);
}
}
 
void main() {
auto data = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0];
data.heapSort;
data.writeln;
}

Dart[edit]

 
void heapSort(List 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--;
}
}
 
 
 
void heapify(List a, int count) {
// start is assigned the index in 'a' of the last parent node
int start = ((count - 2)/2).toInt(); // 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--;
}
}
 
void siftDown(List a, int start, int end) {
// end represents the limit of how far down the heap to shift
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 shifting down the child now
} else {
return;
}
}
 
}
 
void main() {
var arr=[1,5,2,7,3,9,4,6,8];
print("Before sort");
arr.forEach((var i)=>print("$i"));
heapSort(arr);
print("After sort");
arr.forEach((var i)=>print("$i"));
}
 
 

E[edit]

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)
}
}
}

EchoLisp[edit]

We use the heap library and the heap-pop primitive to implement heap-sort.

 
(lib 'heap)
 
(define (heap-sort list)
(define heap (make-heap < )) ;; make a min heap
(list->heap list heap)
(while (not (heap-empty? heap))
(push 'stack (heap-pop heap)))
(stack->list 'stack))
 
(define L (shuffle (iota 15)))
(9 4 0 12 8 3 10 7 11 2 5 6 14 13 1)
(heap-sort L)
(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)
 
 

Eiffel[edit]

 
class
HEAPSORT
 
feature
 
sort_array (ar: ARRAY [INTEGER])
-- Sorts array 'ar' in ascending order.
require
not_empty: ar.count > 0
local
i, j, r, l, m, n: INTEGER
sorted: BOOLEAN
do
n := ar.count
j := 0
i := 0
m := 0
r := n
l := (n // 2)+1
from
until
sorted
loop
if l > 1 then
l := l - 1
m := ar[l]
else
m := ar[r]
ar[r] := ar[1]
r := r - 1
if r = 1 then
ar[1]:=m
sorted := True
end
end
if not sorted then
i := l
j := l * 2
from
until
j > r
loop
if (j < r) and (ar[j] < ar[j + 1]) then
j := j + 1
end
if m < ar[j] then
ar[i]:= ar[j]
i := j
j := j + i
else
j := r + 1
end
end
ar[i]:= m
end
end
ensure
sorted: is_sorted(ar)
end
 
feature{NONE}
 
is_sorted (ar: ARRAY [INTEGER]): BOOLEAN
--- Is 'ar' sorted in ascending order?
local
i: INTEGER
do
Result := True
from
i := ar.lower
until
i >= ar.upper
loop
if ar [i] > ar [i + 1] then
Result := False
end
i := i + 1
end
end
 
end
 

Test:

 
class
APPLICATION
 
create
make
 
feature
 
make
local
test: ARRAY [INTEGER]
do
create test.make_empty
test := <<5, 91, 13, 99,7, 35>>
io.put_string ("Unsorted: ")
across
test as t
loop
io.put_string (t.item.out + " ")
end
io.new_line
create heap_sort
heap_sort.sort_array (test)
io.put_string ("Sorted: ")
across
test as t
loop
io.put_string (t.item.out + " ")
end
end
 
heap_sort: HEAPSORT
 
end
 
Output:
Unsorted: 5 91 13 99 7 35
Sorted: 5 7 13 35 91 99

Elixir[edit]

defmodule Sort do
def heapSort(list) do
len = length(list)
heapify(List.to_tuple(list), div(len - 2, 2))
|> heapSort(len-1)
|> Tuple.to_list
end
 
defp heapSort(a, finish) when finish > 0 do
swap(a, 0, finish)
|> siftDown(0, finish-1)
|> heapSort(finish-1)
end
defp heapSort(a, _), do: a
 
defp heapify(a, start) when start >= 0 do
siftDown(a, start, tuple_size(a)-1)
|> heapify(start-1)
end
defp heapify(a, _), do: a
 
defp siftDown(a, root, finish) when root * 2 + 1 <= finish do
child = root * 2 + 1
if child + 1 <= finish and elem(a,child) < elem(a,child + 1), do: child = child + 1
if elem(a,root) < elem(a,child),
do: swap(a, root, child) |> siftDown(child, finish),
else: a
end
defp siftDown(a, _root, _finish), do: a
 
defp swap(a, i, j) do
{vi, vj} = {elem(a,i), elem(a,j)}
a |> put_elem(i, vj) |> put_elem(j, vi)
end
end
 
(for _ <- 1..20, do: :rand.uniform(20)) |> IO.inspect |> Sort.heapSort |> IO.inspect
Output:
[6, 1, 12, 3, 7, 7, 9, 20, 8, 15, 2, 10, 14, 5, 19, 7, 20, 9, 14, 19]
[1, 2, 3, 5, 6, 7, 7, 7, 8, 9, 9, 10, 12, 14, 14, 15, 19, 19, 20, 20]

F#[edit]

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

Forth[edit]

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


 
\ Written in ANS-Forth; tested under VFX.
\ Requires the novice package: http://www.forth.org/novice.html
\ The following should already be done:
\ include novice.4th
 
\ This is already in the novice package, so it is not really necessary to compile the code provided here.
 
\ ******
\ ****** This is our array sort. We are using the heap-sort because it provides consistent times and it is not recursive.
\ ****** This code was ported from C++ at: http://www.snippets.24bytes.com/2010/06/heap-sort.html
\ ****** Our array record size must be a multiple of W. This is assured if FIELD is used for creating the record.
\ ****** The easiest way to speed this up is to rewrite EXCHANGE in assembly language.
\ ******
 
marker HeapSort.4th
 
macro: exchange ( adrX adrY size -- ) \ the size of the record must be a multiple of W
begin dup while \ -- adrX adrY remaining
over @ fourth @ \ -- adrX adrY remaining Y X
fourth ! fourth ! \ -- adrX adrY remaining
rot w + rot w + rot w -
repeat
3drop ;
 
\ All of these macros use the locals from SORT, and can only be called from SORT.
 
macro: adr ( index -- adr )
recsiz * array + ;
 
macro: left ( x -- y ) 2* 1+ ;
 
macro: right ( x -- y ) 2* 2 + ;
 
macro: heapify ( x -- )
dup >r begin \ r: -- great
dup left dup limit < if dup adr rover adr 'comparer execute if rdrop dup >r then then drop
dup right dup limit < if dup adr r@ adr 'comparer execute if rdrop dup >r then then drop
dup r@ <> while
adr r@ adr recsiz exchange
r@ repeat
drop rdrop ;
 
macro: build-max-heap ( -- )
limit 1- 2/ begin dup 0>= while dup heapify 1- repeat drop ;
 
: sort { array limit recsiz 'comparer -- }
recsiz [ w 1- ] literal and abort" *** SORT: record size must be a multiple of the cell size ***"
build-max-heap
begin limit while -1 +to limit
0 adr limit adr recsiz exchange
0 heapify repeat ;
 
\ The SORT locals:
\ array \ the address of the 0th element
\ limit \ the number of records in the array
\ recsiz \ the size of a record in the array \ this must be a multiple of W (FIELD assures this)
\ 'comparer \ adrX adrY -- X>Y?
 
\ Note for the novice:
\ This code was originally written with colon words rather than macros, and using items rather than local variables.
\ After it was debugged, it was changed to use macros and locals so that it would be fast and reentrant.
\ One of the reasons why the heap-sort was chosen is because it is not recursive, which allows macros to be used.
\ Using macros allows the data (array, limit, recsiz, 'comparer) to be held in locals rather than items, which is reentrant.
 
 
\ ******
\ ****** This tests SORT.
\ ******
 
create aaa 2 , 9 , 3 , 6 , 1 , 4 , 5 , 7 , 0 , 8 ,
 
: print-aaa ( limit -- )
cells aaa + aaa do I @ . w +loop ;
 
: int> ( adrX adrY -- X>Y? )
swap @ swap @ > ;
 
: test-sort ( limit -- )
cr dup print-aaa
aaa over w ['] int> sort
cr print-aaa ;
 
10 test-sort
 
Output:
2 9 3 6 1 4 5 7 0 8 
0 1 2 3 4 5 6 7 8 9

Fortran[edit]

Works with: Fortran version 90 and later

Translation of the pseudocode

program Heapsort_Demo
implicit none
 
integer, parameter :: num = 20
real :: array(num)
 
call random_seed
call random_number(array)
write(*,*) "Unsorted array:-"
write(*,*) array
write(*,*)
call heapsort(array)
write(*,*) "Sorted array:-"
write(*,*) array
 
contains
 
subroutine heapsort(a)
 
real, intent(in out) :: a(0:)
integer :: start, n, bottom
real :: temp
 
n = size(a)
do start = (n - 2) / 2, 0, -1
call siftdown(a, start, n);
end do
 
do bottom = n - 1, 1, -1
temp = a(0)
a(0) = a(bottom)
a(bottom) = temp;
call siftdown(a, 0, bottom)
end do
 
end subroutine heapsort
 
subroutine siftdown(a, start, bottom)
 
real, intent(in out) :: a(0:)
integer, intent(in) :: start, bottom
integer :: child, root
real :: temp
 
root = start
do while(root*2 + 1 < bottom)
child = root * 2 + 1
 
if (child + 1 < bottom) then
if (a(child) < a(child+1)) child = child + 1
end if
 
if (a(root) < a(child)) then
temp = a(child)
a(child) = a (root)
a(root) = temp
root = child
else
return
end if
end do
 
end subroutine siftdown
 
end program Heapsort_Demo

FreeBASIC[edit]

' version 22-10-2016
' compile with: fbc -s console
' for boundary checks on array's compile with: fbc -s console -exx
 
' sort from lower bound to the highter bound
' array's can have subscript range from -2147483648 to +2147483647
 
Sub siftdown(hs() As Long, start As ULong , end_ As ULong)
 
Dim As ULong root = start
Dim As Long lb = LBound(hs)
 
While root * 2 +1 < end_
Dim As ULong child = root * 2 +1
If (child +1 < end_) And (hs(lb + child) < hs(lb + child +1)) Then
child = child +1
End If
If hs(lb + root) < hs(lb + child) Then
Swap hs(lb + root), hs(lb + child)
root = child
Else
Return
End If
Wend
 
End Sub
 
Sub heapsort(hs() As Long)
 
Dim As Long lb = LBound(hs)
Dim As ULong count = UBound(hs) - lb
Dim As Long start = (count -2) \ 2
 
While start >= 0
siftdown(hs(), start, count)
start = start -1
Wend
 
Dim As ULong end_ = count
While end_ > 0
Swap hs(lb + end_), hs(lb)
siftdown(hs(), 0, end_)
end_ = end_ -1
Wend
 
End Sub
 
' ------=< MAIN >=------
 
Dim As Long array(-7 To 7)
Dim As Long i, lb = LBound(array), ub = UBound(array)
 
Randomize Timer
For i = lb To ub : array(i) = i : Next
For i = lb To ub
Swap array(i), array(Int(Rnd * (ub - lb +1)) + lb)
Next
 
Print "Unsorted"
For i = lb To ub
Print Using " ###"; array(i);
Next : Print : Print
 
heapsort(array())
 
Print "After heapsort"
For i = lb To ub
Print Using " ###"; array(i);
Next : Print
 
' empty keyboard buffer
While Inkey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End
Output:
Unsorted
   0   3  -6   2   1  -4   7   5   6  -3   4  -7  -1  -5  -2

After heapsort
  -7  -6  -5  -4  -3  -2  -1   0   1   2   3   4   5   6   7

FunL[edit]

Direct translation of the pseudocode. The array object (using Scala's ArraySeq class) has built-in method length, so the count parameter is not needed.

def heapSort( a ) =
heapify( a )
end = a.length() - 1
 
while end > 0
a(end), a(0) = a(0), a(end)
siftDown( a, 0, --end )
 
def heapify( a ) =
for i <- (a.length() - 2)\2..0 by -1
siftDown( a, i, a.length() - 1 )
 
def siftDown( a, start, end ) =
root = start
 
while root*2 + 1 <= end
child = root*2 + 1
 
if child + 1 <= end and a(child) < a(child + 1)
child++
 
if a(root) < a(child)
a(root), a(child) = a(child), a(root)
root = child
else
break
 
a = array( [7, 2, 6, 1, 9, 5, 0, 3, 8, 4] )
heapSort( a )
println( a )
Output:
ArraySeq(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

Go[edit]

Here's an ingenious solution that makes use of the heap module. Although the heap module usually implements an independent heap with push/pop operations, we use a helper type where the "pop" operation does not actually change the size of the underlying container, but changes a "heap length" variable indicating the length of the prefix of the underlying container that is considered "the heap".

Since we want to implement a generic algorithm, we accept an argument of type sort.Interface, and thus do not have access to the actual elements of the container we're sorting. We can only swap elements. This causes a problem for us when implementing the Pop method, as we can't actually return an element. The ingenious step is realizing that heap.Pop() must move the value to pop to the "end" of the heap area, because its interface only has access to a "Swap" function, and a "Pop" function that pops from the end. (It does not have the ability to pop a value at the beginning.) This is perfect because we precisely want to move the thing popped to the end and shrink the "heap area" by 1. Our "Pop" function returns nothing since we can't get the value, but don't actually need it. (We only need the swapping that it does for us.)

package main
 
import (
"sort"
"container/heap"
"fmt"
)
 
type HeapHelper struct {
container sort.Interface
length int
}
 
func (self HeapHelper) Len() int { return self.length }
// We want a max-heap, hence reverse the comparison
func (self HeapHelper) Less(i, j int) bool { return self.container.Less(j, i) }
func (self HeapHelper) Swap(i, j int) { self.container.Swap(i, j) }
// this should not be called
func (self *HeapHelper) Push(x interface{}) { panic("impossible") }
func (self *HeapHelper) Pop() interface{} {
self.length--
return nil // return value not used
}
 
func heapSort(a sort.Interface) {
helper := HeapHelper{ a, a.Len() }
heap.Init(&helper)
for helper.length > 0 {
heap.Pop(&helper)
}
}
 
func main() {
a := []int{170, 45, 75, -90, -802, 24, 2, 66}
fmt.Println("before:", a)
heapSort(sort.IntSlice(a))
fmt.Println("after: ", a)
}
Output:
before: [170 45 75 -90 -802 24 2 66]
after:  [-802 -90 2 24 45 66 75 170]

If you want to implement it manually:

package main
 
import (
"sort"
"fmt"
)
 
func main() {
a := []int{170, 45, 75, -90, -802, 24, 2, 66}
fmt.Println("before:", a)
heapSort(sort.IntSlice(a))
fmt.Println("after: ", a)
}
 
func heapSort(a sort.Interface) {
for start := (a.Len() - 2) / 2; start >= 0; start-- {
siftDown(a, start, a.Len()-1)
}
for end := a.Len() - 1; end > 0; end-- {
a.Swap(0, end)
siftDown(a, 0, end-1)
}
}
 
 
func siftDown(a sort.Interface, start, end int) {
for root := start; root*2+1 <= end; {
child := root*2 + 1
if child+1 <= end && a.Less(child, child+1) {
child++
}
if !a.Less(root, child) {
return
}
a.Swap(root, child)
root = child
}
}

Groovy[edit]

Loose translation of the pseudocode:

def makeSwap = { a, i, j = i+1 -> print "."; a[[j,i]] = a[[i,j]] } 
 
def checkSwap = { list, i, j = i+1 -> [(list[i] > list[j])].find{ it }.each { makeSwap(list, i, j) } }
 
def siftDown = { a, start, end ->
def p = start
while (p*2 < end) {
def c = p*2 + ((p*2 + 1 < end && a[p*2 + 2] > a[p*2 + 1]) ? 2 : 1)
if (checkSwap(a, c, p)) { p = c }
else { return }
}
}
 
def heapify = {
(((it.size()-2).intdiv(2))..0).each { start -> siftDown(it, start, it.size()-1) }
}
 
def heapSort = { list ->
heapify(list)
(0..<(list.size())).reverse().each { end ->
makeSwap(list, 0, end)
siftDown(list, 0, end-1)
}
list
}

Test:

println (heapSort([23,76,99,58,97,57,35,89,51,38,95,92,24,46,31,24,14,12,57,78,4]))
println (heapSort([88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1]))
Output:
.......................................................................[4, 12, 14, 23, 24, 24, 31, 35, 38, 46, 51, 57, 57, 58, 76, 78, 89, 92, 95, 97, 99]
..........................................................................................[0, 1, 4, 5, 7, 8, 12, 14, 18, 20, 31, 33, 44, 62, 70, 73, 75, 76, 78, 81, 82, 84, 88]

Haskell[edit]

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]]

Icon and Unicon[edit]

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. The full demosort exercises the named sort of a list with op = "numeric", "string", ">>" (lexically gt, descending),">" (numerically gt, descending), a custom comparator, and also a string.

Abbreviated 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)
  ...
  on string : "qwerty"
    with op = &null:         "eqrtwy"   (0 ms)

J[edit]

Generally, this task should be accomplished in J using /:~. Here we take an approach that's more comparable with the other examples on this page.

Translation of the pseudocode

swap=: C.~ <
 
siftDown=: 4 : 0
'c e'=. x
while. e > c=.1+2*s=.c do.
before=. <&({&y)
if. e > 1+c do. c=.c+ c before c+1 end.
if. s before c do. y=. y swap c,s else. break. end.
end.
y
)
 
heapSort=: 3 : 0
if. 1>: c=. # y do. y return. end.
z=. siftDown&.>/ (c,~each i.<.c%2),<y NB. heapify
> ([ siftDown swap~)&.>/ (0,each}.i.c),z
)

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

Java[edit]

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;
}
}

JavaScript[edit]

Translation of: CoffeeScript
 
function swap(data, i, j) {
var tmp = data[i];
data[i] = data[j];
data[j] = tmp;
}
 
function heap_sort(arr) {
put_array_in_heap_order(arr);
end = arr.length - 1;
while(end > 0) {
swap(arr, 0, end);
sift_element_down_heap(arr, 0, end);
end -= 1
}
}
 
function put_array_in_heap_order(arr) {
var i;
i = arr.length / 2 - 1;
i = Math.floor(i);
while (i >= 0) {
sift_element_down_heap(arr, i, arr.length);
i -= 1;
}
}
 
function sift_element_down_heap(heap, i, max) {
var i_big, c1, c2;
while(i < max) {
i_big = i;
c1 = 2*i + 1;
c2 = c1 + 1;
if (c1 < max && heap[c1] > heap[i_big])
i_big = c1;
if (c2 < max && heap[c2] > heap[i_big])
i_big = c2;
if (i_big == i) return;
swap(heap,i, i_big);
i = i_big;
}
}
 
arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8,];
heap_sort(arr);
alert(arr);
Output:
    [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15]

Kotlin[edit]

// version 1.1.0
 
fun heapSort(a: IntArray) {
heapify(a)
var end = a.size - 1
while (end > 0) {
val temp = a[end]
a[end] = a[0]
a[0] = temp
end--
siftDown(a, 0, end)
}
}
 
fun heapify(a: IntArray) {
var start = (a.size - 2) / 2
while (start >= 0) {
siftDown(a, start, a.size - 1)
start--
}
}
 
fun siftDown(a: IntArray, start: Int, end: Int) {
var root = start
while (root * 2 + 1 <= end) {
var child = root * 2 + 1
if (child + 1 <= end && a[child] < a[child + 1]) child++
if (a[root] < a[child]) {
val temp = a[root]
a[root] = a[child]
a[child] = temp
root = child
}
else return
}
}
 
fun main(args: Array<String>) {
val aa = arrayOf(
intArrayOf(100, 2, 56, 200, -52, 3, 99, 33, 177, -199),
intArrayOf(4, 65, 2, -31, 0, 99, 2, 83, 782, 1),
intArrayOf(12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8)
)
for (a in aa) {
heapSort(a)
println(a.joinToString(", "))
}
}
Output:
-199, -52, 2, 3, 33, 56, 99, 100, 177, 200
-31, 0, 1, 2, 2, 4, 65, 83, 99, 782
1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15

Liberty BASIC[edit]

wikiSample=1    'comment out for random array
 
data 6, 5, 3, 1, 8, 7, 2, 4
itemCount = 20
if wikiSample then itemCount = 8
dim A(itemCount)
for i = 1 to itemCount
A(i) = int(rnd(1) * 100)
if wikiSample then read tmp: A(i)=tmp
next i
 
print "Before Sort"
call printArray itemCount
 
call heapSort itemCount
 
print "After Sort"
call printArray itemCount
end
 
'------------------------------------------
sub heapSort count
call heapify count
 
print "the heap"
call printArray count
 
theEnd = count
while theEnd > 1
call swap theEnd, 1
call siftDown 1, theEnd-1
theEnd = theEnd - 1
wend
end sub
 
sub heapify count
start = int(count / 2)
while start >= 1
call siftDown start, count
start = start - 1
wend
end sub
 
sub siftDown start, theEnd
root = start
while root * 2 <= theEnd
child = root * 2
swap = root
if A(swap) < A(child) then
swap = child
end if
if child+1 <= theEnd then
if A(swap) < A(child+1) then
swap = child + 1
end if
end if
if swap <> root then
call swap root, swap
root = swap
else
exit sub
end if
wend
end sub
 
sub swap a,b
tmp = A(a)
A(a) = A(b)
A(b) = tmp
end sub
 
'===========================================
sub printArray itemCount
for i = 1 to itemCount
print using("###", A(i));
next i
print
end sub


LotusScript[edit]

 
Public Sub heapsort(pavIn As Variant)
Dim liCount As Integer, liEnd As Integer
Dim lvTemp As Variant
liCount = UBound(pavIn) + 1
 
heapify pavIn, liCount
 
liEnd = liCount - 1
While liEnd > 0
lvTemp = pavIn(liEnd)
pavIn(liEnd) = pavIn(0)
pavIn(0) = lvTemp
liEnd = liEnd -1
siftDown pavIn,0, liEnd
Wend
End Sub
 
Private Sub heapify(pavIn As Variant,piCount As Integer)
Dim liStart As Integer
liStart = (piCount - 2) / 2
While liStart >=0
siftDown pavIn, liStart, piCount -1
liStart = liStart - 1
Wend
End Sub
 
Private Sub siftDown(pavIn As Variant, piStart As Integer, piEnd As Integer)
Dim liRoot As Integer, liChild As Integer
Dim lvTemp As Variant
liRoot = piStart
While liRoot *2 + 1 <= piEnd
liChild = liRoot *2 + 1
If liChild +1 <= piEnd And pavIn(liChild) < pavIn(liChild + 1) Then
liChild = liChild + 1
End If
If pavIn(liRoot) < pavIn(liChild) Then
lvTemp = pavIn(liRoot)
pavIn(liRoot) = pavIn(liChild)
pavIn(liChild) = lvTemp
liRoot = liChild
Else
Exit sub
End if
wend
End Sub
 

M4[edit]

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')

Mathematica[edit]

siftDown[list_,root_,theEnd_]:=
While[(root*2) <= theEnd,
child = root*2;
If[(child+1 <= theEnd)&&(list[[child]] < list[[child+1]]), child++;];
If[list[[root]] < list[[child]],
list[[{root,child}]] = list[[{child,root}]]; root = child;,
Break[];
]
]
 
heapSort[list_] := Module[{ count, start},
count = Length[list]; start = Floor[count/2];
While[start >= 1,list = siftDown[list,start,count];
start--;
]
While[count > 1, list[[{count,1}]] = list[[{1,count}]];
count--; list = siftDown[list,1,count];
]
]
Output:
heapSort@{2,3,1,5,7,6}
{1,2,3,5,6,7}

MATLAB / Octave[edit]

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

MAXScript[edit]

fn heapify arr count =
(
local s = count /2
while s > 0 do
(
arr = siftDown arr s count
s -= 1
)
return arr
)
fn siftDown arr s end =
(
local root = s
while root * 2 <= end do
(
local child = root * 2
if child < end and arr[child] < arr[child+1] do
(
child += 1
)
if arr[root] < arr[child] then
(
swap arr[root] arr[child]
root = child
)
else return arr
)
return arr
)
fn heapSort arr =
(
local count = arr.count
arr = heapify arr count
local end = count
while end >= 1 do
(
swap arr[1] arr[end]
 
end -= 1
arr = siftDown arr 1 end
)
 
)

Output:

 
a = for i in 1 to 10 collect random 0 9
#(7, 2, 5, 6, 1, 5, 4, 0, 1, 6)
heapSort a
#(0, 1, 1, 2, 4, 5, 5, 6, 6, 7)
 

NetRexx[edit]

/* NetRexx */
options replace format comments java crossref savelog symbols binary
 
import java.util.List
 
placesList = [String -
"UK London", "US New York", "US Boston", "US Washington" -
, "UK Washington", "US Birmingham", "UK Birmingham", "UK Boston" -
]
 
lists = [ -
placesList -
, heapSort(String[] Arrays.copyOf(placesList, placesList.length)) -
]
 
loop ln = 0 to lists.length - 1
cl = lists[ln]
loop ct = 0 to cl.length - 1
say cl[ct]
end ct
say
end ln
 
return
 
method heapSort(a = String[], count = a.length) public constant binary returns String[]
 
 
rl = String[a.length]
al = List heapSort(Arrays.asList(a), count)
al.toArray(rl)
 
return rl
 
method heapSort(a = List, count = a.size) public constant binary returns ArrayList
 
a = heapify(a, count)
 
iend = count - 1
loop label iend while iend > 0
swap = a.get(0)
a.set(0, a.get(iend))
a.set(iend, swap)
a = siftDown(a, 0, iend - 1)
iend = iend - 1
end iend
 
return ArrayList(a)
 
method heapify(a = List, count = int) public constant binary returns List
 
start = (count - 2) % 2
 
loop label strt while start >= 0
a = siftDown(a, start, count - 1)
start = start - 1
end strt
 
return a
 
method siftDown(a = List, istart = int, iend = int) public constant binary returns List
 
root = istart
 
loop label root while root * 2 + 1 <= iend
child = root * 2 + 1
if child + 1 <= iend then do
if (Comparable a.get(child)).compareTo(Comparable a.get(child + 1)) < 0 then do
child = child + 1
end
end
if (Comparable a.get(root)).compareTo(Comparable a.get(child)) < 0 then do
swap = a.get(root)
a.set(root, a.get(child))
a.set(child, swap)
root = child
end
else do
leave root
end
end root
 
return a
Output:
UK  London
US  New York
US  Boston
US  Washington
UK  Washington
US  Birmingham
UK  Birmingham
UK  Boston

UK  Birmingham
UK  Boston
UK  London
UK  Washington
US  Birmingham
US  Boston
US  New York
US  Washington

Nim[edit]

proc siftDown[T](a: var openarray[T]; start, ending: int) =
var root = start
while root * 2 + 1 < ending:
var child = 2 * root + 1
if child + 1 < ending and a[child] < a[child+1]:
inc child
if a[root] < a[child]:
swap a[child], a[root]
root = child
else:
return
 
proc heapSort[T](a: var openarray[T]) =
let count = a.len
for start in countdown((count - 2) div 2, 0):
siftDown(a, start, count)
for ending in countdown(count - 1, 1):
swap a[ending], a[0]
siftDown(a, 0, ending)
 
var a = @[4, 65, 2, -31, 0, 99, 2, 83, 782]
heapSort a
echo a
Output:
@[-31, 0, 2, 2, 4, 65, 83, 99, 782]

Objeck[edit]

Translation of: Java
bundle Default {
class HeapSort {
function : Main(args : String[]) ~ Nil {
values := [4, 3, 1, 5, 6, 2];
HeapSort(values);
each(i : values) {
values[i]->PrintLine();
};
}
 
function : HeapSort(a : Int[]) ~ Nil {
count := a->Size();
Heapify(a, count);
 
end := count - 1;
while(end > 0) {
tmp := a[end];
a[end] := a[0];
a[0] := tmp;
SiftDown(a, 0, end - 1);
end -= 1;
};
}
 
function : Heapify(a : Int[], count : Int) ~ Nil {
start := (count - 2) / 2;
while(start >= 0) {
SiftDown(a, start, count - 1);
start -= 1;
};
}
 
function : SiftDown(a : Int[], start : Int, end : Int) ~ Nil {
root := start;
while((root * 2 + 1) <= end) {
child := root * 2 + 1;
if(child + 1 <= end & a[child] < a[child + 1]) {
child := child + 1;
};
 
if(a[root] < a[child]) {
tmp := a[root];
a[root] := a[child];
a[child] := tmp;
root := child;
}
else {
return;
};
};
}
}
}

OCaml[edit]

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

Oz[edit]

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}}

Pascal[edit]

An example, which works on arrays with arbitrary bounds :-)

program HeapSortDemo;
 
type
TIntArray = array[4..15] of integer;
 
var
data: TIntArray;
i: integer;
 
procedure siftDown(var a: TIntArray; start, ende: integer);
var
root, child, swap: integer;
begin
root := start;
while root * 2 - start + 1 <= ende do
begin
child := root * 2 - start + 1;
if (child + 1 <= ende) and (a[child] < a[child + 1]) then
inc(child);
if a[root] < a[child] then
begin
swap := a[root];
a[root] := a[child];
a[child] := swap;
root := child;
end
else
exit;
end;
end;
 
procedure heapify(var a: TIntArray);
var
start, count: integer;
begin
count := length(a);
start := low(a) + count div 2 - 1;
while start >= low(a) do
begin
siftdown(a, start, high(a));
dec(start);
end;
end;
 
procedure heapSort(var a: TIntArray);
var
ende, swap: integer;
begin
heapify(a);
ende := high(a);
while ende > low(a) do
begin
swap := a[low(a)];
a[low(a)] := a[ende];
a[ende] := swap;
dec(ende);
siftdown(a, low(a), ende);
end;
end;
 
begin
Randomize;
writeln('The data before sorting:');
for i := low(data) to high(data) do
begin
data[i] := Random(high(data));
write(data[i]:4);
end;
writeln;
heapSort(data);
writeln('The data after sorting:');
for i := low(data) to high(data) do
begin
write(data[i]:4);
end;
writeln;
end.
Output:
The data before sorting:
  12  13   0   1   0  14  13  10   1  10   9   2
The data after sorting:
   0   0   1   1   2   9  10  10  12  13  13  14

Perl[edit]

#!/usr/bin/perl
 
my @a = (4, 65, 2, -31, 0, 99, 2, 83, 782, 1);
print "@a\n";
heap_sort(\@a);
print "@a\n";
 
sub heap_sort {
my ($a) = @_;
my $n = @$a;
for (my $i = ($n - 2) / 2; $i >= 0; $i--) {
down_heap($a, $n, $i);
}
for (my $i = 0; $i < $n; $i++) {
my $t = $a->[$n - $i - 1];
$a->[$n - $i - 1] = $a->[0];
$a->[0] = $t;
down_heap($a, $n - $i - 1, 0);
}
}
 
sub down_heap {
my ($a, $n, $i) = @_;
while (1) {
my $j = max($a, $n, $i, 2 * $i + 1, 2 * $i + 2);
last if $j == $i;
my $t = $a->[$i];
$a->[$i] = $a->[$j];
$a->[$j] = $t;
$i = $j;
}
}
 
sub max {
my ($a, $n, $i, $j, $k) = @_;
my $m = $i;
$m = $j if $j < $n && $a->[$j] > $a->[$m];
$m = $k if $k < $n && $a->[$k] > $a->[$m];
return $m;
}
 

Perl 6[edit]

sub heap_sort ( @list ) {
for ( 0 ..^ +@list div 2 ).reverse -> $start {
_sift_down $start, @list.end, @list;
}
 
for ( 1 ..^ +@list ).reverse -> $end {
@list[ 0, $end ] .= reverse;
_sift_down 0, $end-1, @list;
}
}
 
sub _sift_down ( $start, $end, @list ) {
my $root = $start;
while ( my $child = $root * 2 + 1 ) <= $end {
$child++ if $child + 1 <= $end and [<] @list[ $child, $child+1 ];
return if @list[$root] >= @list[$child];
@list[ $root, $child ] .= reverse;
$root = $child;
}
}
 
my @data = 6, 7, 2, 1, 8, 9, 5, 3, 4;
say 'Input = ' ~ @data;
@data.&heap_sort;
say 'Output = ' ~ @data;
Output:
Input  = 6 7 2 1 8 9 5 3 4
Output = 1 2 3 4 5 6 7 8 9

Phix[edit]

function siftDown(sequence arr, integer s, integer last)
integer root = s
while root*2<=last do
integer child = root*2
if child<last and arr[child]<arr[child+1] then
child += 1
end if
if arr[root]>=arr[child] then exit end if
object tmp = arr[root]
arr[root] = arr[child]
arr[child] = tmp
root = child
end while
return arr
end function
 
function heapify(sequence arr, integer count)
integer s = floor(count/2)
while s>0 do
arr = siftDown(arr,s,count)
s -= 1
end while
return arr
end function
 
function heap_sort(sequence arr)
integer last = length(arr)
arr = heapify(arr,last)
while last>1 do
object tmp = arr[1]
arr[1] = arr[last]
arr[last] = tmp
last -= 1
arr = siftDown(arr,1,last)
end while
return arr
end function
 
?heap_sort({5,"oranges","and",3,"apples"})
Output:
{3,5,"and","apples","oranges"}

PicoLisp[edit]

(de heapSort (A Cnt)
(let Cnt (length A)
(for (Start (/ Cnt 2) (gt0 Start) (dec Start))
(siftDown A Start (inc Cnt)) )
(for (End Cnt (> End 1) (dec End))
(xchg (nth A End) A)
(siftDown A 1 End) ) )
A )
 
(de siftDown (A Start End)
(use Child
(for (Root Start (> End (setq Child (* 2 Root))))
(and
(> End (inc Child))
(> (get A (inc Child)) (get A Child))
(inc 'Child) )
(NIL (> (get A Child) (get A Root)))
(xchg (nth A Root) (nth A Child))
(setq Root Child) ) ) )
Output:
: (heapSort (make (do 9 (link (rand 1 999)))))
-> (1 167 183 282 524 556 638 891 902)

PL/I[edit]

*process source xref attributes or(!);
/*********************************************************************
* Pseudocode found here:
* http://en.wikipedia.org/wiki/Heapsort#Pseudocode
* Sample data from REXX
* 27.07.2013 Walter Pachl
*********************************************************************/

heaps: Proc Options(main);
Dcl a(0:25) Char(50) Var Init(
'---letters of the modern Greek Alphabet---',
'==========================================',
'alpha','beta','gamma','delta','epsilon','zeta','eta','theta',
'iota','kappa','lambda','mu','nu','xi','omicron','pi',
'rho','sigma','tau','upsilon','phi','chi','psi','omega');
Dcl n Bin Fixed(31) Init((hbound(a)+1));
 
Call showa('before sort');
Call heapsort((n));
Call showa(' after sort');
 
heapSort: Proc(count);
Dcl (count,end) Bin Fixed(31);
Call heapify((count));
end=count-1;
do while(end>0);
Call swap(end,0);
end=end-1;
Call siftDown(0,(end));
End;
End;
 
heapify: Proc(count);
Dcl (count,start) Bin Fixed(31);
start=(count-2)/2;
Do while (start>=0);
Call siftDown((start),count-1);
start=start-1;
End;
End;
 
siftDown: Proc(start,end);
Dcl (count,start,root,end,child,sw) Bin Fixed(31);
root=start;
Do while(root*2+1<= end);
child=root*2+1;
sw=root;
if a(sw)<a(child) Then
sw=child;
if child+1<=end & a(sw)<a(child+1) Then
sw=child+1;
if sw^=root Then Do;
Call swap(root,sw);
root=sw;
End;
else
return;
End;
End;
 
swap: Proc(x,y);
Dcl (x,y) Bin Fixed(31);
Dcl temp Char(50) Var;
temp=a(x);
a(x)=a(y);
a(y)=temp;
End;
 
showa: Proc(txt);
Dcl txt Char(*);
Dcl j Bin Fixed(31);
Do j=0 To hbound(a);
Put Edit('element',j,txt,a(j))(skip,a,f(3),x(1),a,x(1),a);
End;
End;
 
End;
Output:
element  0 before sort ---letters of the modern Greek Alphabet---
element  1 before sort ==========================================
element  2 before sort alpha
element  3 before sort beta
element  4 before sort gamma
element  5 before sort delta
element  6 before sort epsilon
element  7 before sort zeta
element  8 before sort eta
element  9 before sort theta
element 10 before sort iota
element 11 before sort kappa
element 12 before sort lambda
element 13 before sort mu
element 14 before sort nu
element 15 before sort xi
element 16 before sort omicron
element 17 before sort pi
element 18 before sort rho
element 19 before sort sigma
element 20 before sort tau
element 21 before sort upsilon
element 22 before sort phi
element 23 before sort chi
element 24 before sort psi
element 25 before sort omega
element  0  after sort ---letters of the modern Greek Alphabet---
element  1  after sort ==========================================
element  2  after sort alpha
element  3  after sort beta
element  4  after sort chi
element  5  after sort delta
element  6  after sort epsilon
element  7  after sort eta
element  8  after sort gamma
element  9  after sort iota
element 10  after sort kappa
element 11  after sort lambda
element 12  after sort mu
element 13  after sort nu
element 14  after sort omega
element 15  after sort omicron
element 16  after sort phi
element 17  after sort pi
element 18  after sort psi
element 19  after sort rho
element 20  after sort sigma
element 21  after sort tau
element 22  after sort theta
element 23  after sort upsilon
element 24  after sort xi
element 25  after sort zeta

PowerShell[edit]

 
function heapsort($a, $count) {
$a = heapify $a $count
$end = $count - 1
while( $end -gt 0) {
$a[$end], $a[0] = $a[0], $a[$end]
$end--
$a = siftDown $a 0 $end
}
$a
}
function heapify($a, $count) {
$start = [Math]::Floor(($count - 2) / 2)
while($start -ge 0) {
$a = siftDown $a $start ($count-1)
$start--
}
$a
}
function siftdown($a, $start, $end) {
$b, $root = $true, $start
while(( ($root * 2 + 1) -le $end) -and $b) {
$child = $root * 2 + 1
if( ($child + 1 -le $end) -and ($a[$child] -lt $a[$child + 1]) ) {
$child++
}
if($a[$root] -lt $a[$child]) {
$a[$root], $a[$child] = $a[$child], $a[$root]
$root = $child
}
else { $b = $false}
}
$a
}
$array = @(60, 21, 19, 36, 63, 8, 100, 80, 3, 87, 11)
"$(heapsort $array $array.Count)"
 

Output:

3 8 11 19 21 36 60 63 80 87 100

PureBasic[edit]

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

Python[edit]

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]

Racket[edit]

 
#lang racket
(require (only-in srfi/43 vector-swap!))
 
(define (heap-sort! xs)
(define (ref i) (vector-ref xs i))
(define (swap! i j) (vector-swap! xs i j))
(define size (vector-length xs))
 
(define (sift-down! r end)
(define c (+ (* 2 r) 1))
(define c+1 (+ c 1))
(when (<= c end)
(define child
(if (and (<= c+1 end) (< (ref c) (ref c+1)))
c+1 c))
(when (< (ref r) (ref child))
(swap! r child))
(sift-down! child end)))
 
(for ([i (in-range (quotient (- size 2) 2) -1 -1)])
(sift-down! i (- size 1)))
 
(for ([end (in-range (- size 1) 0 -1)])
(swap! 0 end)
(sift-down! 0 (- end 1)))
xs)
 

REXX[edit]

version 1[edit]

This REXX version uses a heapsort to sort elements of an array, the elements can be numbers or character strings.

Indexing of the array (for this version) starts with   1   (one),   but can be programmed to start with zero.

/*REXX program sorts an array (names of modern Greek letters) using a heapsort algorithm*/
@.=; @.1='alpha'  ; @.6 ="zeta" ; @.11='lambda' ; @.16="pi"  ; @.21='phi'
@.2='beta'  ; @.7 ="eta"  ; @.12='mu'  ; @.17="rho"  ; @.22='chi'
@.3='gamma'  ; @.8 ="theta"; @.13='nu'  ; @.18="sigma" ; @.23='psi'
@.4='delta'  ; @.9 ="iota" ; @.14='xi'  ; @.19="tau"  ; @.24='omega'
@.5='epsilon'; @.10="kappa"; @.15='omicron'; @.20="upsilon"
do #=1 while @.#\==''; end; #=#-1 /*find # entries.*/
call show "before sort:"
call heapSort #; say copies('▒', 40) /*sort; show sep.*/
call show " after sort:"
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
heapSort: procedure expose @.; arg n; do j=n%2 by -1 to 1; call shuffle j,n; end /*j*/
do n=n by -1 to 2; _=@.1; @.1=@.n; @.n=_; call shuffle 1,n-1
end /*n*/ /* [↑] swap two elements; and shuffle.*/
return
/*──────────────────────────────────────────────────────────────────────────────────────*/
shuffle: procedure expose @.; parse arg i,n; $=@.i /*obtain parent. */
do while i+i<=n; j=i+i; k=j+1
if k<=n then if @.k>@.j then j=k
if $>=@.j then leave; @.i=@.j; i=j
end /*while*/
@.i=$; return
/*──────────────────────────────────────────────────────────────────────────────────────*/
show: do e=1 for #; say ' element' right(e,length(#)) arg(1) @.e; end; return

output   using the (default) Greek alphabet for input:

    element  1 before sort: alpha
    element  2 before sort: beta
    element  3 before sort: gamma
    element  4 before sort: delta
    element  5 before sort: epsilon
    element  6 before sort: zeta
    element  7 before sort: eta
    element  8 before sort: theta
    element  9 before sort: iota
    element 10 before sort: kappa
    element 11 before sort: lambda
    element 12 before sort: mu
    element 13 before sort: nu
    element 14 before sort: xi
    element 15 before sort: omicron
    element 16 before sort: pi
    element 17 before sort: rho
    element 18 before sort: sigma
    element 19 before sort: tau
    element 20 before sort: upsilon
    element 21 before sort: phi
    element 22 before sort: chi
    element 23 before sort: psi
    element 24 before sort: omega
▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
    element  1  after sort: alpha
    element  2  after sort: beta
    element  3  after sort: chi
    element  4  after sort: delta
    element  5  after sort: epsilon
    element  6  after sort: eta
    element  7  after sort: gamma
    element  8  after sort: iota
    element  9  after sort: kappa
    element 10  after sort: lambda
    element 11  after sort: mu
    element 12  after sort: nu
    element 13  after sort: omega
    element 14  after sort: omicron
    element 15  after sort: phi
    element 16  after sort: pi
    element 17  after sort: psi
    element 18  after sort: rho
    element 19  after sort: sigma
    element 20  after sort: tau
    element 21  after sort: theta
    element 22  after sort: upsilon
    element 23  after sort: xi
    element 24  after sort: zeta

version 2[edit]

This REXX version creates a stemmed array from a list   (it can be numbers or characters).

/*REXX program sorts a list (names of modern Greek letters) using a  heapsort algorithm.*/
parse arg g /*obtain optional argument from the CL.*/
if g='' then g= 'alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu',
"xi omicron pi rho sigma tau upsilon phi chi psi omega" /*adjust # [↓] */
do #=1 for words(g); @.#=word(g,#); end; #=#-1
call show "before sort:"
call heapSort #; say copies('▒', 40) /*sort; show sep*/
call show " after sort:"
exit /*stick a fork in it, we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
heapSort: procedure expose @.; arg n; do j=n%2 by -1 to 1; call shuffle j,n; end /*j*/
do n=n by -1 to 2; _=@.1; @.1=@.n; @.n=_; call shuffle 1,n-1
end /*n*/ /* [↑] swap two elements; and shuffle.*/
return
/*──────────────────────────────────────────────────────────────────────────────────────*/
shuffle: procedure expose @.; parse arg i,n; $=@.i /*obtain parent. */
do while i+i<=n; j=i+i; k=j+1
if k<=n then if @.k>@.j then j=k
if $>=@.j then leave; @.i=@.j; i=j
end /*while*/
@.i=$; return
/*──────────────────────────────────────────────────────────────────────────────────────*/
show: do e=1 for #; say ' element' right(e,length(#)) arg(1) @.e; end; return

output   is the same as the 1st REXX version when using the default input.


output   when using the following for input:   19 0 -.2 .1 1e5 19 17 -6 789 11 37

    element  1 before sort: 19
    element  2 before sort: 0
    element  3 before sort: -.2
    element  4 before sort: .1
    element  5 before sort: 1e5
    element  6 before sort: 19
    element  7 before sort: 17
    element  8 before sort: -6
    element  9 before sort: 789
    element 10 before sort: 11
    element 11 before sort: 37
▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
    element  1  after sort: -6
    element  2  after sort: -.2
    element  3  after sort: 0
    element  4  after sort: .1
    element  5  after sort: 11
    element  6  after sort: 17
    element  7  after sort: 19
    element  8  after sort: 19
    element  9  after sort: 37
    element 10  after sort: 789
    element 11  after sort: 1e5

version 3[edit]

/* REXX ***************************************************************
* Translated from PL/I
* 27.07.2013 Walter Pachl
**********************************************************************/

list='---letters of the modern Greek Alphabet---|'||,
'==========================================|'||,
'alpha|beta|gamma|delta|epsilon|zeta|eta|theta|'||,
'iota|kappa|lambda|mu|nu|xi|omicron|pi|'||,
'rho|sigma|tau|upsilon|phi|chi|psi|omega'
Do i=0 By 1 While list<>''
Parse Var list a.i '|' list
End
n=i-1
 
Call showa 'before sort'
Call heapsort n
Call showa ' after sort'
Exit
 
heapSort: Procedure Expose a.
Parse Arg count
Call heapify count
end=count-1
do while end>0
Call swap end,0
end=end-1
Call siftDown 0,end
End
Return
 
heapify: Procedure Expose a.
Parse Arg count
start=(count-2)%2
Do while start>=0
Call siftDown start,count-1
start=start-1
End
Return
 
siftDown: Procedure Expose a.
Parse Arg start,end
root=start
Do while root*2+1<= end
child=root*2+1
sw=root
if a.sw<a.child Then
sw=child
child_1=child+1
if child+1<=end & a.sw<a.child_1 Then
sw=child+1
if sw<>root Then Do
Call swap root,sw
root=sw
End
else
return
End
Return
 
swap: Procedure Expose a.
Parse arg x,y
temp=a.x
a.x=a.y
a.y=temp
Return
 
showa: Procedure Expose a. n
Parse Arg txt
Do j=0 To n-1
Say 'element' format(j,2) txt a.j
End
Return

Output: see PL/I

Ruby[edit]

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]

Rust[edit]

Translation of: Python

This program allows the caller to specify an arbitrary function by which an order is determined.

fn main() {
let mut v = [4,6,8,1,0,3,2,2,9,5];
heap_sort(&mut v, |x,y| x < y);
println!("{:?}", v);
}
 
fn heap_sort<T,F>(array: &mut [T], order: F)
where F: Fn(&T,&T) -> bool
{
let len = array.len();
// Create heap
for start in (0..len/2).rev() {
sift_down(array,&order,start,len-1)
}
 
for end in (1..len).rev() {
array.swap(0,end);
sift_down(array,&order,0,end-1)
}
}
 
fn sift_down<T,F>(array: &mut [T], order: &F, start: usize, end: usize)
where F: Fn(&T,&T) -> bool
{
let mut root = start;
loop {
let mut child = root * 2 + 1;
if child > end { break; }
if child + 1 <= end && order(&array[child], &array[child + 1]) {
child += 1;
}
if order(&array[root], &array[child]) {
array.swap(root,child);
root = child
} else {
break;
}
}
}

Of course, you could also simply use BinaryHeap in the standard library.

use std::collections::BinaryHeap;
 
fn main() {
let src = vec![6,2,3,6,1,2,7,8,3,2];
let sorted= BinaryHeap::from(src).into_sorted_vec();
println!("{:?}", sorted);
}

Scala[edit]

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)
}
}

Scheme[edit]

Works with: Scheme version RRS
; 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)

Seed7[edit]

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]

Sidef[edit]

func sift_down(a, start, end) {
var root = start;
while ((2*root + 1) <= end) {
var child = (2*root + 1);
if ((child+1 <= end) && (a[child] < a[child + 1])) {
child += 1;
}
if (a[root] < a[child]) {
a[child, root] = a[root, child];
root = child;
} else {
return;
}
}
}
 
func heapify(a, count) {
var start = ((count - 2) / 2);
while (start >= 0) {
sift_down(a, start, count-1);
start -= 1;
}
}
 
func heap_sort(a, count) {
heapify(a, count);
var end = (count - 1);
while (end > 0) {
a[0, end] = a[end, 0];
end -= 1;
sift_down(a, 0, end)
}
return a
}
 
var arr = (1..10 -> shuffle); # creates a shuffled array
say arr; # prints the unsorted array
heap_sort(arr, arr.len); # sorts the array in-place
say arr; # prints the sorted array
Output:
[10, 5, 2, 1, 7, 6, 4, 8, 3, 9]
[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]

Standard ML[edit]

Since Standard ML is a functional language, a pairing heap is used instead of a standard binary heap.

(* Pairing heap - http://en.wikipedia.org/wiki/Pairing_heap *)
functor PairingHeap(type t
val cmp : t * t -> order) =
struct
datatype 'a heap = Empty
| Heap of 'a * 'a heap list;
 
(* merge, O(1)
* Merges two heaps *)
fun merge (Empty, h) = h
| merge (h, Empty) = h
| merge (h1 as Heap(e1, s1), h2 as Heap(e2, s2)) =
case cmp (e1, e2) of LESS => Heap(e1, h2 :: s1)
| _ => Heap(e2, h1 :: s2)
 
(* insert, O(1)
* Inserts an element into the heap *)
fun insert (e, h) = merge (Heap (e, []), h)
 
(* findMin, O(1)
* Returns the smallest element of the heap *)
fun findMin Empty = raise Domain
| findMin (Heap(e, _)) = e
 
(* deleteMin, O(lg n) amortized
* Deletes the smallest element of the heap *)
local
fun mergePairs [] = Empty
| mergePairs [h] = h
| mergePairs (h1::h2::hs) = merge (merge(h1, h2), mergePairs hs)
in
fun deleteMin Empty = raise Domain
| deleteMin (Heap(_, s)) = mergePairs s
end
 
(* build, O(n)
* Builds a heap from a list *)
fun build es = foldl insert Empty es;
end
 
local
structure IntHeap = PairingHeap(type t = int; val cmp = Int.compare);
open IntHeap
 
fun heapsort' Empty = []
| heapsort' h = findMin h :: (heapsort' o deleteMin) h;
in
fun heapsort ls = (heapsort' o build) ls
 
val test_0 = heapsort [] = []
val test_1 = heapsort [1,2,3] = [1, 2, 3]
val test_2 = heapsort [1,3,2] = [1, 2, 3]
val test_3 = heapsort [6,2,7,5,8,1,3,4] = [1, 2, 3, 4, 5, 6, 7, 8]
end;
 

Swift[edit]

func heapsort<T:Comparable>(inout list:[T]) {
var count = list.count
 
func shiftDown(inout list:[T], start:Int, end:Int) {
var root = start
 
while root * 2 + 1 <= end {
var child = root * 2 + 1
var swap = root
 
if list[swap] < list[child] {
swap = child
}
 
if child + 1 <= end && list[swap] < list[child + 1] {
swap = child + 1
}
 
if swap == root {
return
} else {
(list[root], list[swap]) = (list[swap], list[root])
root = swap
}
}
}
 
func heapify(inout list:[T], count:Int) {
var start = (count - 2) / 2
 
while start >= 0 {
shiftDown(&list, start, count - 1)
 
start--
}
}
 
heapify(&list, count)
 
var end = count - 1
 
while end > 0 {
(list[end], list[0]) = (list[0], list[end])
 
end--
 
shiftDown(&list, 0, end)
}
}

Tcl[edit]

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

TI-83 BASIC[edit]

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).

: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

uBasic/4tH[edit]

PRINT "Heap sort:"
n = FUNC (_InitArray)
PROC _ShowArray (n)
PROC _Heapsort (n)
PROC _ShowArray (n)
PRINT
 
END
 
 
_Heapsort PARAM(1) ' Heapsort
LOCAL(1)
PROC _Heapify (a@)
 
b@ = a@ - 1
DO WHILE b@ > 0
PROC _Swap (b@, 0)
PROC _Siftdown (0, b@)
b@ = b@ - 1
LOOP
RETURN
 
 
_Heapify PARAM(1)
LOCAL(1)
 
b@ = (a@ - 2) / 2
DO WHILE b@ > -1
PROC _Siftdown (b@, a@)
b@ = b@ - 1
LOOP
RETURN
 
 
_Siftdown PARAM(2)
LOCAL(2)
c@ = a@
 
DO WHILE ((c@ * 2) + 1) < (b@)
d@ = c@ * 2 + 1
IF d@+1 < b@ IF @(d@) < @(d@+1) THEN d@ = d@ + 1
WHILE @(c@) < @(d@)
PROC _Swap (d@, c@)
c@ = d@
LOOP
 
RETURN
 
 
_Swap PARAM(2) ' Swap two array elements
PUSH @(a@)
@(a@) = @(b@)
@(b@) = POP()
RETURN
 
 
_InitArray ' Init example array
PUSH 4, 65, 2, -31, 0, 99, 2, 83, 782, 1
 
FOR i = 0 TO 9
@(i) = POP()
NEXT
 
RETURN (i)
 
 
_ShowArray PARAM (1) ' Show array subroutine
FOR i = 0 TO a@-1
PRINT @(i),
NEXT
 
PRINT
RETURN

zkl[edit]

fcn heapSort(a){  // in place
n := a.len();
foreach start in ([(n-2)/2 .. 0,-1])
{ siftDown(a, start, n-1) }
foreach end in ([n-1 .. 1,-1]){
a.swap(0, end);
siftDown(a, 0, end-1);
}
a
}
 
fcn siftDown(a, start, end){
while((child := start*2 + 1) <= end){
if(child < end and a[child]<a[child+1]) child+=1;
if(a[start] >= a[child]) return();
a.swap(start, child);
start = child;
}
}
heapSort(L(170, 45, 75, -90, -802, 24, 2, 66)).println();
heapSort("this is a test".split("")).println();
Output:
L(-802,-90,2,24,45,66,75,170)
L(" "," "," ","a","e","h","i","i","s","s","s","t","t","t")