Sorting algorithms/Heapsort: Difference between revisions

Content added Content deleted

Inline

Revision as of 23:48, 21 January 2019

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

Translation of: PL/I

The program uses ASM structured macros and two ASSIST macros (XDECO, XPRNT) to keep the code as short as possible. <lang 360asm>* 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</lang>

Output:

 -31   0   1   2   2   4  45  58  65  69  74  82  82  83  88  89  99 104 112 782

ActionScript

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

Ada

This implementation is a generic heapsort for unconstrained arrays. <lang Ada>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);</lang> <lang Ada>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;</lang> Demo code: <lang Ada>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;</lang>

ALGOL 68

<lang algol68>#--- 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))

)</lang>

Output:

Before:       +633       +972       +136       +494       +720       +326       +813       +980       +784       +760
                                                                                                                     
After:        +136       +326       +494       +633       +720       +760       +784       +813       +972       +980

AutoHotkey

<lang 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</lang>

BBC BASIC

<lang bbcbasic> 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</lang>

Output:

       -31         0         1         2         2         4        65        83        99       782

BCPL

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

}</lang>

C

<lang c>#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;

} </lang>

C++

Uses C++11. Compile with

g++ -std=c++11 heap.cpp

<lang 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";

}</lang>

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

}</lang>

Output:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

C#

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

}</lang>

Clojure

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

</lang> Example usage: <lang lisp>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]</lang>

COBOL

Works with: GnuCOBOL

<lang cobol> >>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.</lang>

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

<lang coffeescript># 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</lang>

Output:

> coffee heap.coffee 
[ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 ]

Common Lisp

<lang 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)))))</lang>

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

<lang d>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;

}</lang>

A lower level implementation: <lang d>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;

}</lang>

Dart

<lang dart> 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"));

}

</lang>

E

Translation of: Python

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

}</lang>

EchoLisp

We use the heap library and the heap-pop primitive to implement heap-sort. <lang scheme> (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)

</lang>

Eiffel

<lang Eiffel> 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 </lang> Test: <lang Eiffel> 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 </lang>

Output:

Unsorted: 5 91 13 99 7 35
Sorted: 5 7 13 35 91 99

Elixir

<lang elixir>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</lang>

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#

<lang fsharp>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</lang>

Forth

This program assumes that return addresses simply reside as a single cell on the Return Stack. Most Forth compilers fulfill this requirement. <lang forth>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 </lang>

<lang forth> \ 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 </lang>

Output:

2 9 3 6 1 4 5 7 0 8 
0 1 2 3 4 5 6 7 8 9

Fortran

Works with: Fortran version 90 and later

Translation of the pseudocode <lang fortran>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</lang>

FreeBASIC

<lang freebasic>' 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 higher 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_) AndAlso (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 + 1
   Dim As Long start = (count - 2) \ 2
   Dim As ULong end_ = count - 1

   While start >= 0
       siftdown(hs(), start, end_)
       start = start - 1
   Wend

   While end_ > 0
       Swap hs(lb + end_), hs(lb)
       end_ = end_ - 1
       siftdown(hs(), 0, end_)
   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)

   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</lang>

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

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.

<lang funl>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 )</lang>

Output:

ArraySeq(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

Go

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

}</lang>

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: <lang go>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
   }

}</lang>

Groovy

Loose translation of the pseudocode: <lang groovy>def makeSwap = { a, i, j = i+1 -> print "."; aj,i = ai,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

}</lang> Test: <lang groovy>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]))</lang>

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

Using package fgl from HackageDB <lang haskell>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))</lang> e.g. <lang haskell>*Main> heapsort [[6,9],[2,13],[6,8,14,9],[10,7],[5]] [[2,13],[5],[6,8,14,9],[6,9],[10,7]]</lang>

Icon and Unicon

<lang 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</lang> 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

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 <lang j>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

)</lang> Examples <lang j> 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</lang>

Java

Direct translation of the pseudocode. <lang java>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; } }</lang>

JavaScript

Translation of: CoffeeScript

<lang Javascript> 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);
   var 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);</lang>

Output:

    [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15]

Julia

<lang julia>function percolate_down!(a, first, last)

   r = first
   while 2 * r + 1 <= last
       c = 2 * r + 1
       if c + 1 <= last && a[c + 1] < a[c + 2]
           c += 1
       end
       if a[r + 1] < a[c + 1]
           a[c + 1], a[r + 1] = a[r + 1], a[c + 1]
           r = c
       else
           break
       end
   end

