Sorting algorithms/Heapsort

From Rosetta Code
Task
Sorting algorithms/Heapsort
You are encouraged to solve this task according to the task description, using any language you may know.
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.

A heap sort 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.

11l

Translation of: Python
F siftdown(&lst, start, end)
   V root = start
   L
      V child = root * 2 + 1
      I child > end
         L.break
      I child + 1 <= end & lst[child] < lst[child + 1]
         child++
      I lst[root] < lst[child]
         swap(&lst[root], &lst[child])
         root = child
      E
         L.break

F heapsort(&lst)
   L(start) ((lst.len - 2) I/ 2 .. 0).step(-1)
      siftdown(&lst, start, lst.len - 1)

   L(end) (lst.len - 1 .< 0).step(-1)
      swap(&lst[end], &lst[0])
      siftdown(&lst, 0, end - 1)

V arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
heapsort(&arr)
print(arr)
Output:
[0, 1, 2, 3, 4, 5, 6, 7, 8, 9]

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.

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

AArch64 Assembly

Works with: as version Raspberry Pi 3B version Buster 64 bits
/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program heapSort64.s   */
/* look Pseudocode begin this task  */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeConstantesARM64.inc"

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:  .asciz "\n"
 
.align 4
//TableNumber:         .quad   1,3,6,2,5,9,10,8,4,7
TableNumber:         .quad   10,9,8,7,6,-5,4,3,2,1
                 .equ NBELEMENTS, (. - TableNumber) / 8 
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:       .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main 
main:                                           // entry of program 
 
1:
    ldr x0,qAdrTableNumber                      // address number table
    mov x1,#NBELEMENTS                          // number of élements 
    bl heapSort
    ldr x0,qAdrTableNumber                      // address number table
    bl displayTable
 
    ldr x0,qAdrTableNumber                      // address number table
    mov x1,#NBELEMENTS                          // number of élements 
    bl isSorted                                 // control sort
    cmp x0,#1                                   // sorted ?
    beq 2f                                    
    ldr x0,qAdrszMessSortNok                    // no !! error sort
    bl affichageMess
    b 100f
2:                                              // yes
    ldr x0,qAdrszMessSortOk
    bl affichageMess
100:                                            // standard end of the program 
    mov x0, #0                                  // return code
    mov x8, #EXIT                               // request to exit program
    svc #0                                      // perform the system call
 
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableNumber:          .quad TableNumber
qAdrszMessSortOk:         .quad szMessSortOk
qAdrszMessSortNok:        .quad szMessSortNok
/******************************************************************/
/*     control sorted table                                   */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements  > 0  */
/* x0 return 0  if not sorted   1  if sorted */
isSorted:
    stp x2,lr,[sp,-16]!              // save  registers
    stp x3,x4,[sp,-16]!              // save  registers
    mov x2,#0
    ldr x4,[x0,x2,lsl 3]
1:
    add x2,x2,1
    cmp x2,x1
    bge 99f
    ldr x3,[x0,x2, lsl 3]
    cmp x3,x4
    blt 98f
    mov x4,x3
    b 1b
98:
    mov x0,0                      // not sorted
    b 100f
99:
    mov x0,1                      // sorted
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*         heap sort                                              */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of element */
heapSort:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    bl heapify                     // first place table in max-heap order
    sub x3,x1,1
1:
    cmp x3,0
    ble 100f
    mov x1,0                       // swap the root(maximum value) of the heap with the last element of the heap)
    mov x2,x3
    bl swapElement
    sub x3,x3,1
    mov x1,0
    mov x2,x3                      // put the heap back in max-heap order
    bl siftDown
    b 1b
 
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*      place table in max-heap order                             */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of element */
heapify:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    str x4,[sp,-16]!               // save  registers
    mov x4,x1
    sub x3,x1,2
    lsr x3,x3,1
1:
    cmp x3,0
    blt 100f
    mov x1,x3
    sub x2,x4,1
    bl siftDown
    sub x3,x3,1
    b 1b
100:
    ldr x4,[sp],16                 // restaur  1 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*     swap two elements of table                                  */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the first index */