end

function heapify!(a, n)

   first = div(n - 2, 2)
   while first >= 0
       percolate_down!(a, first, n - 1)
       first -= 1
   end

end

function heapsort(a)

   n = length(a)
   heapify!(a, n)
   last = n - 1
   while last > 0
       a[1], a[last + 1] = a[last + 1], a[1]
       last -= 1
       percolate_down!(a, 0, last)
   end
   a

end

a = shuffle(collect(1:12)) println("Unsorted: $a") println("Heap sorted: ", heapsort(a))

</lang>

Output:


Unsorted: [3, 12, 11, 4, 2, 7, 5, 8, 9, 1, 10, 6]
Heap sorted: [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12]

Kotlin

<lang scala>// 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(", "))
   }

}</lang>

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

<lang lb>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</lang>

LotusScript

<lang LotusScript> 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 </lang>

M4

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

Maple

<lang>swap := proc(arr, a, b) local temp: temp := arr[a]: arr[a] := arr[b]: arr[b] := temp: end proc: heapify := proc(toSort, n, i) local largest, l, r, holder: largest := i: l := 2*i: r := 2*i+1: if (l <= n and toSort[l] > toSort[largest]) then largest := l: end if: if (r <= n and toSort[r] > toSort[largest]) then largest := r: end if: if (not largest = i) then swap(toSort, i, largest); heapify(toSort, n, largest): end if: end proc: heapsort := proc(arr) local n,i: n := numelems(arr): for i from trunc(n/2) to 1 by -1 do heapify(arr, n, i): end do: for i from n to 2 by -1 do swap(arr, 1, i): heapify(arr, i-1, 1): end do: end proc: arr := Array([17,3,72,0,36,2,3,8,40,0]); heapsort(arr); arr;</lang>

Output:

[0,0,2,3,3,8,17,36,40,72]

Mathematica

<lang Mathematica>siftDown[list_,root_,theEnd_]:=

While[(root*2) <= theEnd,
 child = root*2;
 If[(child+1 <= theEnd)&&(listchild < listchild+1), child++;];
 If[listroot < listchild,
  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];
]

]</lang>

Output:

heapSort@{2,3,1,5,7,6}
{1,2,3,5,6,7}

MATLAB / Octave

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. <lang MATLAB>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</lang> Sample Usage: <lang MATLAB>>> heapSort([4 3 1 5 6 2])

ans =

    1     2     3     4     5     6</lang>

MAXScript

<lang MAXScript>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 )

)</lang> Output: <lang MAXScript> 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)

</lang>

NetRexx

<lang NetRexx>/* 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</lang>

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

<lang nim>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</lang>

Output:

@[-31, 0, 2, 2, 4, 65, 83, 99, 782]

Objeck

Translation of: Java

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

}</lang>

OCaml

<lang 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;;</lang>

Usage: <lang ocaml>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 ();;</lang>

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

A faithful translation of the pseudocode, adjusted to the fact that Oz arrays can start with an arbitrary index, not just 0 or 1. <lang oz>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}}</lang>

Pascal

An example, which works on arrays with arbitrary bounds :-) <lang pascal>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.</lang>

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

<lang perl>#!/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;

} </lang>

Perl 6

<lang perl6>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;</lang>

Output:

Input  = 6 7 2 1 8 9 5 3 4
Output = 1 2 3 4 5 6 7 8 9

Phix

<lang Phix>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"})</lang>

Output:

{3,5,"and","apples","oranges"}

PicoLisp

<lang PicoLisp>(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) ) ) )</lang>

Output:

: (heapSort (make (do 9 (link (rand 1 999)))))
-> (1 167 183 282 524 556 638 891 902)

PL/I

<lang pli>*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;</lang>

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

<lang PowerShell> 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)" </lang> Output:

3 8 11 19 21 36 60 63 80 87 100

PureBasic

<lang 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</lang>

Python

<lang 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</lang>

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

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)

</lang>

REXX

version 1, elements of an array

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

Indexing of the array (for this version) starts with 1 (one), but can be programmed to start with zero. <lang rexx>/*REXX pgm sorts an array (names of epichoric Greek letters) using a heapsort algorithm.*/ @.=; @.1= 'alpha' ; @.7 = "zeta" ; @.13= 'mu' ; @.19= "qoppa" ; @.25= 'chi'

    @.2= 'beta'   ;   @.8 = "eta"   ;   @.14= 'nu'     ;  @.20= "rho"    ;  @.26= 'psi'
    @.3= 'gamma'  ;   @.9 = "theta" ;   @.15= 'xi'     ;  @.21= "sigma"  ;  @.27= 'omega'
    @.4= 'delta'  ;   @.10= "iota"  ;   @.16= 'omicron';  @.22= "tau"
    @.5= 'digamma';   @.11= "kappa" ;   @.17= 'pi'     ;  @.23= "upsilon"
    @.6= 'epsilon';   @.12= "lambda";   @.18= 'san'    ;  @.24= "phi"
                           do #=1  until @.#==;  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 s=1 for #; say ' element' right(s, length(#)) arg(1) @.s; end; return</lang>

output when using the default (epichoric 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: digamma
    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: san
    element 19 before sort: qoppa
    element 20 before sort: rho
    element 21 before sort: sigma
    element 22 before sort: tau
    element 23 before sort: upsilon
    element 24 before sort: phi
    element 25 before sort: chi
    element 26 before sort: psi
    element 27 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: digamma
    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: qoppa
    element 20  after sort: rho
    element 21  after sort: san
    element 22  after sort: sigma
    element 23  after sort: tau
    element 24  after sort: theta
    element 25  after sort: upsilon
    element 26  after sort: xi
    element 27  after sort: zeta

version 2, elements of a list

This REXX version creates a stemmed array from a list (it can be numbers or characters, or a mixture of both). <lang rexx>/*REXX pgm sorts an array (names of epichoric Greek letters) using a heapsort algorithm.*/ parse arg g /*obtain optional arguments from the CL*/ if g= then g='alpha beta gamma delta digamma epsilon zeta eta theta iota kappa lambda',

               "mu nu xi omicron pi san qoppa  rho sigma tau upsilon phi chi psi omega"

=words(g); do i=1 for #; @.i=word(g,i); end /*assign to @. */

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 s=1 for #; say ' element' right(s, length(#)) arg(1) @.s; end; return</lang>

output is identical to the 1^st REXX version when using the default input (an epichoric Greek alphabet).

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

<lang rexx>/* 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</lang>

Output: see PL/I

Ring

Project : Sorting algorithms/Heapsort

test = [4, 65, 2, -31, 0, 99, 2, 83, 782, 1] see "before sort:" + nl showarray(test) heapsort(test) see "after sort:" + nl showarray(test)

func heapsort(a) cheapify(a) for e = len(a) to 1 step -1

    temp = a[e]
    a[e] = a[1]
    a[1] = temp
    siftdown(a, 1, e-1)

    siftdown(a,s,m)

        c = r * 2                  
        if c + 1 <= e
           if a[c] < a[c + 1]
              c = c + 1
           ok
        ok
        if a[r] < a[c]
           temp = a[r]
           a[r] = a[c]
           a[c] = temp  
           r = c    
        else
           exit 
        ok

end

func showarray(vect)

       svect = ""
       for n = 1 to len(vect)
             svect = svect + vect[n] + " "
       next
       svect = left(svect, len(svect) - 1)
       see svect + nl

</lang> Output:

before sort:
4 65 2 -31 0 99 2 83 782 1
after sort:
-31 0 1 2 2 4 65 83 99 782

Ruby

<lang 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</lang> 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

Translation of: Python

This program allows the caller to specify an arbitrary function by which an order is determined. <lang rust>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() {
       shift_down(array, &order, start, len - 1)
   }

   for end in (1..len).rev() {
       array.swap(0, end);
       shift_down(array, &order, 0, end - 1)
   }

}

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

}</lang>

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

<lang rust>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);

}</lang>

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. <lang scala>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)
 }

}</lang>

Scheme

Works with: Scheme version R

^{5}

RS

<lang scheme>; 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</lang>

Output:

done
#(0 1 2 3 4 5 6 7 8 9)

Seed7

<lang 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;</lang>

Original source: [1]

SequenceL

<lang sequenceL> import <Utilities/Sequence.sl>;

TUPLE<T> ::= (A: T, B: T);

heapSort(x(1)) := let heapified := heapify(x, (size(x) - 2) / 2 + 1); in sortLoop(heapified, size(heapified));

heapify(x(1), i) := x when i <= 0 else heapify(siftDown(x, i, size(x)), i - 1);

sortLoop(x(1), i) := x when i <= 2 else sortLoop( siftDown(swap(x, 1, i), 1, i - 1), i - 1);

siftDown(x(1), start, end) := let child := start * 2; child1 := child + 1 when child + 1 <= end and x[child] < x[child + 1] else child; in x when child >= end else x when x[start] >= x[child1] else siftDown(swap(x, child1, start), child1, end);

swap(list(1), i, j) := let vals := (A: list[i], B: list[j]); in setElementAt(setElementAt(list, i, vals.B), j, vals.A); </lang>

Sidef

<lang ruby>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</lang>

Output:

[10, 5, 2, 1, 7, 6, 4, 8, 3, 9]
[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]

Standard ML

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

<lang sml>(* 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; </lang>

Swift

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

}</lang>

Tcl

Based on the algorithm from Wikipedia:

Works with: Tcl version 8.5

<lang tcl>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

}</lang> Demo code: <lang tcl>puts [heapsort {1 5 3 7 9 2 8 4 6 0}]</lang>

Output:

0 1 2 3 4 5 6 7 8 9

TI-83 BASIC

Store list with a dimension of 7 or less into L₁ (if less input will be padded with zeros), run prgmSORTHEAP, look into L₂ for the sorted version of L₁. It is possible to do this without L₃ (thus, in place).

:If dim(L₁)>7
:Then
:Disp "ERR:7"
:Stop
:End
:If dim(L₁)<7
:Then
:For(A,1,7)
:If A>dim(L₁)
:0→L₁(A)
:End
:End
:{0}→L₂
:For(B,2,7)
:0→L₂(B)
:End
:L₁→L₃
:For(B,0,6)
:If L₃(4)>L₃(2)
:Then
:L₃(2)→A
:L₃(4)→L₃(2)
:A→L₃(4)
:End
:If L₃(5)>L₃(2)
:Then
:L₃(2)→A
:L₃(5)→L₃(2)
:A→L₃(5)
:End
:If L₃(6)>L₃(3)
:Then
:L₃(3)→A
:L₃(6)→L₃(3)
:A→L₃(6)
:End
:If L₃(7)>L₃(3)
:Then
:L₃(3)→A
:L₃(7)→L₃(3)
:A→L₃(7)
:End
:If L₃(2)>L₃(1)
:Then
:L₃(1)→A
:L₃(2)→L₃(1)
:A→L₃(2)
:End
:If L₃(3)>L₃(1)
:Then
:L₃(1)→A
:L₃(3)→L₃(1)
:A→L₃(3)
:End
:L₃(1)→L₂(7-B)
:If L₃(2)>L₃(3)
:Then
:L₃(2)→L₃(1)
:0→L₃(2)
:Else
:L₃(3)→L₃(1)
:0→L₃(3)
:End
:End
:DelVar A
:DelVar B
:DelVar L₃
:Return

uBasic/4tH

<lang>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</lang>

VBA

Translation of: FreeBASIC

<lang VBA>Sub SiftDown(list() As Integer, start As Long, eend As Long) Dim root As Long : root = start Dim lb As Long : lb = LBound(list) Dim temp As Integer

While root * 2 + 1 <= eend Dim child As Long : child = root * 2 + 1 If child + 1 <= eend Then If list(lb + child) < list(lb + child + 1) Then child = child + 1 End If End If If list(lb + root) < list(lb + child) Then temp = list(lb + root) list(lb + root) = list(lb + child) list(lb + child) = temp

root = child Else Exit Sub End If Wend End Sub

Sub HeapSort(list() As Integer) Dim lb As Long : lb = LBound(list) Dim count As Long : count = UBound(list) - lb + 1 Dim start As Long : start = (count - 2) \ 2 Dim eend As Long : eend = count - 1

While start >= 0 SiftDown list(), start, eend start = start - 1 Wend

Dim temp As Integer

While eend > 0 temp = list(lb + eend) list(lb + eend) = list(lb) list(lb) = temp

eend = eend - 1

SiftDown list(), 0, eend Wend End Sub</lang>

zkl

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

}</lang> <lang zkl>heapSort(L(170, 45, 75, -90, -802, 24, 2, 66)).println(); heapSort("this is a test".split("")).println();</lang>

Output:

L(-802,-90,2,24,45,66,75,170)
L(" "," "," ","a","e","h","i","i","s","s","s","t","t","t")