/* x2 contains the second index */
swapElement:
    stp x2,lr,[sp,-16]!            // save  registers
    stp x3,x4,[sp,-16]!            // save  registers
    ldr x3,[x0,x1,lsl #3]          // swap number on the table
    ldr x4,[x0,x2,lsl #3]
    str x4,[x0,x1,lsl #3]
    str x3,[x0,x2,lsl #3]
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
 
/******************************************************************/
/*     put the heap back in max-heap order                        */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the first index */
/* x2 contains the last index */
siftDown:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    stp x4,x5,[sp,-16]!            // save  registers
    stp x6,x7,[sp,-16]!            // save  registers
                                   // x1 = root = start
    mov x3,x2                      // save last index
1:
    lsl x4,x1,1
    add x4,x4,1
    cmp x4,x3
    bgt 100f
    add x5,x4,1
    cmp x5,x3
    bgt 2f
    ldr x6,[x0,x4,lsl 3]           // compare elements on the table
    ldr x7,[x0,x5,lsl 3]
    cmp x6,x7
    csel x4,x5,x4,lt
    //movlt x4,x5
2:
    ldr x7,[x0,x4,lsl 3]           // compare elements on the table
    ldr x6,[x0,x1,lsl 3]           // root
    cmp x6,x7
    bge 100f
    mov x2,x4                      // and x1 is root
    bl swapElement
    mov x1,x4                      // root = child
    b 1b
 
100: 
    ldp x6,x7,[sp],16              // restaur  2 registers
    ldp x4,x5,[sp],16              // restaur  2 registers
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
 
/******************************************************************/
/*      Display table elements                                */ 
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    mov x2,x0                        // table address
    mov x3,0
1:                                   // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv
    bl conversion10S                  // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc            // insert result at @ character
    bl affichageMess                 // display message
    add x3,x3,1
    cmp x3,NBELEMENTS - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
    mov x0,x2
100:
    ldp x2,x3,[sp],16               // restaur  2 registers
    ldp x1,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30
qAdrsZoneConv:            .quad sZoneConv
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"

Action!

Translation of: PL/M
;;; HeapSort - tranlsated from the PL/M sample
;;; and using the test cases and test routines from
;;;     the Gnome Sort Action! sample (also used in other Action! sort samples)

PROC PrintArray(INT ARRAY a INT size)
  INT i
 
  Put('[)
  FOR i=0 TO size-1
  DO
    IF i>0 THEN Put(' ) FI
    PrintI(a(i))
  OD
  Put(']) PutE()
RETURN
 
PROC SiftDown(INT ARRAY a, INT start, endv)
  INT root, child, temp
  root = start

  child = (root LSH 1) + 1
  WHILE child <= endv DO
    IF child + 1 <= endv AND a(child) < a(child+1) THEN child==+ 1 FI
    IF a(root) < a(child) THEN
      temp     = a(root)
      a(root)  = a(child)
      a(child) = temp
      root     = child
      child    = (root LSH 1) + 1
    ELSE
      RETURN
    FI
  OD
RETURN

PROC Heapify(INT ARRAY a, INT count)
  INT start

  start = ((count-2) / 2) + 1
  WHILE start <> 0 DO
    start = start - 1
    SiftDown(a, start, count-1)
  OD
RETURN
    
PROC HeapSort(INT ARRAY a, INT count)
  INT endv, temp
    
  Heapify(a, count)
  endv = count - 1
  WHILE endv > 0 DO
    temp    = a(0)
    a(0)    = a(endv)
    a(endv) = temp
    endv    = endv - 1
    SiftDown(a, 0, endv)
  OD
RETURN

PROC Test(INT ARRAY a INT size)
  PrintE("Array before sort:")
  PrintArray(a,size)
  HeapSort(a,size)
  PrintE("Array after sort:")
  PrintArray(a,size)
  PutE()
RETURN
 
PROC Main()
  INT ARRAY
    a(10)=[1 4 65535 0 3 7 4 8 20 65530],
    b(21)=[10 9 8 7 6 5 4 3 2 1 0
      65535 65534 65533 65532 65531
      65530 65529 65528 65527 65526],
    c(8)=[101 102 103 104 105 106 107 108],
    d(12)=[1 65535 1 65535 1 65535 1
      65535 1 65535 1 65535]
 
  Test(a,10)
  Test(b,21)
  Test(c,8)
  Test(d,12)
RETURN
Output:
Array before sort:
[1 4 -1 0 3 7 4 8 20 -6]
Array after sort:
[-6 -1 0 1 3 4 4 7 8 20]

Array before sort:
[10 9 8 7 6 5 4 3 2 1 0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10]
Array after sort:
[-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 10]

Array before sort:
[101 102 103 104 105 106 107 108]
Array after sort:
[101 102 103 104 105 106 107 108]

Array before sort:
[1 -1 1 -1 1 -1 1 -1 1 -1 1 -1]
Array after sort:
[-1 -1 -1 -1 -1 -1 1 1 1 1 1 1]

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

Ada

This implementation is a generic heapsort for unconstrained arrays.

generic
   type Element_Type is private;
   type Index_Type is (<>);
   type Collection is array(Index_Type range <>) of Element_Type;
   with function "<" (Left, right : element_type) return boolean is <>;
procedure Generic_Heapsort(Item : in out Collection);
procedure Generic_Heapsort(Item : in out Collection) is
   procedure Swap(Left : in out Element_Type; Right : in out Element_Type) is
      Temp : Element_Type := Left;
   begin
      Left := Right;
      Right := Temp;
   end Swap;
   procedure Sift_Down(Item : in out Collection) is
      Root : Integer := Index_Type'Pos(Item'First);
      Child : Integer := Index_Type'Pos(Item'Last);
      Last : Integer := Index_Type'Pos(Item'Last);
   begin
      while Root * 2 + 1 <= Last loop
         Child := Root * 2 + 1;
         if Child + 1 <= Last and then Item(index_Type'Val(Child)) < Item(Index_Type'Val(Child + 1)) then
            Child := Child + 1;
         end if;
         if Item(Index_Type'Val(Root)) < Item(Index_Type'Val(Child)) then
            Swap(Item(Index_Type'Val(Root)), Item(Index_Type'Val(Child)));
            Root := Child;
         else
            exit;
         end if;
      end loop;
   end Sift_Down;
   
   procedure Heapify(Item : in out Collection) is
      First_Pos : Integer := Index_Type'Pos(Index_Type'First);
      Last_Pos  : Integer := Index_Type'Pos(Index_type'Last);
      Start : Index_type := Index_Type'Val((Last_Pos - First_Pos + 1) / 2);
   begin
      loop
         Sift_Down(Item(Start..Item'Last));
         if Start > Index_Type'First then
            Start := Index_Type'Pred(Start);
         else
            exit;
         end if;
      end loop;
   end Heapify;
   Last_Index : Index_Type := Index_Type'Last;
begin
   Heapify(Item);
   while Last_Index > Index_Type'First loop
      Swap(Item(Last_Index), Item(Item'First));
      Last_Index := Index_Type'Pred(Last_Index);
      Sift_Down(Item(Item'First..Last_Index));
   end loop;
   
end Generic_Heapsort;

Demo code:

with Generic_Heapsort;
with Ada.Text_Io; use Ada.Text_Io;

procedure Test_Generic_Heapsort is
   type Days is (Sun, Mon, Tue, Wed, Thu, Fri, Sat);
   type Days_Col is array(Days range <>) of Natural;
   procedure Sort is new Generic_Heapsort(Natural, Days, Days_Col);
   Week : Days_Col := (5, 2, 7, 3, 4, 9, 1);
begin
   for I in Week'range loop
      Put(Days'Image(I) & ":" & Natural'Image(Week(I)) & " ");
   end loop;
   New_Line;
   Sort(Week);
   for I in Week'range loop
      Put(Days'Image(I) & ":" & Natural'Image(Week(I))& " ");
   end loop;
   New_Line;
end Test_Generic_Heapsort;

ALGOL 68

#--- Swap function ---#
PROC swap = (REF []INT array, INT first, INT second) VOID:
(
    INT temp := array[first];
    array[first] := array[second];
    array[second]:= temp
);

#--- Heap sort Move Down ---#
PROC heapmove = (REF []INT array, INT i, INT last) VOID:
(
    INT index := i;
    INT larger := (index*2);
    
    WHILE larger <= last DO
        IF larger < last THEN IF array[larger] < array[larger+1] THEN
            larger +:= 1
        FI FI;
        IF array[index] < array[larger] THEN
            swap(array, index, larger) 
        FI;
        index := larger; 
        larger := (index*2) 
    OD
);

#--- Heap sort ---#
PROC heapsort = (REF []INT array) VOID:
(
    FOR i FROM ENTIER((UPB array) / 2) BY -1 WHILE 
        heapmove(array, i, UPB array);
    i > 1 DO SKIP OD;    
    
    FOR i FROM UPB array BY -1 WHILE 
        swap(array, 1, i);
        heapmove(array, 1, i-1); 
    i > 1 DO SKIP OD
);
#***************************************************************#
main:
(
    [10]INT a; 
    FOR i FROM 1 TO UPB a DO        
        a[i] := ROUND(random*100)
    OD;                    
                  
    print(("Before:", a));
    print((newline, newline));
    heapsort(a);
    print(("After: ", a))

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

ALGOL W

Translation of: PL/M
begin % heapsort - translated from the PL/M sample %

    % in-place heapsorts a, a must have bounds 0 :: count - 1 %
    procedure heapSort ( integer array a ( * ); integer value count ) ;
    begin
        procedure siftDown ( integer array a ( * ); integer value start, endv ) ;
        begin
            integer root, child, temp;
            logical done;
            root := start;
            done := false;
            while begin
                      child := ( root * 2 ) + 1;
                      child <= endv and not done
                  end
            do begin
                if child + 1 <= endv and a( child ) < a( child + 1 ) then child := child + 1;
                if a( root ) < a( child ) then begin
                    temp       := a( root );
                    a( root  ) := a( child );
                    a( child ) := temp;
                    root       := child
                    end
                else done := true
            end while_child_le_endv_and_not_done
        end siftDown ;
        procedure heapify ( integer array a ( * ); integer value count ) ;
        begin
            integer start;
            start := ( count - 2 ) div 2;
            while begin
                siftDown( a, start, count - 1 );
                if start = 0
                then false
                else begin
                    start := start - 1;
                    true
                end if_start_eq_0__
            end do begin end
        end heapify ;
        begin % heapSort body %
            integer endv, temp;
            heapify( a, count );
            endv := count - 1;
            while endv > 0 do begin
                temp      := a( 0 );
                a( 0 )    := a( endv );
                a( endv ) := temp;
                endv      := endv - 1;
                siftDown( a, 0, endv )
            end while_endv_gt_0
        end heapSortBody
    end heapSort;

    begin % test heapSort %
        integer array numbers ( 0 :: 10 );
        integer nPos;
        % constructy an array of integers and sort it %
        nPos := 0;
        for v := 4, 65, 2, 31, 0, 99, 2, 8, 3, 782, 1 do begin
            numbers( nPos ) := v;
            nPos            := nPos + 1
        end for_v ;
        heapSort( numbers, 11 );
        % print the sorted array %
        for n := 0 until 10 do writeon( i_w := 1, s_w := 0, " ", numbers( n ) )
    end tests
end.
Output:
 0 1 2 2 3 4 8 31 65 99 782

AppleScript

Binary heap

-- In-place binary heap sort.
-- Heap sort algorithm: J.W.J. Williams.
on heapSort(theList, l, r) -- Sort items l thru r of theList.
    set listLen to (count theList)
    if (listLen < 2) then return
    -- Convert negative and/or transposed range indices.
    if (l < 0) then set l to listLen + l + 1
    if (r < 0) then set r to listLen + r + 1
    if (l > r) then set {l, r} to {r, l}
    
    script o
        -- The list as a script property to allow faster references to its items.
        property lst : theList
        -- In a binary heap, the list index of each node's first child is (node index * 2) - (l - 1). Preset the constant part.
        property const : l - 1
        
        -- Private subhandler: sift a value down into the heap from a given node.
        on siftDown(siftV, node, endOfHeap)
            set child to node * 2 - const
            repeat until (child comes after endOfHeap)
                set childV to my lst's item child
                if (child comes before endOfHeap) then
                    set child2 to child + 1
                    set child2V to my lst's item child2
                    if (child2V > childV) then
                        set child to child2
                        set childV to child2V
                    end if
                end if
                if (childV > siftV) then
                    set my lst's item node to childV
                    set node to child
                    set child to node * 2 - const
                else
                    exit repeat
                end if
            end repeat
            
            -- Insert the sifted-down value at the node reached.
            set my lst's item node to siftV
        end siftDown
    end script
    
    -- Arrange the sort range into a "heap" with its "top" at the leftmost position.
    repeat with i from (l + r) div 2 to l by -1
        tell o to siftDown(its lst's item i, i, r)
    end repeat
    -- Unpick the heap.    
    repeat with endOfHeap from r to (l + 1) by -1
        set endV to o's lst's item endOfHeap
        set o's lst's item endOfHeap to o's lst's item l
        tell o to siftDown(endV, l, endOfHeap - 1)
    end repeat
    
    return -- nothing 
end heapSort
property sort : heapSort

-- Demo:
local aList
set aList to {74, 95, 9, 56, 76, 33, 51, 27, 62, 55, 86, 60, 65, 32, 10, 62, 72, 87, 86, 85, 36, 20, 44, 17, 60}
sort(aList, 1, -1) -- Sort items 1 thru -1 of aList.
return aList
Output:
9, 10, 17, 20, 27, 32, 33, 36, 44, 51, 55, 56, 60, 60, 62, 62, 65, 72, 74, 76, 85, 86, 86, 87, 95}

Ternary heap

-- In-place ternary heap sort.
-- Heap sort algorithm: J.W.J. Williams.
on heapSort(theList, l, r) -- Sort items l thru r of theList.
    set listLen to (count theList)
    if (listLen < 2) then return
    -- Convert negative and/or transposed range indices.
    if (l < 0) then set l to listLen + l + 1
    if (r < 0) then set r to listLen + r + 1
    if (l > r) then set {l, r} to {r, l}
    
    script o
        -- The list as a script property to allow faster references to its items.
        property lst : theList
        -- In a ternary heap, the list index of each node's first child is (node index * 3) - (l * 2 - 1). Preset the constant part.
        property const : l * 2 - 1
        
        -- Private subhandler: sift a value down into the heap from a given node.
        on siftDown(siftV, node, endOfHeap)
            set child to node * 3 - const
            repeat until (child comes after endOfHeap)
                set childV to my lst's item child
                if (child comes before endOfHeap) then
                    set child2 to child + 1
                    set child2V to my lst's item child2
                    if (child2V > childV) then
                        set child to child2
                        set childV to child2V
                    end if
                    if (child2 comes before endOfHeap) then
                        set child3 to child2 + 1
                        set child3V to my lst's item child3
                        if (child3V > childV) then
                            set child to child3
                            set childV to child3V
                        end if
                    end if
                end if
                if (childV > siftV) then
                    set my lst's item node to childV
                    set node to child
                    set child to node * 3 - const
                else
                    exit repeat
                end if
            end repeat
            
            -- Insert the sifted-down value at the node reached.
            set my lst's item node to siftV
        end siftDown
    end script
    
    -- Arrange the sort range into a ternary "heap" with its "top" at the leftmost position.
    repeat with i from (l + r) div 3 to l by -1
        tell o to siftDown(its lst's item i, i, r)
    end repeat
    -- Unpick the heap.    
    repeat with endOfHeap from r to (l + 1) by -1
        set endV to o's lst's item endOfHeap
        set o's lst's item endOfHeap to o's lst's item l
        tell o to siftDown(endV, l, endOfHeap - 1)
    end repeat
    
    return -- nothing 
end heapSort
property sort : heapSort

-- Demo:
local aList
set aList to {75, 46, 8, 43, 20, 9, 25, 89, 19, 29, 16, 71, 44, 23, 17, 99, 79, 97, 19, 75, 32, 27, 42, 93, 75}
sort(aList, 1, -1) -- Sort items 1 thru -1 of aList.
return aList
Output:
{8, 9, 16, 17, 19, 19, 20, 23, 25, 27, 29, 32, 42, 43, 44, 46, 71, 75, 75, 75, 79, 89, 93, 97, 99}

ARM Assembly

Works with: as version Raspberry Pi
/* ARM assembly Raspberry PI  */
/*  program heapSort.s   */
/* look Pseudocode begin this task  */
 
/************************************/
/* Constantes                       */
/************************************/
.equ STDOUT, 1     @ Linux output console
.equ EXIT,   1     @ Linux syscall
.equ WRITE,  4     @ Linux syscall
/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .ascii "Value  : "
sMessValeur:        .fill 11, 1, ' '            @ size => 11
szCarriageReturn:  .asciz "\n"
 
.align 4
iGraine:  .int 123456
.equ NBELEMENTS,      10
TableNumber:	     .int   1,3,6,2,5,9,10,8,4,7
#TableNumber:	     .int   10,9,8,7,6,5,4,3,2,1
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss  
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main 
main:                                             @ entry of program 
 
1:
    ldr r0,iAdrTableNumber                      @ address number table
    mov r1,#NBELEMENTS                           @ number of élements 
    bl heapSort
    ldr r0,iAdrTableNumber                      @ address number table
    bl displayTable
 
    ldr r0,iAdrTableNumber                      @ address number table
    mov r1,#NBELEMENTS                           @ number of élements 
    bl isSorted                                   @ control sort
    cmp r0,#1                                       @ sorted ?
    beq 2f                                    
    ldr r0,iAdrszMessSortNok                    @ no !! error sort
    bl affichageMess
    b 100f
2:                                                  @ yes
    ldr r0,iAdrszMessSortOk
    bl affichageMess
100:                                               @ standard end of the program 
    mov r0, #0                                      @ return code
    mov r7, #EXIT                                  @ request to exit program
    svc #0                                         @ perform the system call
 
iAdrsMessValeur:          .int sMessValeur
iAdrszCarriageReturn:    .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrszMessSortOk:         .int szMessSortOk
iAdrszMessSortNok:        .int szMessSortNok
/******************************************************************/
/*     control sorted table                                   */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements  > 0  */
/* r0 return 0  if not sorted   1  if sorted */
isSorted:
    push {r2-r4,lr}                                    @ save registers
    mov r2,#0
    ldr r4,[r0,r2,lsl #2]
1:
    add r2,#1
    cmp r2,r1
    movge r0,#1
    bge 100f
    ldr r3,[r0,r2, lsl #2]
    cmp r3,r4
    movlt r0,#0
    blt 100f
    mov r4,r3
    b 1b
100:
    pop {r2-r4,lr}
    bx lr                                              @ return 
/******************************************************************/
/*         heap sort                                              */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of element */
heapSort:
    push {r2,r3,r4,lr}                                    @ save registers
    bl heapify                                          @ first place table in max-heap order
    sub r3,r1,#1
1:
    cmp r3,#0
    ble 100f
    mov r1,#0                                             @ swap the root(maximum value) of the heap with the last element of the heap)
    mov r2,r3
    bl swapElement
    sub r3,#1
    mov r1,#0
    mov r2,r3                                             @ put the heap back in max-heap order
    bl siftDown
    b 1b

100:
    pop {r2,r3,r4,lr}
    bx lr                                              @ return 
/******************************************************************/
/*      place table in max-heap order                             */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of element */
heapify:
    push {r1,r2,r3,r4,lr}                                    @ save registers
    mov r4,r1
    sub r3,r1,#2
    lsr r3,#1
1:
    cmp r3,#0
    blt 100f
    mov r1,r3
    sub r2,r4,#1
    bl siftDown
    sub r3,#1
    b 1b
100:
    pop {r1,r2,r3,r4,lr}
    bx lr                                              @ return 
/******************************************************************/
/*     swap two elements of table                                  */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the first index */
/* r2 contains the second index */
swapElement:
    push {r3,r4,lr}                                    @ save registers
    ldr r3,[r0,r1,lsl #2]                              @ swap number on the table
    ldr r4,[r0,r2,lsl #2]
    str r4,[r0,r1,lsl #2]
    str r3,[r0,r2,lsl #2]

100:
    pop {r3,r4,lr}
    bx lr                                              @ return 
 
/******************************************************************/
/*     put the heap back in max-heap order                        */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the first index */
/* r2 contains the last index */
siftDown:
    push {r1-r7,lr}                                    @ save registers
                                                       @ r1 = root = start
    mov r3,r2                                          @ save last index
1:
    lsl r4,r1,#1
    add r4,#1
    cmp r4,r3
    bgt 100f
    add r5,r4,#1
    cmp r5,r3
    bgt 2f
    ldr r6,[r0,r4,lsl #2]                              @ compare elements on the table
    ldr r7,[r0,r5,lsl #2]
    cmp r6,r7
    movlt r4,r5
2:
    ldr r7,[r0,r4,lsl #2]                              @ compare elements on the table
    ldr r6,[r0,r1,lsl #2]                              @ root
    cmp r6,r7
    bge 100f
    mov r2,r4                                          @ and r1 is root
    bl swapElement
    mov r1,r4                                          @ root = child
    b 1b

100:
    pop {r1-r7,lr}
    bx lr                                              @ return  

/******************************************************************/
/*      Display table elements                                */ 
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsMessValeur                             @ display value
    bl conversion10                                    @ call function
    ldr r0,iAdrsMessResult
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBELEMENTS - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
100:
    pop {r0-r3,lr}
    bx lr
/******************************************************************/
/*     display text with size calculation                         */ 
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {r0,r1,r2,r7,lr}                          @ save  registres
    mov r2,#0                                      @ counter length 
1:                                                 @ loop length calculation 
    ldrb r1,[r0,r2]                                @ read octet start position + index 
    cmp r1,#0                                      @ if 0 its over 
    addne r2,r2,#1                                 @ else add 1 in the length 
    bne 1b                                         @ and loop 
                                                   @ so here r2 contains the length of the message 
    mov r1,r0                                      @ address message in r1 
    mov r0,#STDOUT                                 @ code to write to the standard output Linux 
    mov r7, #WRITE                                 @ code call system "write" 
    svc #0                                         @ call systeme 
    pop {r0,r1,r2,r7,lr}                           @ restaur des  2 registres */ 
    bx lr                                          @ return  
/******************************************************************/
/*     Converting a register to a decimal unsigned                */ 
/******************************************************************/
/* r0 contains value and r1 address area   */
/* r0 return size of result (no zero final in area) */
/* area size => 11 bytes          */
.equ LGZONECAL,   10
conversion10:
    push {r1-r4,lr}                                 @ save registers 
    mov r3,r1
    mov r2,#LGZONECAL
 
1:	                                            @ start loop
    bl divisionpar10U                               @ unsigned  r0 <- dividende. quotient ->r0 reste -> r1
    add r1,#48                                      @ digit
    strb r1,[r3,r2]                                 @ store digit on area
    cmp r0,#0                                       @ stop if quotient = 0 
    subne r2,#1                                     @ else previous position
    bne 1b	                                    @ and loop
                                                    @ and move digit from left of area
    mov r4,#0
2:
    ldrb r1,[r3,r2]
    strb r1,[r3,r4]
    add r2,#1
    add r4,#1
    cmp r2,#LGZONECAL
    ble 2b
                                                      @ and move spaces in end on area
    mov r0,r4                                         @ result length 
    mov r1,#' '                                       @ space
3:
    strb r1,[r3,r4]                                   @ store space in area
    add r4,#1                                         @ next position
    cmp r4,#LGZONECAL
    ble 3b                                            @ loop if r4 <= area size
 
100:
    pop {r1-r4,lr}                                    @ restaur registres 
    bx lr                                             @return
 
/***************************************************/
/*   division par 10   unsigned                    */
/***************************************************/
/* r0 dividende   */
/* r0 quotient */	
/* r1 remainder  */
divisionpar10U:
    push {r2,r3,r4, lr}
    mov r4,r0                                          @ save value
    //mov r3,#0xCCCD                                   @ r3 <- magic_number lower  raspberry 3
    //movt r3,#0xCCCC                                  @ r3 <- magic_number higter raspberry 3
    ldr r3,iMagicNumber                                @ r3 <- magic_number    raspberry 1 2
    umull r1, r2, r3, r0                               @ r1<- Lower32Bits(r1*r0) r2<- Upper32Bits(r1*r0) 
    mov r0, r2, LSR #3                                 @ r2 <- r2 >> shift 3
    add r2,r0,r0, lsl #2                               @ r2 <- r0 * 5 
    sub r1,r4,r2, lsl #1                               @ r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10)
    pop {r2,r3,r4,lr}
    bx lr                                              @ leave function 
iMagicNumber:  	.int 0xCCCCCCCD

Arturo

siftDown: function [items, start, ending][
    root: start
    a: new items
    while [ending > 1 + 2 * root][
        child: 1 + 2 * root
        if and? ending > child + 1
                a\[child+1] > a\[child] -> child: child + 1

        if? a\[root] < a\[child][
            tmp: a\[child]
            a\[child]: a\[root]
            a\[root]: tmp
            root: child
        ]
        else -> return a
    ]
    return a
]

heapSort: function [items][
    b: new items
    count: size b
    loop ((count-2)/2) .. 0 'start -> b: siftDown b start count
    loop (count-1) .. 1 'ending [
        tmp: b\[ending]
        b\[ending]: b\0
        b\0: tmp
        b: siftDown b 0 ending
    ]
    return b
]

print heapSort [3 1 2 8 5 7 9 4 6]
Output:
1 2 3 4 5 6 7 8 9


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

BBC BASIC

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

BCPL

// This can be run using Cintcode BCPL freely available from www.cl.cam.ac.uk/users/mr10.

GET "libhdr.h"

LET heapify(v, k, i, last) BE
{ LET j = i+i  // If there is a son (or two), j = subscript of first.
  AND x = k    // x will hold the larger of the sons if any.

  IF j<=last DO x := v!j      // j, x = subscript and key of first son.
  IF j< last DO
  { LET y = v!(j+1)           // y = key of the other son.
    IF x<y DO x,j := y, j+1   // j, x = subscript and key of larger son.
  }

  IF k>=x DO
  { v!i := k                  // k is not lower than larger son if any.
    RETURN
  }
  v!i := x
  i := j
} REPEAT

AND heapsort(v, upb) BE
{ FOR i = upb/2 TO 1 BY -1 DO heapify(v, v!i, i, upb)

  FOR i = upb TO 2 BY -1 DO
  { LET k = v!i
    v!i := v!1
    heapify(v, k, 1, i-1)
  }
}

LET start() = VALOF {
  LET v = VEC 1000
  FOR i = 1 TO 1000 DO v!i := randno(1_000_000)
  heapsort(v, 1000)
  FOR i = 1 TO 1000 DO
  { IF i MOD 10 = 0 DO newline()
    writef(" %i6", v!i)
  }
  newline()
}

C

#include <stdio.h>

int max (int *a, int n, int i, int j, int k) {
    int m = i;
    if (j < n && a[j] > a[m]) {
        m = j;
    }
    if (k < n && a[k] > a[m]) {
        m = k;
    }
    return m;
}

void downheap (int *a, int n, int i) {
    while (1) {
        int j = max(a, n, i, 2 * i + 1, 2 * i + 2);
        if (j == i) {
            break;
        }
        int t = a[i];
        a[i] = a[j];
        a[j] = t;
        i = j;
    }
}

void heapsort (int *a, int n) {
    int i;
    for (i = (n - 2) / 2; i >= 0; i--) {
        downheap(a, n, i);
    }
    for (i = 0; i < n; i++) {
        int t = a[n - i - 1];
        a[n - i - 1] = a[0];
        a[0] = t;
        downheap(a, n - i - 1, 0);
    }
}

int main () {
    int a[] = {4, 65, 2, -31, 0, 99, 2, 83, 782, 1};
    int n = sizeof a / sizeof a[0];
    int i;
    for (i = 0; i < n; i++)
        printf("%d%s", a[i], i == n - 1 ? "\n" : " ");
    heapsort(a, n);
    for (i = 0; i < n; i++)
        printf("%d%s", a[i], i == n - 1 ? "\n" : " ");
    return 0;
}

C#

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

C++

Uses C++11. Compile with

g++ -std=c++11 heap.cpp
#include <algorithm>
#include <iterator>
#include <iostream>

template<typename RandomAccessIterator>
void heap_sort(RandomAccessIterator begin, RandomAccessIterator end) {
  std::make_heap(begin, end);
  std::sort_heap(begin, end);
}

int main() {
  int a[] = {100, 2, 56, 200, -52, 3, 99, 33, 177, -199};
  heap_sort(std::begin(a), std::end(a));
  copy(std::begin(a), std::end(a), std::ostream_iterator<int>(std::cout, " "));
  std::cout << "\n";
}
Output:
-199 -52 2 3 33 56 99 100 177 200
Translation of: CoffeeScript

Uses C++11. Compile with

 g++ -std=c++11
#include <iostream>
#include <vector>

using namespace std;

void shift_down(vector<int>& heap,int i, int max) {
    int i_big, c1, c2;
    while(i < max) {
        i_big = i;
        c1 = (2*i) + 1;
        c2 = c1 + 1;
        if( c1<max && heap[c1]>heap[i_big] )
            i_big = c1;
        if( c2<max && heap[c2]>heap[i_big] )
            i_big = c2;
        if(i_big == i) return;
        swap(heap[i],heap[i_big]);
        i = i_big;
    }
}

void to_heap(vector<int>& arr) {
    int i = (arr.size()/2) - 1;
    while(i >= 0) {
        shift_down(arr, i, arr.size());
        --i;
    }
}

void heap_sort(vector<int>& arr) {
    to_heap(arr);
    int end = arr.size() - 1;
    while (end > 0) {
        swap(arr[0], arr[end]);
        shift_down(arr, 0, end);
        --end;
    }
}

int main() {
    vector<int> data = {
        12, 11, 15, 10, 9, 1, 2,
        3, 13, 14, 4, 5, 6, 7, 8
    };
    heap_sort(data);
    for(int i : data) cout << i << " ";
}
Output:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

Clojure

(defn- swap [a i j]
  (assoc a i (nth a j) j (nth a i)))
 
(defn- sift [a pred k l]
  (loop [a a x k y (inc (* 2 k))]
    (if (< (inc (* 2 x)) l)
      (let [ch (if (and (< y (dec l)) (pred (nth a y) (nth a (inc y))))
                 (inc y)
                 y)]
        (if (pred (nth a x) (nth a ch))
          (recur (swap a x ch) ch (inc (* 2 ch)))
          a))
      a)))

(defn- heapify[pred a len]
  (reduce (fn [c term] (sift (swap c term 0) pred 0 term))
          (reduce (fn [c i] (sift c pred i len))
                  (vec a)
                  (range (dec (int (/ len 2))) -1 -1))
          (range (dec len) 0 -1)))

(defn heap-sort
  ([a pred]
   (let [len (count a)]
     (heapify pred a len)))
  ([a]
     (heap-sort a <)))

Example usage:

user> (heapsort [1 2 4 6 2 3 6])
[1 2 2 3 4 6 6]
user> (heapsort [1 2 4 6 2 3 6] >)
[6 6 4 3 2 2 1]
user> (heapsort (list 1 2 4 6 2 3 6))
[1 2 2 3 4 6 6]

CLU

% Sort an array in place using heap-sort. The contained type
% may be any type that can be compared.
heapsort = cluster [T: type] is sort
           where T has lt: proctype (T,T) returns (bool)
    rep = null 
    aT = array[T]
    
    sort = proc (a: aT)
        % CLU arrays may start at any index.
        % For simplicity, we will store the old index,
        % reindex the array at zero, do the heap-sort,
        % then undo the reindexing.
        % This should be a constant-time operation.
        old_low: int := aT$low(a)
        aT$set_low(a, 0)
        heapsort_(a)
        aT$set_low(a, old_low)
    end sort
    
    % Heap-sort a zero-indexed array
    heapsort_ = proc (a: aT)
        heapify(a)
        end_: int := aT$high(a)
        while end_ > 0 do
            swap(a, end_, 0)
            end_ := end_ - 1
            siftDown(a, 0, end_)
        end
    end heapsort_
    
    heapify = proc (a: aT)
        start: int := (aT$high(a) - 1) / 2
        while start >= 0 do
            siftDown(a, start, aT$high(a))
            start := start - 1
        end
    end heapify
    
    siftDown = proc (a: aT, start, end_: int)
        root: int := start
        while root*2 + 1 <= end_ do
            child: int := root * 2 + 1
            if child + 1 <= end_ cand 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 siftDown
            
    swap = proc (a: aT, i, j: int)
        temp: T := a[i]
        a[i] := a[j]
        a[j] := temp
    end swap
end heapsort

% Print an array
print_arr = proc [T: type] (s: stream, a: array[T], w: int)
            where T has unparse: proctype (T) returns (string)
    for e: T in array[T]$elements(a) do
        stream$putright(s, T$unparse(e), w)
    end
    stream$putl(s, "")
end print_arr

% Test the heapsort
start_up = proc ()
    po: stream := stream$primary_output()
    arr: array[int] := array[int]$[9, -5, 3, 3, 24, -16, 3, -120, 250, 17]
    
    stream$puts(po, "Before sorting: ")
    print_arr[int](po,arr,5)
    
    heapsort[int]$sort(arr)
    stream$puts(po, "After sorting:  ")
    print_arr[int](po,arr,5)
end start_up
Output:
Before sorting:     9   -5    3    3   24  -16    3 -120  250   17
After sorting:   -120  -16   -5    3    3    3    9   17   24  250

COBOL

Works with: GnuCOBOL
        >>SOURCE FORMAT FREE
*> This code is dedicated to the public domain
*> This is GNUCOBOL 2.0
identification division.
program-id. heapsort.
environment division.
configuration section.
repository. function all intrinsic.
data division.
working-storage section.
01  filler.
    03  a pic 99.
    03  a-start pic 99.
    03  a-end pic 99.
    03  a-parent pic 99.
    03  a-child pic 99.
    03  a-sibling pic 99.
    03  a-lim pic 99 value 10.
    03  array-swap pic 99.
    03  array occurs 10 pic 99.
procedure division.
start-heapsort.

    *> fill the array
    compute a = random(seconds-past-midnight)
    perform varying a from 1 by 1 until a > a-lim
        compute array(a) = random() * 100
    end-perform

    perform display-array
    display  space 'initial array'

    *>heapify the array
    move a-lim to a-end
    compute a-start = (a-lim + 1) / 2
    perform sift-down varying a-start from a-start by -1 until a-start = 0

    perform display-array
    display space 'heapified'

    *> sort the array
    move 1 to a-start
    move a-lim to a-end
    perform until a-end = a-start
        move array(a-end) to array-swap
        move array(a-start) to array(a-end)
        move array-swap to array(a-start)
        subtract 1 from a-end
        perform sift-down
    end-perform

    perform display-array
    display space 'sorted'

    stop run
    .
sift-down.
    move a-start to a-parent
    perform until a-parent * 2 > a-end
        compute a-child = a-parent * 2 
        compute a-sibling = a-child + 1
        if a-sibling <= a-end and array(a-child) < array(a-sibling)
            *> take the greater of the two
            move a-sibling to a-child
        end-if
        if a-child <= a-end and array(a-parent) < array(a-child)
           *> the child is greater than the parent
           move array(a-child) to array-swap
           move array(a-parent) to array(a-child)
           move array-swap to array(a-parent)
        end-if
        *> continue down the tree
        move a-child to a-parent
    end-perform
    .
display-array.
    perform varying a from 1 by 1 until a > a-lim
        display space array(a) with no advancing
    end-perform
    .
end program heapsort.
Output:
prompt$ cobc -xj heapsort.cob
 20 26 47 88 97 39 07 77 35 98 initial array
 98 97 47 88 26 39 07 77 35 20 heapified
 07 20 26 35 39 47 77 88 97 98 sorted

CoffeeScript

# Do an in-place heap sort.
heap_sort = (arr) ->
  put_array_in_heap_order(arr)
  end = arr.length - 1
  while end > 0
    [arr[0], arr[end]] = [arr[end], arr[0]]
    sift_element_down_heap arr, 0, end
    end -= 1

put_array_in_heap_order = (arr) ->
  i = arr.length / 2 - 1
  i = Math.floor i
  while i >= 0
    sift_element_down_heap arr, i, arr.length
    i -= 1

sift_element_down_heap = (heap, i, max) ->
  while i < max
    i_big = i
    c1 = 2*i + 1
    c2 = c1 + 1
    if c1 < max and heap[c1] > heap[i_big]
      i_big = c1
    if c2 < max and heap[c2] > heap[i_big]
      i_big = c2
    return if i_big is i
    [heap[i], heap[i_big]] = [heap[i_big], heap[i]]
    i = i_big

do ->
  arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8]
  heap_sort arr
  console.log arr
Output:
> coffee heap.coffee 
[ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 ]

Common Lisp

(defun make-heap (&optional (length 7))
  (make-array length :adjustable t :fill-pointer 0))

(defun left-index (index)
  (1- (* 2 (1+ index))))

(defun right-index (index)
  (* 2 (1+ index)))

(defun parent-index (index)
  (floor (1- index) 2))

(defun percolate-up (heap index predicate)
  (if (zerop index) heap
    (do* ((element (aref heap index))
          (index index pindex)
          (pindex (parent-index index)
                  (parent-index index)))
         ((zerop index) heap)
      (if (funcall predicate element (aref heap pindex))
        (rotatef (aref heap index) (aref heap pindex))
        (return-from percolate-up heap)))))

(defun heap-insert (heap element predicate)
  (let ((index (vector-push-extend element heap 2)))
    (percolate-up heap index predicate)))

(defun percolate-down (heap index predicate)
  (let ((length (length heap))
        (element (aref heap index)))
    (flet ((maybe-element (index)
             "return the element at index or nil, and a boolean
              indicating whether there was an element."
             (if (< index length)
               (values (aref heap index) t)
               (values nil nil))))
      (do ((index index swap-index)
           (lindex (left-index index) (left-index index))
           (rindex (right-index index) (right-index index))
           (swap-index nil) (swap-child nil))
          (nil)
        ;; Extact the left child if there is one. If there is not,
        ;; return the heap.  Set the left child as the swap-child.
        (multiple-value-bind (lchild lp) (maybe-element lindex)
          (if (not lp) (return-from percolate-down heap)
            (setf swap-child lchild
                  swap-index lindex))
          ;; Extract the right child, if any, and when better than the
          ;; current swap-child, update the swap-child.
          (multiple-value-bind (rchild rp) (maybe-element rindex)
            (when (and rp (funcall predicate rchild lchild))
              (setf swap-child rchild
                    swap-index rindex))
            ;; If the swap-child is better than element, rotate them,
            ;; and continue percolating down, else return heap.
            (if (not (funcall predicate swap-child element))
              (return-from percolate-down heap)
              (rotatef (aref heap index) (aref heap swap-index)))))))))

(defun heap-empty-p (heap)
  (eql (length heap) 0))

(defun heap-delete-min (heap predicate)
  (assert (not (heap-empty-p heap)) () "Can't pop from empty heap.")
  (prog1 (aref heap 0)
    (setf (aref heap 0) (vector-pop heap))
    (unless (heap-empty-p heap)
      (percolate-down heap 0 predicate))))

(defun heapsort (sequence predicate)
  (let ((h (make-heap (length sequence))))
    (map nil #'(lambda (e) (heap-insert h e predicate)) sequence)
    (map-into sequence #'(lambda () (heap-delete-min h predicate)))))

Example usage:

(heapsort (vector 1 9 2 8 3 7 4 6 5) '<) ; #(1 2 3 4 5 6 7 8 9)
(heapsort (list 9 8 1 2 7 6 3 4 5) '<)   ; (1 2 3 4 5 6 7 8 9)

D

import std.stdio, std.container;

void heapSort(T)(T[] data) /*pure nothrow @safe @nogc*/ {
    for (auto h = data.heapify; !h.empty; h.removeFront) {}
}

void main() {
   auto items = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0];
   items.heapSort;
   items.writeln;
}

A lower level implementation:

import std.stdio, std.algorithm;

void heapSort(R)(R seq) pure nothrow @safe @nogc {
   static void siftDown(R seq, in size_t start,
                        in size_t end) pure nothrow @safe @nogc {
      for (size_t root = start; root * 2 + 1 <= end; ) {
         auto child = root * 2 + 1;
         if (child + 1 <= end && seq[child] < seq[child + 1])
            child++;
         if (seq[root] < seq[child]) {
            swap(seq[root], seq[child]);
            root = child;
         } else
            break;
      }
   }

   if (seq.length > 1)
      foreach_reverse (immutable start; 1 .. (seq.length - 2) / 2 + 2)
         siftDown(seq, start - 1, seq.length - 1);

   foreach_reverse (immutable end; 1 .. seq.length) {
      swap(seq[end], seq[0]);
      siftDown(seq, 0, end - 1);
   }
}

void main() {
   auto data = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0];
   data.heapSort;
   data.writeln;
}

Dart

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

Delphi

See Pascal.

Draco

proc nonrec siftDown([*] int a; word start, end) void:
    word root, child;
    int temp;
    bool stop;
    
    root := start;
    stop := false;
    while not stop and root*2 + 1 <= end do
        child := root*2 + 1;
        if child+1 <= end and a[child] < a[child + 1] then
            child := child + 1
        fi;
        if a[root] < a[child] then 
            temp := a[root];
            a[root] := a[child];
            a[child] := temp;
            root := child
        else
            stop := true
        fi
    od
corp

proc nonrec heapify([*] int a; word count) void:
    word start;
    bool stop;
    
    start := (count - 2) / 2;
    stop := false;
    while not stop do
        siftDown(a, start, count-1);
        if start=0
            then stop := true       /* avoid having to use a signed index */
            else start := start - 1
        fi
    od
corp

proc nonrec heapsort([*] int a) void:
    word end;
    int temp;
    
    heapify(a, dim(a,1));
    end := dim(a,1) - 1;
    while end > 0 do
        temp := a[0];
        a[0] := a[end];
        a[end] := temp;
        end := end - 1;
        siftDown(a, 0, end)
    od
corp

/* Test */
proc nonrec main() void:
    int i;
    [10] int a = (9, -5, 3, 3, 24, -16, 3, -120, 250, 17);
    
    write("Before sorting: ");
    for i from 0 upto 9 do write(a[i]:5) od; 
    writeln();
    
    heapsort(a);
    write("After sorting:  ");
    for i from 0 upto 9 do write(a[i]:5) od 
corp
Output:
Before sorting:     9   -5    3    3   24  -16    3 -120  250   17
After sorting:   -120  -16   -5    3    3    3    9   17   24  250

E

Translation of: Python
def heapsort := {
  def cswap(c, a, b) {
    def t := c[a]
    c[a]  := c[b]
    c[b]  := t
    # println(c)
  }

  def siftDown(array, start, finish) {
    var root := start
    while (var child := root * 2 + 1
           child <= finish) {
      if (child + 1 <= finish && array[child] < array[child + 1]) {
        child += 1
      }
      if (array[root] < array[child]) {
        cswap(array, root, child)
        root := child
      } else {
        break
      }
    }
  }

  /** Heapsort (in-place). */
  def heapsort(array) {
    # in pseudo-code, heapify only called once, so inline it here
    for start in (0..((array.size()-2)//2)).descending() {
      siftDown(array, start, array.size()-1)
    }
 
    for finish in (0..(array.size()-1)).descending() {
      cswap(array, 0, finish)
      siftDown(array, 0, finish - 1)
    }
  }
}

EasyLang

proc sort . d[] .
   n = len d[]
   # make heap
   for i = 2 to n
      if d[i] > d[(i + 1) div 2]
         j = i
         repeat
            h = (j + 1) div 2
            until d[j] <= d[h]
            swap d[j] d[h]
            j = h
         .
      .
   .
   for i = n downto 2
      swap d[1] d[i]
      j = 1
      ind = 2
      while ind < i
         if ind + 1 < i and d[ind + 1] > d[ind]
            ind += 1
         .
         if d[j] < d[ind]
            swap d[j] d[ind]
         .
         j = ind
         ind = 2 * j
      .
   .
.
data[] = [ 29 4 72 44 55 26 27 77 92 5 ]
sort data[]
print data[]

EchoLisp

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

(lib 'heap)

(define (heap-sort list)
    (define heap (make-heap < )) ;; make a min heap
    (list->heap list heap)
    (while (not (heap-empty? heap)) 
          (push 'stack (heap-pop heap)))
    (stack->list 'stack))

(define L (shuffle (iota 15)))
     (9 4 0 12 8 3 10 7 11 2 5 6 14 13 1)
(heap-sort L)
     (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14)

Eiffel

 
class
	HEAPSORT

feature

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

feature{NONE}

	is_sorted (ar: ARRAY [INTEGER]): BOOLEAN
			--- Is 'ar' sorted in ascending order?
		local
			i: INTEGER
		do
			Result := True
			from
				i := ar.lower
			until
				i >= ar.upper
			loop
				if ar [i] > ar [i + 1] then
					Result := False
				end
				i := i + 1
			end
		end

end

Test:

class
	APPLICATION

create
	make

feature

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

	heap_sort: HEAPSORT

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

Elixir

defmodule Sort do
  def heapSort(list) do
    len = length(list)
    heapify(List.to_tuple(list), div(len - 2, 2))
    |> heapSort(len-1)
    |> Tuple.to_list
  end
  
  defp heapSort(a, finish) when finish > 0 do
    swap(a, 0, finish)
    |> siftDown(0, finish-1)
    |> heapSort(finish-1)
  end
  defp heapSort(a, _), do: a
  
  defp heapify(a, start) when start >= 0 do
    siftDown(a, start, tuple_size(a)-1)
    |> heapify(start-1)
  end
  defp heapify(a, _), do: a
  
  defp siftDown(a, root, finish) when root * 2 + 1 <= finish do
    child = root * 2 + 1
    if child + 1 <= finish and elem(a,child) < elem(a,child + 1), do: child = child + 1
    if elem(a,root) < elem(a,child),
      do:   swap(a, root, child) |> siftDown(child, finish),
      else: a
  end
  defp siftDown(a, _root, _finish), do: a
  
  defp swap(a, i, j) do
    {vi, vj} = {elem(a,i), elem(a,j)}
    a |> put_elem(i, vj) |> put_elem(j, vi)
  end
end

(for _ <- 1..20, do: :rand.uniform(20)) |> IO.inspect |> Sort.heapSort |> IO.inspect
Output:
[6, 1, 12, 3, 7, 7, 9, 20, 8, 15, 2, 10, 14, 5, 19, 7, 20, 9, 14, 19]
[1, 2, 3, 5, 6, 7, 7, 7, 8, 9, 9, 10, 12, 14, 14, 15, 19, 19, 20, 20]

F#

let inline swap (a: _ []) i j =
  let temp = a.[i]
  a.[i] <- a.[j]
  a.[j] <- temp
 
let inline sift cmp (a: _ []) start count =
  let rec loop root child =
    if root * 2 + 1 < count then
      let p = child < count - 1 && cmp a.[child] a.[child + 1] < 0
      let child = if p then child + 1 else child
      if cmp a.[root] a.[child] < 0 then
        swap a root child
        loop child (child * 2 + 1)
  loop start (start * 2 + 1)

let inline heapsort cmp (a: _ []) =
  let n = a.Length
  for start = n/2 - 1 downto 0 do
    sift cmp a start n
  for term = n - 1 downto 1 do
    swap a term 0
    sift cmp a 0 term

Forth

This program assumes that return addresses simply reside as a single cell on the Return Stack. Most Forth compilers fulfill this requirement.

create example
  70 , 61 , 63 , 37 , 63 , 25 , 46 , 92 , 38 , 87 ,

[UNDEFINED] r'@ [IF]
: r'@ r> r> r@ swap >r swap >r ;
[THEN]

defer precedes                         ( n1 n2 a -- f)
defer exchange                         ( n1 n2 a --)

: siftDown                             ( a e s -- a e s)
  swap >r swap >r dup                  ( s r)
  begin                                ( s r)
    dup 2* 1+ dup r'@ <                ( s r c f)
  while                                ( s r c)
    dup 1+ dup r'@ <                   ( s r c c+1 f)
    if                                 ( s r c c+1)
      over over r@ precedes if swap then
    then drop                          ( s r c)
    over over r@ precedes              ( s r c f)
  while                                ( s r c)
    tuck r@ exchange                   ( s r)
  repeat then                          ( s r)
  drop drop r> swap r> swap            ( a e s)
;

: heapsort                             ( a n --)
  over >r                              ( a n)
  dup 1- 1- 2/                         ( a c s)
  begin                                ( a c s)
    dup 0< 0=                          ( a c s f)
  while                                ( a c s)
    siftDown 1-                        ( a c s)
  repeat drop                          ( a c)

  1- 0                                 ( a e 0)
  begin                                ( a e 0)
    over 0>                            ( a e 0 f)
  while                                ( a e 0)
    over over r@ exchange              ( a e 0)
    siftDown swap 1- swap              ( a e 0)
  repeat                               ( a e 0)
  drop drop drop r> drop
;

:noname >r cells r@ + @ swap cells r> + @ swap < ; is precedes
:noname >r cells r@ + swap cells r> + over @ over @ swap rot ! swap ! ; is exchange

: .array 10 0 do example i cells + ? loop cr ;

.array example 10 heapsort .array


\ Written in ANS-Forth; tested under VFX.
\ Requires the novice package: http://www.forth.org/novice.html
\ The following should already be done:
\ include novice.4th

\ This is already in the novice package, so it is not really necessary to compile the code provided here.

\ ****** 
\ ****** This is our array sort. We are using the heap-sort because it provides consistent times and it is not recursive.
\ ****** This code was ported from C++ at: http://www.snippets.24bytes.com/2010/06/heap-sort.html
\ ****** Our array record size must be a multiple of W. This is assured if FIELD is used for creating the record.
\ ****** The easiest way to speed this up is to rewrite EXCHANGE in assembly language.
\ ****** 

marker HeapSort.4th

macro: exchange ( adrX adrY size -- )   \ the size of the record must be a multiple of W
    begin  dup while                    \ -- adrX adrY remaining
        over @  fourth @                \ -- adrX adrY remaining Y X
        fourth !  fourth !              \ -- adrX adrY remaining
        rot w +  rot w +  rot w -  
        repeat
    3drop ;

\ All of these macros use the locals from SORT, and can only be called from SORT.

macro: adr ( index -- adr )  
    recsiz *  array + ;

macro: left ( x -- y )      2*  1+ ;
    
macro: right ( x -- y )     2*  2 + ;    

macro: heapify ( x -- )
    dup >r  begin   \ r: -- great
        dup left    dup limit < if      dup adr  rover adr  'comparer execute if    rdrop  dup >r   then then  drop
        dup right   dup limit < if      dup adr  r@ adr     'comparer execute if    rdrop  dup >r   then then  drop
        dup r@ <> while
            adr  r@ adr  recsiz exchange
            r@ repeat
    drop rdrop ;
                
macro: build-max-heap ( -- )
    limit 1- 2/  begin  dup 0>= while  dup heapify  1- repeat drop ;
    
: sort { array limit recsiz 'comparer -- }      
    recsiz  [ w 1- ] literal  and  abort" *** SORT: record size must be a multiple of the cell size ***"
    build-max-heap
    begin  limit while  -1 +to limit
        0 adr  limit adr  recsiz exchange
        0 heapify  repeat ;

\ The SORT locals:
\ array             \ the address of the 0th element
\ limit             \ the number of records in the array
\ recsiz            \ the size of a record in the array     \ this must be a multiple of W (FIELD assures this)
\ 'comparer         \ adrX adrY -- X>Y?

\ Note for the novice:
\ This code was originally written with colon words rather than macros, and using items rather than local variables.
\ After it was debugged, it was changed to use macros and locals so that it would be fast and reentrant.
\ One of the reasons why the heap-sort was chosen is because it is not recursive, which allows macros to be used.
\ Using macros allows the data (array, limit, recsiz, 'comparer) to be held in locals rather than items, which is reentrant.

    
\ ****** 
\ ****** This tests SORT.
\ ****** 

create aaa  2 , 9 , 3 , 6 , 1 , 4 , 5 , 7 , 0 , 8 ,

: print-aaa ( limit -- )
    cells aaa +  aaa do  I @ .  w +loop ;

: int> ( adrX adrY -- X>Y? )
    swap @  swap @  > ;
    
: test-sort ( limit -- )
    cr  dup print-aaa
    aaa  over  w  ['] int>  sort 
    cr  print-aaa ;    

10 test-sort
Output:
2 9 3 6 1 4 5 7 0 8 
0 1 2 3 4 5 6 7 8 9

Fortran

Works with: Fortran version 90 and later

Translation of the pseudocode

program Heapsort_Demo
  implicit none
  
  integer, parameter :: num = 20
  real :: array(num)
    
  call random_seed
  call random_number(array)
  write(*,*) "Unsorted array:-"
  write(*,*) array
  write(*,*)
  call heapsort(array)
  write(*,*) "Sorted array:-"
  write(*,*) array
  
contains

subroutine heapsort(a)

   real, intent(in out) :: a(0:)
   integer :: start, n, bottom
   real :: temp

   n = size(a)
   do start = (n - 2) / 2, 0, -1
     call siftdown(a, start, n);
   end do
   
   do bottom = n - 1, 1, -1
     temp = a(0)
     a(0) = a(bottom)
     a(bottom) = temp;
     call siftdown(a, 0, bottom)
   end do

end subroutine heapsort

subroutine siftdown(a, start, bottom)
  
  real, intent(in out) :: a(0:)
  integer, intent(in) :: start, bottom
  integer :: child, root
  real :: temp

  root = start
  do while(root*2 + 1 < bottom)
    child = root * 2 + 1
    
    if (child + 1 < bottom) then
      if (a(child) < a(child+1)) child = child + 1
    end if
    
    if (a(root) < a(child)) then
      temp = a(child)
      a(child) = a (root)
      a(root) = temp
      root = child
    else
      return
    end if  
  end do      
    
end subroutine siftdown

end program Heapsort_Demo

FreeBASIC

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

Print "Unsorted"
For i = lb To ub
    Print Using " ###"; array(i);
Next : Print : Print

heapsort(array())

Print "After heapsort"
For i = lb To ub
    Print Using " ###"; array(i);
Next : Print

' empty keyboard buffer
While Inkey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End
Output:
Unsorted
   0   3  -6   2   1  -4   7   5   6  -3   4  -7  -1  -5  -2

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

FunL

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

def heapSort( a ) =
  heapify( a )
  end = a.length() - 1

  while end > 0
    a(end), a(0) = a(0), a(end)
    siftDown( a, 0, --end )

def heapify( a ) =
  for i <- (a.length() - 2)\2..0 by -1
    siftDown( a, i, a.length() - 1 )

def siftDown( a, start, end ) =
  root = start

  while root*2 + 1 <= end
    child = root*2 + 1

    if child + 1 <= end and a(child) < a(child + 1)
      child++

    if a(root) < a(child)
      a(root), a(child) = a(child), a(root)
      root = child
    else
      break

a = array( [7, 2, 6, 1, 9, 5, 0, 3, 8, 4] )
heapSort( a )
println( a )
Output:
ArraySeq(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

Go

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

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

package main

import (
  "sort"
  "container/heap"
  "fmt"
)

type HeapHelper struct {
    container sort.Interface
    length    int
}

func (self HeapHelper) Len() int { return self.length }
// We want a max-heap, hence reverse the comparison
func (self HeapHelper) Less(i, j int) bool { return self.container.Less(j, i) }
func (self HeapHelper) Swap(i, j int) { self.container.Swap(i, j) }
// this should not be called
func (self *HeapHelper) Push(x interface{}) { panic("impossible") }
func (self *HeapHelper) Pop() interface{} {
    self.length--
    return nil // return value not used
}

func heapSort(a sort.Interface) {
    helper := HeapHelper{ a, a.Len() }
    heap.Init(&helper)
    for helper.length > 0 {
        heap.Pop(&helper)
    }
}

func main() {
    a := []int{170, 45, 75, -90, -802, 24, 2, 66}
    fmt.Println("before:", a)
    heapSort(sort.IntSlice(a))
    fmt.Println("after: ", a)
}
Output:
before: [170 45 75 -90 -802 24 2 66]
after:  [-802 -90 2 24 45 66 75 170]

If you want to implement it manually:

package main

import (
  "sort"
  "fmt"
)

func main() {
    a := []int{170, 45, 75, -90, -802, 24, 2, 66}
    fmt.Println("before:", a)
    heapSort(sort.IntSlice(a))
    fmt.Println("after: ", a)
}

func heapSort(a sort.Interface) {
    for start := (a.Len() - 2) / 2; start >= 0; start-- {
        siftDown(a, start, a.Len()-1)
    }
    for end := a.Len() - 1; end > 0; end-- {
        a.Swap(0, end)
        siftDown(a, 0, end-1)
    }
}


func siftDown(a sort.Interface, start, end int) {
    for root := start; root*2+1 <= end; {
        child := root*2 + 1
        if child+1 <= end && a.Less(child, child+1) {
            child++
        }
        if !a.Less(root, child) {
            return
        }
        a.Swap(root, child)
        root = child
    }
}

Groovy

Loose translation of the pseudocode:

def makeSwap = { a, i, j = i+1 -> print "."; a[[j,i]] = a[[i,j]] } 

def checkSwap = { list, i, j = i+1 -> [(list[i] > list[j])].find{ it }.each { makeSwap(list, i, j) } } 

def siftDown = { a, start, end ->
    def p = start
    while (p*2 < end) {
        def c = p*2 + ((p*2 + 1 < end && a[p*2 + 2] > a[p*2 + 1]) ? 2 : 1)
        if (checkSwap(a, c, p)) { p = c }
        else                    { return }
    }
}

def heapify = {
    (((it.size()-2).intdiv(2))..0).each { start -> siftDown(it, start, it.size()-1) }
}

def heapSort = { list ->
    heapify(list)
    (0..<(list.size())).reverse().each { end ->
        makeSwap(list, 0, end)
        siftDown(list, 0, end-1)
    }
    list
}

This is a better to read version. It includes comments and much better to understand and read function headers and loops. It also has better readable variable names and can therefore be better used for study purposes. It contains the same functions, even if a function with a single variable assignment in it is not very useful.

def makeSwap (list, element1, element2) {
    //exchanges two elements in a list.
    //print a dot for each swap.
    print "."
    list[[element2,element1]] = list[[element1,element2]]
}

def checkSwap (list, child, parent) {
    //check if parent is smaller than child, then swap.
    if (list[parent] < list[child]) makeSwap(list, child, parent)
}

def siftDown (list, start, end) {
    //end represents the limit of how far down the heap to sift
    //start is the head of the heap
    def parent = start
    while (parent*2 < end) { //While the root has at least one child
        def child = parent*2 + 1 //root*2+1 points to the left child
        //find the child with the higher value
        //if the child has a sibling and the child's value is less than its sibling's..
        if (child + 1 <= end && list[child] < list[child+1]) child++  //point to the other child
        if (checkSwap(list, child, parent)) {  //check if parent is smaller than child and swap
            parent = child                  //make child to next parent
        } else {
            return                          //The rest of the heap is in order - return.
        }
    }
}

def heapify (list) {
    // Create a heap out of a list
    // run through all the heap parents and
    // ensure that each parent is lager than the child for all parent/childs.
    // (list.size() -2) / 2 = last parent in the heap.
    for (start in ((list.size()-2).intdiv(2))..0 ) {
        siftDown(list, start, list.size() - 1)
    }
}

def heapSort (list) {
    //heap sort any unsorted list
    heapify(list)  //ensure that the list is in a binary heap state
    //Run the list backwards and
    //for end = (size of list -1 ) to 0
    for (end in (list.size()-1)..0 ) {
        makeSwap(list, 0, end)    //put the top of the heap to the end (largest element)
        siftDown(list, 0, end-1)    //ensure that the rest is a heap again
    }
    list
}

Test:

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

Haskell

data Tree a = Nil
            | Node a (Tree a) (Tree a)
            deriving Show

insert :: Ord a => a -> Tree a -> Tree a
insert x Nil = Node x Nil Nil
insert x (Node y leftBranch rightBranch)
  | x < y = Node x (insert y rightBranch) leftBranch
  | otherwise = Node y (insert x rightBranch) leftBranch

merge :: Ord a => Tree a -> Tree a -> Tree a
merge Nil t = t
merge t Nil = t
merge tx@(Node vx lx rx) ty@(Node vy ly ry)
  | vx < vy = Node vx (merge lx rx) ty
  | otherwise = Node vy tx (merge ly ry)

fromList :: Ord a => [a] -> Tree a
fromList = foldr insert Nil

toList :: Ord a => Tree a -> [a]
toList Nil = []
toList (Node x l r) = x : toList (merge l r)

heapSort :: Ord a => [a] -> [a]
heapSort = toList . fromList

e.g

ghci> heapSort [9,5,8,2,1,4,6,3,0,7]
[0,1,2,3,4,5,6,7,8,9]

Using package fgl from HackageDB

import Data.Graph.Inductive.Internal.Heap(
  Heap(..),insert,findMin,deleteMin)

-- heapsort is added in this module as an example application

build :: Ord a => [(a,b)] -> Heap a b
build = foldr insert Empty

toList :: Ord a => Heap a b -> [(a,b)]
toList Empty = []
toList h = x:toList r
           where (x,r) = (findMin h,deleteMin h)

heapSort :: Ord a => [a] -> [a]
heapSort = (map fst) . toList . build . map (\x->(x,x))

e.g.

*Main> heapsort [[6,9],[2,13],[6,8,14,9],[10,7],[5]]
[[2,13],[5],[6,8,14,9],[6,9],[10,7]]

Haxe

Translation of: D
class HeapSort {
  @:generic
  private static function siftDown<T>(arr: Array<T>, start:Int, end:Int) {
    var root = start;
    while (root * 2 + 1 <= end) {
      var child = root * 2 + 1;
      if (child + 1 <= end && Reflect.compare(arr[child], arr[child + 1]) < 0)
        child++;
      if (Reflect.compare(arr[root], arr[child]) < 0) {
        var temp = arr[root];
        arr[root] = arr[child];
        arr[child] = temp;
        root = child;
      } else {
        break;
      }
    }
  }

  @:generic
  public static function sort<T>(arr:Array<T>) {
    if (arr.length > 1)
    {
      var start = (arr.length - 2) >> 1;
      while (start > 0) {
        siftDown(arr, start - 1, arr.length - 1);
        start--;
      }
    }

    var end = arr.length - 1;
    while (end > 0) {
      var temp = arr[end];
      arr[end] = arr[0];
      arr[0] = temp;
      siftDown(arr, 0, end - 1);
      end--;
    }
  } 
}

class Main {
  static function main() {
    var integerArray = [1, 10, 2, 5, -1, 5, -19, 4, 23, 0];
    var floatArray = [1.0, -3.2, 5.2, 10.8, -5.7, 7.3, 
                      3.5, 0.0, -4.1, -9.5];
    var stringArray = ['We', 'hold', 'these', 'truths', 'to', 
                       'be', 'self-evident', 'that', 'all', 
                       'men', 'are', 'created', 'equal'];
    Sys.println('Unsorted Integers: ' + integerArray);
    HeapSort.sort(integerArray);
    Sys.println('Sorted Integers:   ' + integerArray);
    Sys.println('Unsorted Floats:   ' + floatArray);
    HeapSort.sort(floatArray);
    Sys.println('Sorted Floats:     ' + floatArray);
    Sys.println('Unsorted Strings:  ' + stringArray);
    HeapSort.sort(stringArray);
    Sys.println('Sorted Strings:    ' + stringArray);
  }
}
Output:
Unsorted Integers: [1,10,2,5,-1,5,-19,4,23,0]
Sorted Integers:   [-19,-1,0,1,2,4,5,5,10,23]
Unsorted Floats:   [1,-3.2,5.2,10.8,-5.7,7.3,3.5,0,-4.1,-9.5]
Sorted Floats:     [-9.5,-5.7,-4.1,-3.2,0,1,3.5,5.2,7.3,10.8]
Unsorted Strings:  [We,hold,these,truths,to,be,self-evident,that,all,men,are,created,equal]
Sorted Strings:    [We,all,are,be,created,equal,hold,men,self-evident,that,these,to,truths]

Icon and Unicon

procedure main()                     #: demonstrate various ways to sort a list and string 
   demosort(heapsort,[3, 14, 1, 5, 9, 2, 6, 3],"qwerty")
end

procedure heapsort(X,op)                            #: return sorted list ascending(or descending)
local head,tail

   op := sortop(op,X)                               # select how and what we sort

   every head := (tail := *X) / 2  to 1 by -1 do    # work back from from last parent node
      X := siftdown(X,op,head,tail)                 # sift down from head to make the heap 

   every tail := *X to 2 by -1 do {                 # work between the beginning and the tail to final positions
      X[1] :=: X[tail]
      X := siftdown(X,op,1,tail-1)                  # re-sift next (previous) branch after shortening the heap
      }

   return X
end

procedure siftdown(X,op,root,tail)                  #: the value @root is moved "down" the path of max(min) value to its level
local child

   while (child :=  root * 2) <= tail do {          # move down the branch from root to tail

      if op(X[child],X[tail >= child + 1]) then     # choose the larger(smaller) 
         child +:= 1                                # ... child 

      if op(X[root],X[child]) then  {               # root out of order? 
         X[child] :=: X[root]                       
         root := child                              # follow max(min) branch
         }
      else 
         return X
      }
   return X
end

Algorithm notes:

  • This is a fairly straight forward implementation of the pseudo-code with 'heapify' coded in-line.

Implementation notes:

  • Since this transparently sorts both string and list arguments the result must 'return' to bypass call by value (strings)
  • Beware missing trailing 'returns' when translating pseudo-code. For amusement try comment out the return at the end of 'shiftdown'

Note: This example relies on the supporting procedures 'sortop', and 'demosort' in Bubble Sort. The full demosort exercises the named sort of a list with op = "numeric", "string", ">>" (lexically gt, descending),">" (numerically gt, descending), a custom comparator, and also a string.

Abbreviated sample output:
Sorting Demo using procedure heapsort
  on list : [ 3 14 1 5 9 2 6 3 ]
    with op = &null:         [ 1 2 3 3 5 6 9 14 ]   (0 ms)
  ...
  on string : "qwerty"
    with op = &null:         "eqrtwy"   (0 ms)

J

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

Translation of the pseudocode

swap=: C.~ <

siftDown=: 4 : 0
  'c e'=. x
  while. e > c=.1+2*s=.c do.
    before=. <&({&y)
    if. e > 1+c do. c=.c+ c before c+1 end.
    if. s before c do. y=. y swap c,s else. break. end.
  end.
  y
)

heapSort=: 3 : 0
  if. 1>: c=. # y do. y return. end.
  z=. siftDown&.>/ (c,~each i.<.c%2),<y        NB. heapify
  > ([ siftDown swap~)&.>/ (0,each}.i.c),z
)

Examples

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

   heapSort &. (a.&i.) 'aqwcdhkij'
acdhijkqw

Janet

Translation of this Python code. Based on R. Sedgwick's Algorithms Section 2.4.

Although Janet is a (functional) Lisp, it has support for mutable arrays and imperative programming.

(defn swap [l a b]
  (let [aval (get l a) bval (get l b)]
    (put l a bval)
    (put l b aval)))

(defn heap-sort [l] 
  (def len (length l))
  # Invariant: heap[parent] <= heap[*children]
  (def heap (array/new (+ len 1)))
  (array/push heap nil)
  (def ROOT 1)

  # Returns the parent index of index, or nil if none
  (defn parent [idx]
    (assert (> idx 0))
    (if (= idx 1) nil (math/trunc (/ idx 2))))
  # Returns a tuple [a b] of the two child indices of idx
  (defn children [idx]
    (def a (* idx 2))
    (def b (+ a 1))
    (def l (length heap))
    # NOTE: `if` implicitly returns nil on false
    [(if (< a l) a) (if (< b l) b)])
  (defn check-invariants [idx]
    (def [a b] (children idx))
    (def p (parent idx))
    (assert (or (nil? a) (<= (get heap idx) (get heap a))))
    (assert (or (nil? b) (<= (get heap idx) (get heap b))))
    (assert (or (nil? p) (>= (get heap idx) (get heap p)))))
  (defn swim [idx]
    (def val (get heap idx))
    (def parent-idx (parent idx))
    (when (and (not (nil? parent-idx)) (< val (get heap parent-idx)))
      (swap heap parent-idx idx)
      (swim parent-idx)
    )
    (check-invariants idx))
  

  (defn sink [idx]
    (def [a b] (children idx))
    (def target-val (get heap idx))
    (def smaller-children @[])
    (defn handle-child [idx]
      (let [child-val (get heap idx)]
        (if (and (not (nil? idx)) (< child-val target-val))
          (array/push smaller-children idx))))
    (handle-child a)
    (handle-child b)
    (assert (<= (length smaller-children) 2))
    (def smallest-child (cond
      (empty? smaller-children) nil
      (= 1 (length smaller-children)) (get smaller-children 0)
      (< (get heap (get smaller-children 0)) (get heap (get smaller-children 1))) (get smaller-children 0)
      # NOTE: The `else` for final branch of `cond` is implicit
      (get smaller-children 1)
    ))
    (unless (nil? smallest-child)
      (swap heap smallest-child idx)
      (sink smallest-child)
      # Recheck invariants
      (check-invariants idx)))

  (defn insert [val]
    (def idx (length heap))
    (array/push heap val)
    (swim idx))

  (defn remove-smallest []
    (assert (> (length heap) 1))
    (def largest (get heap ROOT))
    (def new-root (array/pop heap))
    (when (> (length heap) 1)
      (put heap ROOT new-root)
      (sink ROOT))
    (assert (not (nil? largest)))
    largest)

  (each item l (insert item))

  (def res @[])
  (while (> (length heap) 1)
    (array/push res (remove-smallest)))
  res)

# NOTE: Makes a copy of input array. Output is mutable
(print (heap-sort [7 12 3 9 -1 17 6]))
Output:
    @[-1 3 6 7 9 12 17]

Java

Direct translation of the pseudocode.

public static void heapSort(int[] a){
	int count = a.length;

	//first place a in max-heap order
	heapify(a, count);

	int end = count - 1;
	while(end > 0){
		//swap the root(maximum value) of the heap with the
		//last element of the heap
		int tmp = a[end];
		a[end] = a[0];
		a[0] = tmp;
		//put the heap back in max-heap order
		siftDown(a, 0, end - 1);
		//decrement the size of the heap so that the previous
		//max value will stay in its proper place
		end--;
	}
}

public static void heapify(int[] a, int count){
	//start is assigned the index in a of the last parent node
	int start = (count - 2) / 2; //binary heap

	while(start >= 0){
		//sift down the node at index start to the proper place
		//such that all nodes below the start index are in heap
		//order
		siftDown(a, start, count - 1);
		start--;
	}
	//after sifting down the root all nodes/elements are in heap order
}

public static void siftDown(int[] a, int start, int end){
	//end represents the limit of how far down the heap to sift
	int root = start;

	while((root * 2 + 1) <= end){      //While the root has at least one child
		int child = root * 2 + 1;           //root*2+1 points to the left child
		//if the child has a sibling and the child's value is less than its sibling's...
		if(child + 1 <= end && a[child] < a[child + 1])
			child = child + 1;           //... then point to the right child instead
		if(a[root] < a[child]){     //out of max-heap order
			int tmp = a[root];
			a[root] = a[child];
			a[child] = tmp;
			root = child;                //repeat to continue sifting down the child now
		}else
			return;
	}
}

JavaScript

function heapSort(arr) {
    heapify(arr)
    end = arr.length - 1
    while (end > 0) {
        [arr[end], arr[0]] = [arr[0], arr[end]]
        end--
        siftDown(arr, 0, end)
    }
}

function heapify(arr) {
    start = Math.floor(arr.length/2) - 1

    while (start >= 0) {
        siftDown(arr, start, arr.length - 1)
        start--
    }
}

function siftDown(arr, startPos, endPos) {
    let rootPos = startPos

    while (rootPos * 2 + 1 <= endPos) {
        childPos = rootPos * 2 + 1
        if (childPos + 1 <= endPos && arr[childPos] < arr[childPos + 1]) {
            childPos++
        }
        if (arr[rootPos] < arr[childPos]) {
            [arr[rootPos], arr[childPos]] = [arr[childPos], arr[rootPos]]
            rootPos = childPos
        } else {
            return
        }
    }
}
test('rosettacode', () => {
    arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8,]
    heapSort(arr)
    expect(arr).toStrictEqual([1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15])
})
Output:
    [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15]

jq

Works with: jq

Works with gojq, the Go implementation of jq

Since jq is a purely functional language, the putative benefits of the heapsort algorithm do not accrue here.

def swap($a; $i; $j):
  $a
  | .[$i] as $t
  | .[$i] = .[$j]
  | .[$j] = $t ;

def siftDown($a; $start; $iend):
  { $a, root: $start }
  | until( .stop or (.root*2 + 1 > $iend);
      .child = .root*2 + 1
      | if .child + 1 <= $iend and .a[.child] < .a[.child+1]
        then .child += 1
	else .
	end
        | if .a[.root] < .a[.child]
          then
	  .a = swap(.a; .root; .child)
          | .root = .child
          else .stop = true
          end)
  | .a ;

def heapify:
  length as $count
  | {a: ., start: ((($count - 2)/2)|floor)}
  | until(.start < 0;
        .a = siftDown(.a; .start; $count - 1)
        | .start += -1 )
  | .a ;
 
def heapSort:
  { a: heapify,
    iend: (length - 1) }
  | until( .iend <= 0;
        .a = swap(.a; 0; .iend)
        | .iend += -1
        | .a = siftDown(.a; 0; .iend) )
  | .a ;
 
[4, 65, 2, -31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3]
|
 "Before: \(.)",
 "After : \(heapSort)\n"
Output:
Before: [4,65,2,-31,0,99,2,83,782,1]
After : [-31,0,1,2,2,4,65,83,99,782]

Before: [7,5,2,6,1,4,2,6,3]
After : [1,2,2,3,4,5,6,6,7]

Julia

function swap(a, i, j)
    a[i], a[j] = a[j], a[i] 
end
 
function pd!(a, first, last)
    while (c = 2 * first - 1) < last
        if c < last && a[c] < a[c + 1]
            c += 1
        end
        if a[first] < a[c]
            swap(a, c, first)
            first = c
        else
            break
        end
    end
end
 
function heapify!(a, n)
    f = div(n, 2)
    while f >= 1 
        pd!(a, f, n)
        f -= 1 
    end
end
 
function heapsort!(a)
    n = length(a)
    heapify!(a, n)
    l = n
    while l > 1 
        swap(a, 1, l)
        l -= 1
        pd!(a, 1, l)
    end
    return a
end

using Random: shuffle
a = shuffle(collect(1:12))
println("Unsorted: $a")
println("Heap sorted: ", heapsort!(a))
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

// version 1.1.0

fun heapSort(a: IntArray) {
    heapify(a)
    var end = a.size - 1
    while (end > 0) {
        val temp = a[end]
        a[end] = a[0]
        a[0] = temp
        end--
        siftDown(a, 0, end)
    }
}

fun heapify(a: IntArray) {
    var start = (a.size - 2) / 2
    while (start >= 0) {
        siftDown(a, start, a.size - 1)
        start--
    }
}

fun siftDown(a: IntArray, start: Int, end: Int) {
    var root = start
    while (root * 2 + 1 <= end) {
        var child = root * 2 + 1
        if (child + 1 <= end && a[child] < a[child + 1]) child++
        if (a[root] < a[child]) {
            val temp = a[root]
            a[root] = a[child]
            a[child] = temp
            root = child
        }
        else return
    }
}

fun main(args: Array<String>) {
    val aa = arrayOf(
        intArrayOf(100, 2, 56, 200, -52, 3, 99, 33, 177, -199),
        intArrayOf(4, 65, 2, -31, 0, 99, 2, 83, 782, 1),
        intArrayOf(12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8)
    )
    for (a in aa) {
        heapSort(a)
        println(a.joinToString(", "))
    }
}
Output:
-199, -52, 2, 3, 33, 56, 99, 100, 177, 200
-31, 0, 1, 2, 2, 4, 65, 83, 99, 782
1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15

Liberty BASIC

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

Lobster

def siftDown(a, start, end):
   // (end represents the limit of how far down the heap to sift)
   var root = start

   while root * 2 + 1 <= end:           // (While the root has at least one child)
      var 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]:
         child += 1                     // (... then point to the right child instead)
      if a[root] < a[child]:            // (out of max-heap order)
         let r = a[root]                // swap(a[root], a[child])
         a[root] = a[child]
         a[child] = r
         root = child                   // (repeat to continue sifting down the child now)
      else:
         return

def heapify(a, count):
   //(start is assigned the index in a of the last parent node)
   var start = (count - 2) >> 1

   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 -= 1
   // (after sifting down the root all nodes/elements are in heap order)

def heapSort(a):
   // input: an unordered array a of length count
   let count = a.length
   // (first place a in max-heap order)
   heapify(a, count)

   var end = count - 1
   while end > 0:
      //(swap the root(maximum value) of the heap with the last element of the heap)
      let z = a[0]
      a[0] = a[end]
      a[end] = z
      //(decrement the size of the heap so that the previous max value will stay in its proper place)
      end -= 1
      // (put the heap back in max-heap order)
      siftDown(a, 0, end)

let inputi = [1,10,2,5,-1,5,-19,4,23,0]
print ("input:  " + inputi)
heapSort(inputi)
print ("sorted: " + inputi)
let inputf = [1,-3.2,5.2,10.8,-5.7,7.3,3.5,0,-4.1,-9.5]
print ("input:  " + inputf)
heapSort(inputf)
print ("sorted: " + inputf)
let inputs = ["We","hold","these","truths","to","be","self-evident","that","all","men","are","created","equal"]
print ("input:  " + inputs)
heapSort(inputs)
print ("sorted: " + inputs)
Output:
input:  [1, 10, 2, 5, -1, 5, -19, 4, 23, 0]
sorted: [-19, -1, 0, 1, 2, 4, 5, 5, 10, 23]
input:  [1.0, -3.2, 5.2, 10.8, -5.7, 7.3, 3.5, 0.0, -4.1, -9.5]
sorted: [-9.5, -5.7, -4.1, -3.2, 0.0, 1.0, 3.5, 5.2, 7.3, 10.8]
input:  ["We", "hold", "these", "truths", "to", "be", "self-evident", "that", "all", "men", "are", "created", "equal"]
sorted: ["We", "all", "are", "be", "created", "equal", "hold", "men", "self-evident", "that", "these", "to", "truths"]

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

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

Maple

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;
Output:
[0,0,2,3,3,8,17,36,40,72]

Mathematica/Wolfram Language

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

MATLAB / Octave

This function definition is an almost exact translation of the pseudo-code into MATLAB, but I have chosen to make the heapify function inline because it is only called once in the pseudo-code. Also, MATLAB uses 1 based array indecies, therefore all of the pseudo-code has been translated to reflect that difference.

function list = heapSort(list)

    function list = siftDown(list,root,theEnd) 
        while (root * 2) <= theEnd
            
            child = root * 2;
            if (child + 1 <= theEnd) && (list(child) < list(child+1))
                child = child + 1;
            end
            
            if list(root) < list(child)
                list([root child]) = list([child root]); %Swap
                root = child;
            else
                return
            end
            
        end %while
    end %siftDown
    
    count = numel(list);
    
    %Because heapify is called once in pseudo-code, it is inline here
    start = floor(count/2);
        
    while start >= 1
        list = siftDown(list, start, count);
        start = start - 1;
    end
    %End Heapify
    
    while count > 1
        
        list([count 1]) = list([1 count]); %Swap        
        count = count - 1;
        list = siftDown(list,1,count);
        
    end
    
end

Sample Usage:

>> heapSort([4 3 1 5 6 2])

ans =

     1     2     3     4     5     6

MAXScript

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

Output:

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

Mercury

Works with: Mercury version 22.01.1


%%%-------------------------------------------------------------------

:- module heapsort_task.

:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module array.
:- import_module int.
:- import_module list.
:- import_module random.
:- import_module random.sfc16.

%%%-------------------------------------------------------------------
%%%
%%% heapsort/3 --
%%%
%%% A generic heapsort predicate. It takes a "Less_than" predicate to
%%% determine the order of the sort.
%%%
%%% That I call the predicate "Less_than" does not, by any means,
%%% preclude a descending order. This "Less_than" refers to the
%%% ordinals of the sequence. In other words, it means "comes before".
%%%
%%% The implementation closely follows the task pseudocode--although,
%%% of course, loops have been turned into tail recursions and arrays
%%% are treated as state variables.
%%%

:- pred heapsort(pred(T, T)::pred(in, in) is semidet,
                 array(T)::array_di, array(T)::array_uo) is det.
heapsort(Less_than, !Arr) :-
  heapsort(Less_than, size(!.Arr), !Arr).

:- pred heapsort(pred(T, T)::pred(in, in) is semidet, int::in,
                 array(T)::array_di, array(T)::array_uo) is det.
heapsort(Less_than, Count, !Arr) :-
  heapify(Less_than, Count, !Arr),
  heapsort_loop(Less_than, Count, Count - 1, !Arr).

:- pred heapsort_loop(pred(T, T)::pred(in, in) is semidet,
                      int::in, int::in,
                      array(T)::array_di, array(T)::array_uo) is det.
heapsort_loop(Less_than, Count, End, !Arr) :-
  if (End = 0) then true
  else (swap(End, 0, !Arr),
        sift_down(Less_than, 0, End - 1, !Arr),
        heapsort_loop(Less_than, Count, End - 1, !Arr)).

:- pred heapify(pred(T, T)::pred(in, in) is semidet, int::in,
                array(T)::array_di, array(T)::array_uo) is det.
heapify(Less_than, Count, !Arr) :-
  heapify(Less_than, Count, (Count - 2) // 2, !Arr).

:- pred heapify(pred(T, T)::pred(in, in) is semidet,
                int::in, int::in,
                array(T)::array_di, array(T)::array_uo) is det.
heapify(Less_than, Count, Start, !Arr) :-
  if (Start = -1) then true
  else (sift_down(Less_than, Start, Count - 1, !Arr),
        heapify(Less_than, Count, Start - 1, !Arr)).

:- pred sift_down(pred(T, T)::pred(in, in) is semidet,
                  int::in, int::in,
                  array(T)::array_di, array(T)::array_uo) is det.
sift_down(Less_than, Root, End, !Arr) :-
  if (End < (Root * 2) + 1) then true
  else (locate_child(Less_than, Root, End, !.Arr, Child),
        (if not Less_than(!.Arr^elem(Root), !.Arr^elem(Child))
         then true
         else (swap(Root, Child, !Arr),
               sift_down(Less_than, Child, End, !Arr)))).

:- pred locate_child(pred(T, T)::pred(in, in) is semidet,
                     int::in, int::in,
                     array(T)::in, int::out) is det.
locate_child(Less_than, Root, End, Arr, Child) :-
  Child0 = (Root * 2) + 1,
  (if (End =< Child0 + 1)
   then (Child = Child0)
   else if not Less_than(Arr^elem(Child0), Arr^elem(Child0 + 1))
   then (Child = Child0)
   else (Child = Child0 + 1)).

%%%-------------------------------------------------------------------

main(!IO) :-
  R = (sfc16.init),
  make_io_random(R, M, !IO),
  Generate = (pred(Index::in, Number::out, IO1::di, IO::uo) is det :-
                uniform_int_in_range(M, min(0, Index), 10, Number,
                                     IO1, IO)),
  generate_foldl(30, Generate, Arr0, !IO),
  print_line(Arr0, !IO),
  heapsort(<, Arr0, Arr1),
  print_line(Arr1, !IO),
  heapsort(>=, Arr1, Arr2),
  print_line(Arr2, !IO).

%%%-------------------------------------------------------------------
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:
Output:
$ mmc heapsort_task.m && ./heapsort_task
array([3, 9, 3, 8, 5, 7, 0, 7, 3, 9, 5, 0, 1, 2, 0, 5, 8, 0, 8, 3, 8, 2, 6, 6, 8, 5, 7, 6, 5, 7])
array([0, 0, 0, 0, 1, 2, 2, 3, 3, 3, 3, 5, 5, 5, 5, 5, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8, 8, 9, 9])
array([9, 9, 8, 8, 8, 8, 8, 7, 7, 7, 7, 6, 6, 6, 5, 5, 5, 5, 5, 3, 3, 3, 3, 2, 2, 1, 0, 0, 0, 0])

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

proc siftDown[T](a: var openarray[T]; start, ending: int) =
  var root = start
  while root * 2 + 1 < ending:
    var child = 2 * root + 1
    if child + 1 < ending and a[child] < a[child+1]:
      inc child
    if a[root] < a[child]:
      swap a[child], a[root]
      root = child
    else:
      return

proc heapSort[T](a: var openarray[T]) =
  let count = a.len
  for start in countdown((count - 2) div 2, 0):
    siftDown(a, start, count)
  for ending in countdown(count - 1, 1):
    swap a[ending], a[0]
    siftDown(a, 0, ending)

var a = @[4, 65, 2, -31, 0, 99, 2, 83, 782]
heapSort a
echo a
Output:
@[-31, 0, 2, 2, 4, 65, 83, 99, 782]

Objeck

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

    function : Heapify(a : Int[], count : Int) ~ Nil {
      start := (count - 2) / 2;
      while(start >= 0) {
        SiftDown(a, start, count - 1);
        start -= 1;
      };
    }

    function : SiftDown(a : Int[], start : Int, end : Int) ~ Nil {
      root := start;
      while((root * 2 + 1) <= end) {
        child := root * 2 + 1;
        if(child + 1 <= end & a[child] < a[child + 1]) {
          child := child + 1;
        };
        
        if(a[root] < a[child]) {
          tmp := a[root];
          a[root] := a[child];
          a[child] := tmp;
          root := child;
        }
        else {
          return;
        };  
      };
    }
  }
}

OCaml

let heapsort a =

  let swap i j =
    let t = a.(i) in a.(i) <- a.(j); a.(j) <- t in

  let sift k l =
    let rec check x y =
      if 2*x+1 < l then
        let ch =
          if y < l-1 && a.(y) < a.(y+1) then y+1 else y in
        if a.(x) < a.(ch) then (swap x ch; check ch (2*ch+1)) in
    check k (2*k+1) in

  let len = Array.length a in

  for start = (len/2)-1 downto 0 do
    sift start len;
  done;

  for term = len-1 downto 1 do
    swap term 0;
    sift 0 term;
  done;;

Usage:

let a = [|3;1;4;1;5;9;2;6;5;3;5;8;97;93;23;84;62;64;33;83;27;95|] in
  heapsort a;
  Array.iter (Printf.printf "%d ") a;;
print_newline ();;

let s = "Just to show this is a type-checked polymorphic function" in
let b = Array.init (String.length s) (String.get s) in
  heapsort b;
  Array.iter print_char b;;
print_newline ();;
Output:
1 1 2 3 3 4 5 5 5 6 8 9 23 27 33 62 64 83 84 93 95 97 
        -Jaccccdeeefhhhhiiiiklmnnoooooppprsssstttttuuwyy

Oz

A faithful translation of the pseudocode, adjusted to the fact that Oz arrays can start with an arbitrary index, not just 0 or 1.

declare
  proc {HeapSort A}
     Low = {Array.low A}
     High = {Array.high A}
     Count = High-Low+1
 
     %% heapify
     LastParent = Low + (Count-2) div 2
  in
     for Start in LastParent..Low;~1 do
        {Siftdown A Start High}
     end
 
     %% repeatedly put the maximum element to the end
     %% and re-heapify the rest
     for End in High..Low+1;~1 do
        {Swap A End Low}
        {Siftdown A Low End-1}
     end
  end
 
  proc {Siftdown A Start End}
     Low = {Array.low A}
     fun {FirstChildOf I} Low+(I-Low)*2+1 end
 
     Root = {NewCell Start}
  in
     for while:{FirstChildOf @Root} =< End
        break:Break
     do
        Child = {NewCell {FirstChildOf @Root}}
     in
        if @Child + 1 =< End andthen A.@Child < A.(@Child + 1) then
           Child := @Child + 1
        end
        if A.@Root < A.@Child then
           {Swap A @Root @Child}
           Root := @Child
        else
           {Break}
        end
     end
  end
 
  proc {Swap A I J}
     A.J := (A.I := A.J)
  end
 
  %% create array with indices ~1..7 and fill it
  Arr = {Array.new ~1 7 0}
  {Record.forAllInd unit(~1:3 0:1 4 1 5 9 2 6 5)
   proc {$ I V}
      Arr.I := V
   end}
in
  {HeapSort Arr}
  {Show {Array.toRecord unit Arr}}

Pascal

Works with: FPC

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

program HeapSortDemo;

{$mode objfpc}{$h+}{$b-}

procedure HeapSort(var a: array of Integer);
  procedure SiftDown(Root, Last: Integer);
  var
    Child, Tmp: Integer;
  begin
    while Root * 2 + 1 <= Last do begin
      Child := Root * 2 + 1;
      if (Child + 1 <= Last) and (a[Child] < a[Child + 1]) then
        Inc(Child);
      if a[Root] < a[Child] then begin
        Tmp := a[Root];
        a[Root] := a[Child];
        a[Child] := Tmp;
        Root := Child;
      end else exit;
    end;
  end;
var
  I, Tmp: Integer;
begin
  for I := Length(a) div 2 downto 0 do
    SiftDown(I, High(a));
  for I := High(a) downto 1 do begin
    Tmp := a[0];
    a[0] := a[I];
    a[I] := Tmp;
    SiftDown(0, I - 1);
  end;
end;

procedure PrintArray(const Name: string; const A: array of Integer);
var
  I: Integer;
begin
  Write(Name, ': [');
  for I := 0 to High(A) - 1 do
    Write(A[I], ', ');
  WriteLn(A[High(A)], ']');
end;

var
  a1: array[-7..5] of Integer = (-34, -20, 30, 13, 36, -10, 5, -25, 9, 19, 35, -50, 29);
  a2: array of Integer = (-9, 42, -38, -5, -38, 0, 0, -15, 37, 7, -7, 40);
begin
  HeapSort(a1);
  PrintArray('a1', a1);
  HeapSort(a2);
  PrintArray('a2', a2); 
end.
Output:
a1: [-50, -34, -25, -20, -10, 5, 9, 13, 19, 29, 30, 35, 36]
a2: [-38, -38, -15, -9, -7, -5, 0, 0, 7, 37, 40, 42]

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

Phix

with javascript_semantics

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

Picat

main =>
  _ = random2(),
  A = [random(-10,10) : _ in 1..30],
  println(A),
  heapSort(A),
  println(A).

heapSort(A) =>
  heapify(A),
  End = A.len,
  while (End > 1)
    swap(A, End, 1),
    End := End - 1,
    siftDown(A, 1, End)
  end.

heapify(A) =>
  Count = A.len,
  Start = Count // 2,
  while (Start >= 1)  
    siftDown(A, Start, Count),
    Start := Start - 1
  end.
 
siftDown(A, Start, End) =>
  Root = Start,
  Loop = true,
  while (Root * 2 - 1 < End, Loop == true)
    Child := Root * 2- 1,
    if Child + 1 <= End, A[Child] @< A[Child+1] then
      Child := Child + 1
    end,
    if A[Root] @< A[Child] then
      swap(A,Root, Child),
      Root := Child
    else
       Loop := false
    end
  end.

swap(L,I,J)  =>
  T = L[I],
  L[I] := L[J],
  L[J] := T.
Output:
[6,2,3,1,9,2,5,1,-7,1,2,1,-1,-7,2,0,4,-6,4,-8,1,9,3,5,-6,-6,0,7,-8,-2]
[-8,-8,-7,-7,-6,-6,-6,-2,-1,0,0,1,1,1,1,1,2,2,2,2,3,3,4,4,5,5,6,7,9,9]


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) ) ) )
Output:
: (heapSort (make (do 9 (link (rand 1 999)))))
-> (1 167 183 282 524 556 638 891 902)

PL/I

*process source xref attributes or(!);
 /*********************************************************************
 * Pseudocode found here:
 *   http://en.wikipedia.org/wiki/Heapsort#Pseudocode
 * Sample data from REXX
 * 27.07.2013 Walter Pachl
 *********************************************************************/
 heaps: Proc Options(main);
 Dcl a(0:25) Char(50) Var Init(
      '---letters of the modern Greek Alphabet---',
      '==========================================',
      'alpha','beta','gamma','delta','epsilon','zeta','eta','theta',
      'iota','kappa','lambda','mu','nu','xi','omicron','pi',
      'rho','sigma','tau','upsilon','phi','chi','psi','omega');
 Dcl n Bin Fixed(31) Init((hbound(a)+1));

 Call showa('before sort');
 Call heapsort((n));
 Call showa(' after sort');

 heapSort: Proc(count);
   Dcl (count,end) Bin Fixed(31);
   Call heapify((count));
   end=count-1;
   do while(end>0);
     Call swap(end,0);
     end=end-1;
     Call siftDown(0,(end));
     End;
   End;

 heapify: Proc(count);
   Dcl (count,start) Bin Fixed(31);
   start=(count-2)/2;
   Do while (start>=0);
     Call siftDown((start),count-1);
     start=start-1;
     End;
   End;

 siftDown: Proc(start,end);
   Dcl (count,start,root,end,child,sw) Bin Fixed(31);
   root=start;
   Do while(root*2+1<= end);
     child=root*2+1;
     sw=root;
     if a(sw)<a(child) Then
       sw=child;
     if child+1<=end & a(sw)<a(child+1) Then
       sw=child+1;
     if sw^=root Then Do;
       Call swap(root,sw);
       root=sw;
       End;
     else
       return;
     End;
   End;

 swap: Proc(x,y);
 Dcl (x,y) Bin Fixed(31);
 Dcl temp Char(50) Var;
   temp=a(x);
   a(x)=a(y);
   a(y)=temp;
   End;

 showa: Proc(txt);
 Dcl txt Char(*);
 Dcl j Bin Fixed(31);
 Do j=0 To hbound(a);
   Put Edit('element',j,txt,a(j))(skip,a,f(3),x(1),a,x(1),a);
   End;
 End;

 End;
Output:
element  0 before sort ---letters of the modern Greek Alphabet---
element  1 before sort ==========================================
element  2 before sort alpha
element  3 before sort beta
element  4 before sort gamma
element  5 before sort delta
element  6 before sort epsilon
element  7 before sort zeta
element  8 before sort eta
element  9 before sort theta
element 10 before sort iota
element 11 before sort kappa
element 12 before sort lambda
element 13 before sort mu
element 14 before sort nu
element 15 before sort xi
element 16 before sort omicron
element 17 before sort pi
element 18 before sort rho
element 19 before sort sigma
element 20 before sort tau
element 21 before sort upsilon
element 22 before sort phi
element 23 before sort chi
element 24 before sort psi
element 25 before sort omega
element  0  after sort ---letters of the modern Greek Alphabet---
element  1  after sort ==========================================
element  2  after sort alpha
element  3  after sort beta
element  4  after sort chi
element  5  after sort delta
element  6  after sort epsilon
element  7  after sort eta
element  8  after sort gamma
element  9  after sort iota
element 10  after sort kappa
element 11  after sort lambda
element 12  after sort mu
element 13  after sort nu
element 14  after sort omega
element 15  after sort omicron
element 16  after sort phi
element 17  after sort pi
element 18  after sort psi
element 19  after sort rho
element 20  after sort sigma
element 21  after sort tau
element 22  after sort theta
element 23  after sort upsilon
element 24  after sort xi
element 25  after sort zeta

PL/M

100H:

/* HEAP SORT AN ARRAY OF 16-BIT INTEGERS */
HEAP$SORT: PROCEDURE (AP, COUNT);
    SIFT$DOWN: PROCEDURE (AP, START, ENDV);
        DECLARE (AP, A BASED AP) ADDRESS;
        DECLARE (START, ENDV, ROOT, CHILD, TEMP) ADDRESS;
        ROOT = START;
        
        DO WHILE (CHILD := SHL(ROOT,1) + 1) <= ENDV;
            IF CHILD + 1 <= ENDV AND A(CHILD) < A(CHILD+1) THEN
                CHILD = CHILD + 1;
            IF A(ROOT) < A(CHILD) THEN DO;
                TEMP = A(ROOT);
                A(ROOT) = A(CHILD);
                A(CHILD) = TEMP;
                ROOT = CHILD;
            END;
            ELSE RETURN;
        END;
    END SIFT$DOWN;

    HEAPIFY: PROCEDURE (AP, COUNT);
        DECLARE (AP, COUNT, START) ADDRESS;
        START = (COUNT-2) / 2;
    LOOP:
        CALL SIFT$DOWN(AP, START, COUNT-1);
        IF START = 0 THEN RETURN;
        START = START - 1;
        GO TO LOOP;
    END HEAPIFY;
    
    DECLARE (AP, COUNT, ENDV, TEMP, A BASED AP) ADDRESS;
    
    CALL HEAPIFY(AP, COUNT);
    ENDV = COUNT - 1;
    DO WHILE ENDV > 0;
        TEMP = A(0);
        A(0) = A(ENDV);
        A(ENDV) = TEMP;
        ENDV = ENDV - 1;
        CALL SIFT$DOWN(AP, 0, ENDV);
    END;
END HEAP$SORT;

/* CP/M CALLS AND FUNCTION TO PRINT INTEGERS */
BDOS: PROCEDURE (FN, ARG);
    DECLARE FN BYTE, ARG ADDRESS;
    GO TO 5;
END BDOS;

PRINT$NUMBER: PROCEDURE (N);
    DECLARE S (7) BYTE INITIAL ('..... $');
    DECLARE (N, P) ADDRESS, C BASED P BYTE;
    P = .S(5);
DIGIT:
    P = P-1;
    C = N MOD 10 + '0';
    N = N / 10;
    IF N > 0 THEN GO TO DIGIT;
    CALL BDOS(9, P);
END PRINT$NUMBER;

/* SORT AN ARRAY */
DECLARE NUMBERS (11) ADDRESS INITIAL (4, 65, 2, 31, 0, 99, 2, 8, 3, 782, 1);
CALL HEAP$SORT(.NUMBERS, LENGTH(NUMBERS));

/* PRINT THE SORTED ARRAY */
DECLARE N BYTE;
DO N = 0 TO LAST(NUMBERS);
    CALL PRINT$NUMBER(NUMBERS(N));
END;

CALL BDOS(0,0);
EOF
Output:
0 1 2 2 3 4 8 31 65 99 782

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

Output:

3 8 11 19 21 36 60 63 80 87 100

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

Python

def heapsort(lst):
  ''' Heapsort. Note: this function sorts in-place (it mutates the list). '''

  # in pseudo-code, heapify only called once, so inline it here
  for start in range((len(lst)-2)/2, -1, -1):
    siftdown(lst, start, len(lst)-1)

  for end in range(len(lst)-1, 0, -1):
    lst[end], lst[0] = lst[0], lst[end]
    siftdown(lst, 0, end - 1)
  return lst

def siftdown(lst, start, end):
  root = start
  while True:
    child = root * 2 + 1
    if child > end: break
    if child + 1 <= end and lst[child] < lst[child + 1]:
      child += 1
    if lst[root] < lst[child]:
      lst[root], lst[child] = lst[child], lst[root]
      root = child
    else:
      break

Testing:

>>> ary = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
>>> heapsort(ary)
[0, 1, 2, 3, 4, 5, 6, 7, 8, 9]

Quackery

This uses code from Priority queue#Quackery.

  [ [] swap pqwith >
    dup pqsize times
      [ frompq rot join swap ]
    drop ]                     is hsort ( [ --> [ )
  
  [] 23 times [ 90 random 10 + join ] 
  say "     " dup echo cr 
  say " --> " hsort echo

Output:

     [ 45 82 25 50 14 45 11 25 21 91 10 63 77 42 80 99 16 81 88 97 84 80 87 ]
 --> [ 10 11 14 16 21 25 25 42 45 45 50 63 77 80 80 81 82 84 87 88 91 97 99 ]

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)

Raku

(formerly Perl 6)

sub heap_sort ( @list ) {
    for ( 0 ..^ +@list div 2 ).reverse -> $start {
        _sift_down $start, @list.end, @list;
    }

    for ( 1 ..^ +@list ).reverse -> $end {
        @list[ 0, $end ] .= reverse;
        _sift_down 0, $end-1, @list;
    }
}

sub _sift_down ( $start, $end, @list ) {
    my $root = $start;
    while ( my $child = $root * 2 + 1 ) <= $end {
        $child++ if $child + 1 <= $end and [<] @list[ $child, $child+1 ];
        return if @list[$root] >= @list[$child];
        @list[ $root, $child ] .= reverse;
        $root = $child;
    }
}

my @data = 6, 7, 2, 1, 8, 9, 5, 3, 4;
say 'Input  = ' ~ @data;
@data.&heap_sort;
say 'Output = ' ~ @data;
Output:
Input  = 6 7 2 1 8 9 5 3 4
Output = 1 2 3 4 5 6 7 8 9

REXX

version 1, elements of an array

This REXX version uses a   heapsort   to sort elements of an array which is constructed from a list of words or numbers,
or a mixture of both.

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

/*REXX pgm sorts an array (names of epichoric Greek letters) using a heapsort algorithm.*/
parse arg x;                 call init           /*use args or default,  define @ array.*/
call show     "before sort:"                     /*#:    the number of elements in array*/
call heapSort       #;       say copies('▒', 40) /*sort; then after sort, show separator*/
call show     " after sort:"
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
init: _= '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"
      if x=''  then x= _;                 #= words(x)          /*#: number of words in X*/
            do j=1  for #;  @.j= word(x, j);  end;     return  /*assign letters to array*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
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 heapSuff 1,n-1
            end   /*n*/;           return        /* [↑]  swap two elements; and shuffle.*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
heapSuff: 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            /*define lowest.*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
show:     do s=1  for #;  say '    element' right(s, length(#)) arg(1) @.s;  end;   return
output   when using the default   (epichoric Greek alphabet)   for input:

(Shown at three-quarter size.)

    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
output   when using the following for input:     19  0  -.2  .1  1e5  19  17  -6  789  11  37

(Shown at three-quarter size.)

    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

On an ASCII system, numbers are sorted   before   letters.

output   when executing on an   ASCII   system using the following for input:     11   33   22   scotoma   pareidolia
    element 1 before sort: 11
    element 2 before sort: 33
    element 3 before sort: 22
    element 4 before sort: scotoma
    element 5 before sort: pareidolia
▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
    element 1  after sort: 11
    element 2  after sort: 22
    element 3  after sort: 33
    element 4  after sort: pareidolia
    element 5  after sort: scotoma

On an EBCDIC system, numbers are sorted   after   letters.

output   when executing on an   EBCDIC   system using the following for input:     11   33   22   scotoma   pareidolia
    element 1 before sort: 11
    element 2 before sort: 33
    element 3 before sort: 22
    element 4 before sort: scotoma
    element 5 before sort: pareidolia
▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒▒
    element 1  after sort: pareidolia
    element 2  after sort: scotoma
    element 3  after sort: 11
    element 4  after sort: 22
    element 5  after sort: 33

version 2

/* REXX ***************************************************************
* Translated from PL/I
* 27.07.2013 Walter Pachl
**********************************************************************/
 list='---letters of the modern Greek Alphabet---|'||,
      '==========================================|'||,
      'alpha|beta|gamma|delta|epsilon|zeta|eta|theta|'||,
      'iota|kappa|lambda|mu|nu|xi|omicron|pi|'||,
      'rho|sigma|tau|upsilon|phi|chi|psi|omega'
 Do i=0 By 1 While list<>''
   Parse Var list a.i '|' list
   End
 n=i-1

 Call showa 'before sort'
 Call heapsort n
 Call showa ' after sort'
 Exit

 heapSort: Procedure Expose a.
 Parse Arg count
 Call heapify count
 end=count-1
 do while end>0
   Call swap end,0
   end=end-1
   Call siftDown 0,end
   End
 Return

 heapify: Procedure Expose a.
 Parse Arg count
 start=(count-2)%2
 Do while start>=0
   Call siftDown start,count-1
   start=start-1
   End
 Return

 siftDown: Procedure Expose a.
 Parse Arg start,end
 root=start
 Do while root*2+1<= end
   child=root*2+1
   sw=root
   if a.sw<a.child Then
     sw=child
   child_1=child+1
   if child+1<=end & a.sw<a.child_1 Then
     sw=child+1
   if sw<>root Then Do
     Call swap root,sw
     root=sw
     End
   else
     return
   End
 Return

 swap: Procedure Expose a.
 Parse arg x,y
 temp=a.x
 a.x=a.y
 a.y=temp
 Return

 showa: Procedure Expose a. n
 Parse Arg txt
 Do j=0 To n-1
   Say 'element' format(j,2) txt a.j
   End
 Return

Output: see PL/I

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)
next
 
func cheapify(a)
m = len(a)
for s = floor((m - 1) / 2) to 1 step -1
     siftdown(a,s,m)
next
 
func siftdown(a,s,e)
r = s
while r * 2 + 1 <= e
         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

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

class Array
  def heapsort
    self.dup.heapsort!
  end

  def heapsort!
    # in pseudo-code, heapify only called once, so inline it here
    ((length - 2) / 2).downto(0) {|start| siftdown(start, length - 1)}

    # "end" is a ruby keyword
    (length - 1).downto(1) do |end_|
      self[end_], self[0] = self[0], self[end_]
      siftdown(0, end_ - 1)
    end
    self
  end

  def siftdown(start, end_)
    root = start
    loop do
      child = root * 2 + 1
      break if child > end_
      if child + 1 <= end_ and self[child] < self[child + 1]
        child += 1
      end
      if self[root] < self[child]
        self[root], self[child] = self[child], self[root]
        root = child
      else
        break
      end
    end
  end
end

Testing:

irb(main):035:0> ary = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
=> [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]
irb(main):036:0> ary.heapsort
=> [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]

Rust

Translation of: Python

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

fn main() {
    let mut v = [4, 6, 8, 1, 0, 3, 2, 2, 9, 5];
    heap_sort(&mut v, |x, y| x < y);
    println!("{:?}", v);
}

fn heap_sort<T, F>(array: &mut [T], order: F)
where
    F: Fn(&T, &T) -> bool,
{
    let len = array.len();
    // Create heap
    for start in (0..len / 2).rev() {
        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;
        }
    }
}

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

use std::collections::BinaryHeap;

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

Scala

Works with: Scala version 2.8

This code is not written for maximum performance, though, of course, it preserves the O(n log n) characteristic of heap sort.

def heapSort[T](a: Array[T])(implicit ord: Ordering[T]) {
  import scala.annotation.tailrec // Ensure functions are tail-recursive
  import ord._
  
  val indexOrdering = Ordering by a.apply

  def numberOfLeaves(heapSize: Int) = (heapSize + 1) / 2
  
  def children(i: Int, heapSize: Int) = {
    val leftChild = i * 2 + 1
    leftChild to leftChild + 1 takeWhile (_ < heapSize)
  }

  def swap(i: Int, j: Int) = {
    val tmp = a(i)
    a(i) = a(j)
    a(j) = tmp
  }
  
  // Maintain partial ordering by bubbling down elements
  @tailrec 
  def siftDown(i: Int, heapSize: Int) {
    val childrenOfI = children(i, heapSize)
    if (childrenOfI nonEmpty) {
      val biggestChild = childrenOfI max indexOrdering
      if (a(i) < a(biggestChild)) {
        swap(i, biggestChild)
        siftDown(biggestChild, heapSize)
      }
    }
  }
  
  // Prepare heap by sifting down all non-leaf elements
  for (i <- a.indices.reverse drop numberOfLeaves(a.size)) siftDown(i, a.size)
  
  // Sort from the end of the array forward, by swapping the highest element,
  // which is always the top of the heap, to the end of the unsorted array
  for (i <- a.indices.reverse) {
    swap(0, i)
    siftDown(0, i)
  }
}

Scheme

Works with: Scheme version RRS
; swap two elements of a vector
(define (swap! v i j)
  (define temp (vector-ref v i))
  (vector-set! v i (vector-ref v j))
  (vector-set! v j temp))

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

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

(define (heapsort v)
  ; swap root and end node values,
  ; sift the first element into place
  ; and recurse with new root and next-to-end node
  (define (iter v end)
    (if (zero? end)
        'done
        (begin
          (swap! v 0 end)
          (sift-down! v 0 (- end 1))
          (iter v (- end 1)))))
  (begin
    (heapify v)
    ; start swapping with root and final node
    (iter v (- (vector-length v) 1))))
    
; testing
(define uriah (list->vector '(3 5 7 9 0 8 1 4 2 6)))
(heapsort uriah)
uriah
Output:
done
#(0 1 2 3 4 5 6 7 8 9)

Seed7

const proc: downheap (inout array elemType: arr, in var integer: k, in integer: n) is func
  local
    var elemType: help is elemType.value;
    var integer: j is 0;
  begin
    if k <= n div 2 then
      help := arr[k];
      repeat
        j := 2 * k;
        if j < n and arr[j] < arr[succ(j)] then
          incr(j);
        end if;
        if help < arr[j] then
          arr[k] := arr[j];
          k := j;
        end if;
      until help >= arr[j] or k > n div 2;
      arr[k] := help;
    end if;
  end func;

const proc: heapSort (inout array elemType: arr) is func
  local
    var integer: n is 0;
    var integer: k is 0;
    var elemType: help is elemType.value;
  begin
    n := length(arr);
    for k range n div 2 downto 1 do
      downheap(arr, k, n);
    end for;
    repeat
      help := arr[1];
      arr[1] := arr[n];
      arr[n] := help;
      decr(n);
      downheap(arr, 1, n);
    until n <= 1;
  end func;

Original source: [1]

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

Sidef

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

func heapify(a, count) {
    var start = ((count - 2) / 2)
    while (start >= 0) {
        sift_down(a, start, count-1)
        start -= 1
    }
}

func heap_sort(a, count) {
    heapify(a, count)
    var end = (count - 1)
    while (end > 0) {
        a[0, end] = a[end, 0]
        end -= 1
        sift_down(a, 0, end)
    }
    return a
}

var arr = (1..10 -> shuffle)   # creates a shuffled array
say arr                        # prints the unsorted array
heap_sort(arr, arr.len)        # sorts the array in-place
say arr                        # prints the sorted array
Output:
[10, 5, 2, 1, 7, 6, 4, 8, 3, 9]
[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]

Standard ML

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

(* Pairing heap - http://en.wikipedia.org/wiki/Pairing_heap *)
functor PairingHeap(type t
                    val cmp : t * t -> order) =
struct
  datatype 'a heap = Empty
                   | Heap of 'a * 'a heap list;

  (* merge, O(1)
   * Merges two heaps *)
  fun merge (Empty, h) = h
    | merge (h, Empty) = h
    | merge (h1 as Heap(e1, s1), h2 as Heap(e2, s2)) =
        case cmp (e1, e2) of LESS => Heap(e1, h2 :: s1)
                            |   _ => Heap(e2, h1 :: s2)

  (* insert, O(1)
   * Inserts an element into the heap *)
  fun insert (e, h) = merge (Heap (e, []), h)

  (* findMin, O(1)
   * Returns the smallest element of the heap *)
  fun findMin Empty = raise Domain
    | findMin (Heap(e, _)) = e

  (* deleteMin, O(lg n) amortized
   * Deletes the smallest element of the heap *)
  local
    fun mergePairs [] = Empty
      | mergePairs [h] = h
      | mergePairs (h1::h2::hs) = merge (merge(h1, h2), mergePairs hs)
  in
    fun deleteMin Empty = raise Domain
      | deleteMin (Heap(_, s)) = mergePairs s
  end

  (* build, O(n)
   * Builds a heap from a list *)
  fun build es = foldl insert Empty es;
end

local
  structure IntHeap = PairingHeap(type t = int; val cmp = Int.compare);
  open IntHeap

  fun heapsort' Empty = []
    | heapsort' h = findMin h :: (heapsort' o deleteMin) h;
in
  fun heapsort ls = (heapsort' o build) ls

  val test_0 = heapsort [] = []
  val test_1 = heapsort [1,2,3] = [1, 2, 3]
  val test_2 = heapsort [1,3,2] = [1, 2, 3]
  val test_3 = heapsort [6,2,7,5,8,1,3,4] = [1, 2, 3, 4, 5, 6, 7, 8]
end;

Stata

Variant with siftup and siftdown, using Mata.

function siftup(a, i) {
	k = i
	while (k > 1) {
		p = floor(k/2)
		if (a[k] > a[p]) {
			s = a[p]
			a[p] = a[k]
			a[k] = s
			k = p
		}
		else break
	}
}

function siftdown(a, i) {
	k = 1
	while (1) {
		l = k+k
		if (l > i) break
		if (l+1 <= i) {
			if (a[l+1] > a[l]) l++
		}
		if (a[k] < a[l]) {
			s = a[k]
			a[k] = a[l]
			a[l] = s
			k = l
		}
		else break
	}
}

function heapsort(a) {
	n = length(a)
	for (i = 2; i <= n; i++) {
		siftup(a, i)
	}
	for (i = n; i >= 2; i--) {
		s = a[i]
		a[i] = a[1]
		a[1] = s
		siftdown(a, i-1)
	}
}

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

Tcl

Based on the algorithm from Wikipedia:

Works with: Tcl version 8.5
package require Tcl 8.5

proc heapsort {list {count ""}} {
    if {$count eq ""} {
	set count [llength $list]
    }
    for {set i [expr {$count/2 - 1}]} {$i >= 0} {incr i -1} {
	siftDown list $i [expr {$count - 1}]
    }
    for {set i [expr {$count - 1}]} {$i > 0} {} {
	swap list $i 0
	incr i -1
	siftDown list 0 $i
    }
    return $list
}
proc siftDown {varName i j} {
    upvar 1 $varName a
    while true {
	set child [expr {$i*2 + 1}]
	if {$child > $j} {
	    break
	}
	if {$child+1 <= $j && [lindex $a $child] < [lindex $a $child+1]} {
	    incr child
	}
	if {[lindex $a $i] >= [lindex $a $child]} {
	    break
	}
	swap a $i $child
	set i $child
    }
}
proc swap {varName x y} {
    upvar 1 $varName a
    set tmp [lindex $a $x]
    lset a $x [lindex $a $y]
    lset a $y $tmp
}

Demo code:

puts [heapsort {1 5 3 7 9 2 8 4 6 0}]
Output:
0 1 2 3 4 5 6 7 8 9

TI-83 BASIC

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

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


True BASIC

Translation of: Liberty BASIC
!creamos la matriz y la inicializamos
LET lim = 20
DIM array(20)
FOR i = 1 TO lim
    LET array(i) = INT(RND * 100) + 1
NEXT i

SUB printArray (lim)
    FOR i = 1 TO lim
        !PRINT using("###", array(i));
        PRINT array(i); " ";
    NEXT i
    PRINT
END SUB

SUB heapify (count)
    LET start = INT(count / 2)
    DO WHILE start >= 1
       CALL siftDown (start, count)
       LET start = start - 1
    LOOP
END SUB

SUB siftDown (inicio, final)
    LET root = inicio
    DO WHILE root * 2 <= final
       LET child = root * 2
       LET SWAP = root
       IF array(SWAP) < array(child) THEN
          LET SWAP = child
       END IF
       IF child+1 <= final  THEN
          IF array(SWAP) < array(child+1) THEN
             LET SWAP = child + 1
          END IF
       END IF
       IF SWAP <> root THEN
          CALL SWAP (root, SWAP)
          LET root = SWAP
       ELSE
          EXIT SUB
       END IF
    LOOP
END SUB

SUB SWAP (x,y)
    LET tmp  = array(x)
    LET array(x) = array(y)
    LET array(y) = tmp
END SUB

SUB heapSort (count)
    CALL heapify (count)

    PRINT "el montículo:"
    CALL printArray (count)

    LET final = count
    DO WHILE final > 1
       CALL SWAP (final, 1)
       CALL siftDown (1, final-1)
       LET final = final - 1
    LOOP
END SUB

!--------------------------
PRINT "Antes de ordenar:"
CALL printArray (lim)
PRINT
CALL heapSort (lim)
PRINT
PRINT "Despues de ordenar:"
CALL printArray (lim)
END


uBasic/4tH

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

Vala

Translation of: C++
void swap(int[] array, int i1, int i2) { 
  if (array[i1] == array[i2])
    return;
  var tmp = array[i1];
  array[i1] = array[i2];
  array[i2] = tmp;
}

void shift_down(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, i_big);
    i = i_big;
  }
}

void to_heap(int[] array) {
  int i = (array.length / 2) - 1;
  while (i >= 0) {
    shift_down(array, i, array.length);
    --i;
  }
}

void heap_sort(int[] array) {
  to_heap(array);
  int end = array.length - 1;
  while (end > 0) {
    swap(array, 0, end);
    shift_down(array, 0, end);
    --end;
  }
}

void main() {
  int[] data = {
    12, 11, 15, 10,  9, 
     1,  2, 13,  3, 14, 
     4,  5,  6,  7,  8
  };
  heap_sort(data);
  foreach (int i in data) {
    stdout.printf("%d ", i);
  }
}
Output:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

VBA

Translation of: FreeBASIC
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

V (Vlang)

fn main() {
	mut test_arr := [4, 65, 2, -31, 0, 99, 2, 83, 782, 1]	
	println('Before : $test_arr')
	heap_sort(mut test_arr)  // Heap Sort
	println('After : $test_arr')
}

[direct_array_access]
fn heap_sort(mut array []int) {
	n := array.len
	for i := n/2; i > -1; i-- {
		heapify(mut array, n, i)  // Max heapify
	}
	for i := n - 1; i > 0; i-- {
		array[i], array[0] = array[0], array[i]
		heapify(mut array, i, 0)
	}
}

[direct_array_access]
fn heapify(mut array []int, n int, i int) {
	mut largest := i
	left := 2 * i + 1
	right := 2 * i + 2
	if left < n && array[i] < array[left] {
		largest = left
	}
	if right < n && array[largest] < array[right] {
		largest = right
	}
	if largest != i {
		array[i], array[largest] = array[largest], array[i]
		heapify(mut array, n, largest)
	}
}
Output:
Before : [4, 65, 2, -31, 0, 99, 2, 83, 782, 1]
After : [-31, 0, 1, 2, 2, 4, 65, 83, 99, 782]

Wren

var siftDown = Fn.new { |a, start, end|
    var root = start
    while (root*2 + 1 <= end) {
        var child = root*2 + 1
        if (child + 1 <= end && a[child] < a[child+1]) child = child + 1
        if (a[root] < a[child]) {
            var t = a[root]
            a[root] = a[child]
            a[child] = t
            root = child
        } else {
            return
        }
    }
}

var heapify = Fn.new { |a, count|
    var start = ((count - 2)/2).floor
    while (start >= 0) {
        siftDown.call(a, start, count - 1)
        start = start - 1
    }
}

var heapSort = Fn.new { |a|
    var count = a.count
    heapify.call(a, count)
    var end = count - 1
    while (end > 0) {
        var t = a[end]
        a[end] = a[0]
        a[0] = t
        end = end - 1
        siftDown.call(a, 0, end)
    }
}

var array = [ [4, 65, 2, -31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ]
for (a in array) {
    System.print("Before: %(a)")
    heapSort.call(a)
    System.print("After : %(a)")
    System.print()
}
Output:
Before: [4, 65, 2, -31, 0, 99, 2, 83, 782, 1]
After : [-31, 0, 1, 2, 2, 4, 65, 83, 99, 782]

Before: [7, 5, 2, 6, 1, 4, 2, 6, 3]
After : [1, 2, 2, 3, 4, 5, 6, 6, 7]


Alternatively, we can just call a library method.

Library: Wren-sort
import "./sort" for Sort

var array = [ [4, 65, 2, -31, 0, 99, 2, 83, 782, 1], [7, 5, 2, 6, 1, 4, 2, 6, 3] ]
for (a in array) {
    System.print("Before: %(a)")
    Sort.heap(a)
    System.print("After : %(a)")
    System.print()
}
Output:
As above.

XPL0

proc HeapSort(Array, Size);
int  Array, Size;
int  First, Last, T;

    proc Sift(First, Count);
    int  First, Count;
    int  Root, Child, T;
    [Root:= First;
    loop    [if Root*2 + 1 >= Count then quit;
            Child:= Root*2 + 1;
            if Child < Count-1 and Array(Child) < Array(Child+1) then
                Child:= Child+1;
            if Array(Root) < Array(Child) then
                [T:= Array(Root);  Array(Root):= Array(Child);  Array(Child):= T;
                Root:= Child;
                ]
            else quit;
            ];
    ];

[First:= (Size-1)/2 - 1;
Last:= Size-1;
while First >= 0 do
    [Sift(First, Size-1);
    First:= First-1;
    ];
while Last > 0 do
    [T:= Array(Last);  Array(Last):= Array(0);  Array(0):= T;
    Sift(0, Last);
    Last:= Last-1;
    ];
];

int Array, Size, I;
[Array:= [4, 65, 2, 31, 0, 99, 2, 8, 3, 782, 1];
Size:= 11;
HeapSort(Array, Size);
for I:= 0, Size-1 do
    [IntOut(0, Array(I));  ChOut(0, ^ )];
]
Output:
0 1 2 2 3 4 8 31 65 99 782 

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;
   }
}
heapSort(L(170, 45, 75, -90, -802, 24, 2, 66)).println();
heapSort("this is a test".split("")).println();
Output:
L(-802,-90,2,24,45,66,75,170)
L(" "," "," ","a","e","h","i","i","s","s","s","t","t","t")