Sorting algorithms/Heapsort: Difference between revisions
Walterpachl (talk | contribs) →{{header|REXX}}: add Rexx Version 2 |
Walterpachl (talk | contribs) m →{{header|PL/I}}: typo |
||
Line 1,972: | Line 1,972: | ||
swap: Proc(x,y); |
swap: Proc(x,y); |
||
Dcl (x, |
Dcl (x,y) Bin Fixed(31); |
||
Dcl temp Char(50) Var; |
Dcl temp Char(50) Var; |
||
temp=a(x); |
temp=a(x); |
||
Line 2,042: | Line 2,042: | ||
element 24 after sort xi |
element 24 after sort xi |
||
element 25 after sort zeta |
element 25 after sort zeta |
||
</pre> |
</pre> |
||
=={{header|PureBasic}}== |
=={{header|PureBasic}}== |
Revision as of 23:17, 27 July 2013
You are encouraged to solve this task according to the task description, using any language you may know.
Sorting Algorithm
This is a sorting algorithm. It may be applied to a set of data in order to sort it.
For comparing various sorts, see compare sorts.
For other sorting algorithms, see sorting algorithms, or:
Heap sort | Merge sort | Patience sort | Quick sort
O(n log2n) sorts
Shell Sort
O(n2) sorts
Bubble sort |
Cocktail sort |
Cocktail sort with shifting bounds |
Comb sort |
Cycle sort |
Gnome sort |
Insertion sort |
Selection sort |
Strand sort
other sorts
Bead sort |
Bogo sort |
Common sorted list |
Composite structures sort |
Custom comparator sort |
Counting sort |
Disjoint sublist sort |
External sort |
Jort sort |
Lexicographical sort |
Natural sorting |
Order by pair comparisons |
Order disjoint list items |
Order two numerical lists |
Object identifier (OID) sort |
Pancake sort |
Quickselect |
Permutation sort |
Radix sort |
Ranking methods |
Remove duplicate elements |
Sleep sort |
Stooge sort |
[Sort letters of a string] |
Three variable sort |
Topological sort |
Tree sort
This page uses content from Wikipedia. The original article was at Heapsort. The list of authors can be seen in the page history. As with Rosetta Code, the text of Wikipedia is available under the GNU FDL. (See links for details on variance) |
Heapsort is an in-place sorting algorithm with worst case and average complexity of O(n logn). The basic idea is to turn the array into a binary heap structure, which has the property that it allows efficient retrieval and removal of the maximal element. We repeatedly "remove" the maximal element from the heap, thus building the sorted list from back to front. Heapsort requires random access, so can only be used on an array-like data structure.
Pseudocode:
function heapSort(a, count) is input: an unordered array a of length count (first place a in max-heap order) heapify(a, count) end := count - 1 while end > 0 do (swap the root(maximum value) of the heap with the last element of the heap) swap(a[end], a[0]) (decrement the size of the heap so that the previous max value will stay in its proper place) end := end - 1 (put the heap back in max-heap order) siftDown(a, 0, end)
function heapify(a,count) is (start is assigned the index in a of the last parent node) start := (count - 2) / 2 while start ≥ 0 do (sift down the node at index start to the proper place such that all nodes below the start index are in heap order) siftDown(a, start, count-1) start := start - 1 (after sifting down the root all nodes/elements are in heap order) function siftDown(a, start, end) is (end represents the limit of how far down the heap to sift) root := start while root * 2 + 1 ≤ end do (While the root has at least one child) child := root * 2 + 1 (root*2+1 points to the left child) (If the child has a sibling and the child's value is less than its sibling's...) if child + 1 ≤ end and a[child] < a[child + 1] then child := child + 1 (... then point to the right child instead) if a[root] < a[child] then (out of max-heap order) swap(a[root], a[child]) root := child (repeat to continue sifting down the child now) else return
Write a function to sort a collection of integers using heapsort.
ActionScript
<lang ActionScript>function heapSort(data:Vector.<int>):Vector.<int> { for (var start:int = (data.length-2)/2; start >= 0; start--) { siftDown(data, start, data.length); } for (var end:int = data.length - 1; end > 0; end--) { var tmp:int=data[0]; data[0]=data[end]; data[end]=tmp; siftDown(data, 0, end); } return data; } function siftDown(data:Vector.<int>, start:int, end:int):void { var heapRoot:int=start; while (heapRoot * 2+1 < end) { var child:int=heapRoot*2+1; if (child+1<end&&data[child]<data[child+1]) { child++; } if (data[heapRoot]<data[child]) { var tmp:int=data[heapRoot]; data[heapRoot]=data[child]; data[child]=tmp; heapRoot=child; } else { return; } } }</lang>
Ada
This implementation is a generic heapsort for unconstrained arrays. <lang Ada>generic
type Element_Type is private; type Index_Type is (<>); type Collection is array(Index_Type range <>) of Element_Type; with function "<" (Left, right : element_type) return boolean is <>;
procedure Generic_Heapsort(Item : in out Collection);</lang> <lang Ada>procedure Generic_Heapsort(Item : in out Collection) is
procedure Swap(Left : in out Element_Type; Right : in out Element_Type) is Temp : Element_Type := Left; begin Left := Right; Right := Temp; end Swap; procedure Sift_Down(Item : in out Collection) is Root : Integer := Index_Type'Pos(Item'First); Child : Integer := Index_Type'Pos(Item'Last); Last : Integer := Index_Type'Pos(Item'Last); begin while Root * 2 + 1 <= Last loop Child := Root * 2 + 1; if Child + 1 <= Last and then Item(index_Type'Val(Child)) < Item(Index_Type'Val(Child + 1)) then Child := Child + 1; end if; if Item(Index_Type'Val(Root)) < Item(Index_Type'Val(Child)) then Swap(Item(Index_Type'Val(Root)), Item(Index_Type'Val(Child))); Root := Child; else exit; end if; end loop; end Sift_Down; procedure Heapify(Item : in out Collection) is First_Pos : Integer := Index_Type'Pos(Index_Type'First); Last_Pos : Integer := Index_Type'Pos(Index_type'Last); Start : Index_type := Index_Type'Val((Last_Pos - First_Pos + 1) / 2); begin loop Sift_Down(Item(Start..Item'Last)); if Start > Index_Type'First then Start := Index_Type'Pred(Start); else exit; end if; end loop; end Heapify; Last_Index : Index_Type := Index_Type'Last;
begin
Heapify(Item); while Last_Index > Index_Type'First loop Swap(Item(Last_Index), Item(Item'First)); Last_Index := Index_Type'Pred(Last_Index); Sift_Down(Item(Item'First..Last_Index)); end loop;
end Generic_Heapsort;</lang> Demo code: <lang Ada>with Generic_Heapsort; with Ada.Text_Io; use Ada.Text_Io;
procedure Test_Generic_Heapsort is
type Days is (Sun, Mon, Tue, Wed, Thu, Fri, Sat); type Days_Col is array(Days range <>) of Natural; procedure Sort is new Generic_Heapsort(Natural, Days, Days_Col); Week : Days_Col := (5, 2, 7, 3, 4, 9, 1);
begin
for I in Week'range loop Put(Days'Image(I) & ":" & Natural'Image(Week(I)) & " "); end loop; New_Line; Sort(Week); for I in Week'range loop Put(Days'Image(I) & ":" & Natural'Image(Week(I))& " "); end loop; New_Line;
end Test_Generic_Heapsort;</lang>
AutoHotkey
<lang AutoHotkey>heapSort(a) {
Local end end := %a%0 heapify(a,end) While end > 1 %a%%end% := (%a%1 "", %a%1 := %a%%end%) ,siftDown(a, 1, --end)
}
heapify(a, count) {
Local start start := count // 2 While start siftDown(a, start--, count)
}
siftDown(a, start, end) {
Local child, c1 While start*2 <= end { c1 := 1 + child := start*2 If (c1 <= end && %a%%child% < %a%%c1%) child := c1 If (%a%%start% < %a%%child%) %a%%start% := (%a%%child% "", %a%%child% := %a%%start%) ,start := child Else Return }
}
a = 1,5,2,7,3,4,6,8,1 ; ----- test ----- StringSplit a, a, `, heapSort("a") ListVars MsgBox</lang>
BBC BASIC
<lang bbcbasic> DIM test(9)
test() = 4, 65, 2, -31, 0, 99, 2, 83, 782, 1 PROCheapsort(test()) FOR i% = 0 TO 9 PRINT test(i%) ; NEXT PRINT END DEF PROCheapsort(a()) LOCAL e% PROCheapify(a()) FOR e% = DIM(a(),1) TO 1 STEP -1 SWAP a(e%), a(0) PROCsiftdown(a(), 0, e%-1) NEXT ENDPROC DEF PROCheapify(a()) LOCAL s%, m% m% = DIM(a(),1) FOR s% = (m% - 1) / 2 TO 0 STEP -1 PROCsiftdown(a(), s%, m%) NEXT ENDPROC DEF PROCsiftdown(a(), s%, e%) LOCAL c%, r% r% = s% WHILE r% * 2 + 1 <= e% c% = r% * 2 + 1 IF c% + 1 <= e% IF a(c%) < a(c% + 1) c% += 1 IF a(r%) < a(c%) SWAP a(r%), a(c%) : r% = c% ELSE ENDPROC ENDWHILE ENDPROC</lang>
Output:
-31 0 1 2 2 4 65 83 99 782
BCPL
<lang BCPL>// This can be run using Cintcode BCPL freely available from www.cl.cam.ac.uk/users/mr10.
GET "libhdr.h"
LET heapify(v, k, i, last) BE { LET j = i+i // If there is a son (or two), j = subscript of first.
AND x = k // x will hold the larger of the sons if any.
IF j<=last DO x := v!j // j, x = subscript and key of first son. IF j< last DO { LET y = v!(j+1) // y = key of the other son. IF x<y DO x,j := y, j+1 // j, x = subscript and key of larger son. }
IF k>=x DO { v!i := k // k is not lower than larger son if any. RETURN } v!i := x i := j
} REPEAT
AND heapsort(v, upb) BE { FOR i = upb/2 TO 1 BY -1 DO heapify(v, v!i, i, upb)
FOR i = upb TO 2 BY -1 DO { LET k = v!i v!i := v!1 heapify(v, k, 1, i-1) }
}
LET start() = VALOF {
LET v = VEC 1000 FOR i = 1 TO 1000 DO v!i := randno(1_000_000) heapsort(v, 1000) FOR i = 1 TO 1000 DO { IF i MOD 10 = 0 DO newline() writef(" %i6", v!i) } newline()
}</lang>
C
<lang c>#include <stdio.h>
- include <stdlib.h>
- define ValType double
- define IS_LESS(v1, v2) (v1 < v2)
void siftDown( ValType *a, int start, int count);
- define SWAP(r,s) do{ValType t=r; r=s; s=t; } while(0)
void heapsort( ValType *a, int count) {
int start, end;
/* heapify */ for (start = (count-2)/2; start >=0; start--) { siftDown( a, start, count); }
for (end=count-1; end > 0; end--) { SWAP(a[end],a[0]); siftDown(a, 0, end); }
}
void siftDown( ValType *a, int start, int end) {
int root = start;
while ( root*2+1 < end ) { int child = 2*root + 1; if ((child + 1 < end) && IS_LESS(a[child],a[child+1])) { child += 1; } if (IS_LESS(a[root], a[child])) { SWAP( a[child], a[root] ); root = child; } else return; }
}
int main()
{
int ix; double valsToSort[] = { 1.4, 50.2, 5.11, -1.55, 301.521, 0.3301, 40.17, -18.0, 88.1, 30.44, -37.2, 3012.0, 49.2};
- define VSIZE (sizeof(valsToSort)/sizeof(valsToSort[0]))
heapsort(valsToSort, VSIZE); printf("{"); for (ix=0; ix<VSIZE; ix++) printf(" %.3f ", valsToSort[ix]); printf("}\n"); return 0;
}</lang>
C++
The easiest way is to use the make_heap
and sort_heap
standard library functions.
<lang cpp>#include <iostream>
- include <algorithm> // for std::make_heap, std::sort_heap
template <typename Iterator> void heapsort(Iterator begin, Iterator end) {
std::make_heap(begin, end); std::sort_heap(begin, end);
}
int main() {
double valsToSort[] = { 1.4, 50.2, 5.11, -1.55, 301.521, 0.3301, 40.17, -18.0, 88.1, 30.44, -37.2, 3012.0, 49.2}; const int VSIZE = sizeof(valsToSort)/sizeof(*valsToSort);
heapsort(valsToSort, valsToSort+VSIZE); for (int ix=0; ix<VSIZE; ix++) std::cout << valsToSort[ix] << std::endl; return 0;
}</lang> If you want to be slightly more verbose <lang cpp>#include <iostream>
- include <algorithm> // for std::make_heap, std::pop_heap
template <typename Iterator> void heapsort(Iterator begin, Iterator end) {
std::make_heap(begin, end); while (begin != end) std::pop_heap(begin, end--);
}</lang>
C#
<lang csharp>using System; using System.Collections.Generic; using System.Text;
public class HeapSortClass {
public static void HeapSort<T>(T[] array) { HeapSort<T>(array, 0, array.Length, Comparer<T>.Default); }
public static void HeapSort<T>(T[] array, int offset, int length, IComparer<T> comparer) { HeapSort<T>(array, offset, length, comparer.Compare); }
public static void HeapSort<T>(T[] array, int offset, int length, Comparison<T> comparison) { // build binary heap from all items for (int i = 0; i < length; i++) { int index = i; T item = array[offset + i]; // use next item
// and move it on top, if greater than parent while (index > 0 && comparison(array[offset + (index - 1) / 2], item) < 0) { int top = (index - 1) / 2; array[offset + index] = array[offset + top]; index = top; } array[offset + index] = item; }
for (int i = length - 1; i > 0; i--) { // delete max and place it as last T last = array[offset + i]; array[offset + i] = array[offset];
int index = 0; // the last one positioned in the heap while (index * 2 + 1 < i) { int left = index * 2 + 1, right = left + 1;
if (right < i && comparison(array[offset + left], array[offset + right]) < 0) { if (comparison(last, array[offset + right]) > 0) break;
array[offset + index] = array[offset + right]; index = right; } else { if (comparison(last, array[offset + left]) > 0) break;
array[offset + index] = array[offset + left]; index = left; } } array[offset + index] = last; } }
static void Main() { // usage byte[] r = {5, 4, 1, 2}; HeapSort(r);
string[] s = { "-", "D", "a", "33" }; HeapSort(s, 0, s.Length, StringComparer.CurrentCultureIgnoreCase); }
}</lang>
Clojure
<lang lisp>(defn- swap [a i j]
(assoc a i (nth a j) j (nth a i)))
(defn- sift [a pred k l]
(loop [a a x k y (inc (* 2 k))] (if (< (inc (* 2 x)) l) (let [ch (if (and (< y (dec l)) (pred (nth a y) (nth a (inc y)))) (inc y) y)] (if (pred (nth a x) (nth a ch)) (recur (swap a x ch) ch (inc (* 2 ch))) a)) a)))
(defn- heapify[pred a len]
(reduce (fn [c term] (sift (swap c term 0) pred 0 term)) (reduce (fn [c i] (sift c pred i len)) (vec a) (range (dec (int (/ len 2))) -1 -1)) (range (dec len) 0 -1)))
(defn heap-sort
([a pred] (let [len (count a)] (heapify pred a len))) ([a] (heap-sort a <)))
</lang> Example usage: <lang lisp>user> (heapsort [1 2 4 6 2 3 6]) [1 2 2 3 4 6 6] user> (heapsort [1 2 4 6 2 3 6] >) [6 6 4 3 2 2 1] user> (heapsort (list 1 2 4 6 2 3 6)) [1 2 2 3 4 6 6]</lang>
CoffeeScript
<lang coffeescript># Do an in-place heap sort. heap_sort = (arr) ->
put_array_in_heap_order(arr) end = arr.length - 1 while end > 0 [arr[0], arr[end]] = [arr[end], arr[0]] sift_element_down_heap arr, 0, end end -= 1
put_array_in_heap_order = (arr) ->
i = arr.length / 2 - 1 i = Math.floor i while i >= 0 sift_element_down_heap arr, i, arr.length i -= 1
sift_element_down_heap = (heap, i, max) ->
while i < max i_big = i c1 = 2*i + 1 c2 = c1 + 1 if c1 < max and heap[c1] > heap[i_big] i_big = c1 if c2 < max and heap[c2] > heap[i_big] i_big = c2 return if i_big is i [heap[i], heap[i_big]] = [heap[i_big], heap[i]] i = i_big
do ->
arr = [12, 11, 15, 10, 9, 1, 2, 3, 13, 14, 4, 5, 6, 7, 8] heap_sort arr console.log arr</lang>
- Output:
> coffee heap.coffee [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 ]
Common Lisp
<lang lisp>(defun make-heap (&optional (length 7))
(make-array length :adjustable t :fill-pointer 0))
(defun left-index (index)
(1- (* 2 (1+ index))))
(defun right-index (index)
(* 2 (1+ index)))
(defun parent-index (index)
(floor (1- index) 2))
(defun percolate-up (heap index predicate)
(if (zerop index) heap (do* ((element (aref heap index)) (index index pindex) (pindex (parent-index index) (parent-index index))) ((zerop index) heap) (if (funcall predicate element (aref heap pindex)) (rotatef (aref heap index) (aref heap pindex)) (return-from percolate-up heap)))))
(defun heap-insert (heap element predicate)
(let ((index (vector-push-extend element heap 2))) (percolate-up heap index predicate)))
(defun percolate-down (heap index predicate)
(let ((length (length heap)) (element (aref heap index))) (flet ((maybe-element (index) "return the element at index or nil, and a boolean indicating whether there was an element." (if (< index length) (values (aref heap index) t) (values nil nil)))) (do ((index index swap-index) (lindex (left-index index) (left-index index)) (rindex (right-index index) (right-index index)) (swap-index nil) (swap-child nil)) (nil) ;; Extact the left child if there is one. If there is not, ;; return the heap. Set the left child as the swap-child. (multiple-value-bind (lchild lp) (maybe-element lindex) (if (not lp) (return-from percolate-down heap) (setf swap-child lchild swap-index lindex)) ;; Extract the right child, if any, and when better than the ;; current swap-child, update the swap-child. (multiple-value-bind (rchild rp) (maybe-element rindex) (when (and rp (funcall predicate rchild lchild)) (setf swap-child rchild swap-index rindex)) ;; If the swap-child is better than element, rotate them, ;; and continue percolating down, else return heap. (if (not (funcall predicate swap-child element)) (return-from percolate-down heap) (rotatef (aref heap index) (aref heap swap-index)))))))))
(defun heap-empty-p (heap)
(eql (length heap) 0))
(defun heap-delete-min (heap predicate)
(assert (not (heap-empty-p heap)) () "Can't pop from empty heap.") (prog1 (aref heap 0) (setf (aref heap 0) (vector-pop heap)) (unless (heap-empty-p heap) (percolate-down heap 0 predicate))))
(defun heapsort (sequence predicate)
(let ((h (make-heap (length sequence)))) (map nil #'(lambda (e) (heap-insert h e predicate)) sequence) (map-into sequence #'(lambda () (heap-delete-min h predicate)))))</lang>
Example usage:
(heapsort (vector 1 9 2 8 3 7 4 6 5) '<) ; #(1 2 3 4 5 6 7 8 9) (heapsort (list 9 8 1 2 7 6 3 4 5) '<) ; (1 2 3 4 5 6 7 8 9)
D
<lang d>import std.stdio, std.container;
void heapSort(T)(T[] data) /*pure nothrow*/ {
for (auto h = data.heapify; !h.empty; h.removeFront) {}
}
void main() {
auto items = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]; items.heapSort; items.writeln;
}</lang>
A lower level implementation: <lang d>import std.stdio, std.algorithm;
void inplaceHeapSort(R)(R seq) pure nothrow {
static void siftDown(R seq, in size_t start, in size_t end) pure nothrow { 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 (start; 1 .. (seq.length - 2) / 2 + 2) siftDown(seq, start - 1, seq.length - 1);
foreach_reverse (end; 1 .. seq.length) { swap(seq[end], seq[0]); siftDown(seq, 0, end - 1); }
}
void main() {
auto arr = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0]; inplaceHeapSort(arr); writeln(arr);
}</lang>
Dart
<lang dart> void heapSort(List a) {
int count = a.length; // first place 'a' in max-heap order heapify(a, count); int end = count - 1; while (end > 0) { // swap the root (maximum value) of the heap with the // last element of the heap int tmp = a[end]; a[end] = a[0]; a[0] = tmp; // put the heap back in max-heap order siftDown(a, 0, end - 1); // decrement the size of the heap so that the previous // max value will stay in its proper place end--; }
}
void heapify(List a, int count) {
// start is assigned the index in 'a' of the last parent node int start = ((count - 2)/2).toInt(); // binary heap while (start >= 0) { // sift down the node at index 'start' to the proper place // such that all nodes below the 'start' index are in heap // order siftDown(a, start, count - 1); start--; }
}
void siftDown(List a, int start, int end) {
// end represents the limit of how far down the heap to shift int root = start; while ((root*2 + 1) <= end) { // While the root has at least one child int child = root*2 + 1; // root*2+1 points to the left child // if the child has a sibling and the child's value is less than its sibling's... if (child + 1 <= end && a[child] < a[child + 1]) { child = child+1; // .. then point to the right child instead } if (a[root] < a[child]) { // out of max-heap order int tmp = a[root]; a[root] = a[child]; a[child] = tmp; root = child; // repeat to continue shifting down the child now } else { return; } }
}
void main() {
var arr=[1,5,2,7,3,9,4,6,8]; print("Before sort"); arr.forEach((var i)=>print("$i")); heapSort(arr); print("After sort"); arr.forEach((var i)=>print("$i"));
}
</lang>
E
<lang e>def heapsort := {
def cswap(c, a, b) { def t := c[a] c[a] := c[b] c[b] := t # println(c) }
def siftDown(array, start, finish) { var root := start while (var child := root * 2 + 1 child <= finish) { if (child + 1 <= finish && array[child] < array[child + 1]) { child += 1 } if (array[root] < array[child]) { cswap(array, root, child) root := child } else { break } } }
/** Heapsort (in-place). */ def heapsort(array) { # in pseudo-code, heapify only called once, so inline it here for start in (0..((array.size()-2)//2)).descending() { siftDown(array, start, array.size()-1) } for finish in (0..(array.size()-1)).descending() { cswap(array, 0, finish) siftDown(array, 0, finish - 1) } }
}</lang>
F#
<lang fsharp>let inline swap (a: _ []) i j =
let temp = a.[i] a.[i] <- a.[j] a.[j] <- temp
let inline sift cmp (a: _ []) start count =
let rec loop root child = if root * 2 + 1 < count then let p = child < count - 1 && cmp a.[child] a.[child + 1] < 0 let child = if p then child + 1 else child if cmp a.[root] a.[child] < 0 then swap a root child loop child (child * 2 + 1) loop start (start * 2 + 1)
let inline heapsort cmp (a: _ []) =
let n = a.Length for start = n/2 - 1 downto 0 do sift cmp a start n for term = n - 1 downto 1 do swap a term 0 sift cmp a 0 term</lang>
Forth
This program assumes that return addresses simply reside as a single cell on the Return Stack. Most Forth compilers fulfill this requirement. <lang forth>create example
70 , 61 , 63 , 37 , 63 , 25 , 46 , 92 , 38 , 87 ,
[UNDEFINED] r'@ [IF]
- r'@ r> r> r@ swap >r swap >r ;
[THEN]
defer precedes ( n1 n2 a -- f) defer exchange ( n1 n2 a --)
- siftDown ( a e s -- a e s)
swap >r swap >r dup ( s r) begin ( s r) dup 2* 1+ dup r'@ < ( s r c f) while ( s r c) dup 1+ dup r'@ < ( s r c c+1 f) if ( s r c c+1) over over r@ precedes if swap then then drop ( s r c) over over r@ precedes ( s r c f) while ( s r c) tuck r@ exchange ( s r) repeat then ( s r) drop drop r> swap r> swap ( a e s)
- heapsort ( a n --)
over >r ( a n) dup 1- 1- 2/ ( a c s) begin ( a c s) dup 0< 0= ( a c s f) while ( a c s) siftDown 1- ( a c s) repeat drop ( a c)
1- 0 ( a e 0) begin ( a e 0) over 0> ( a e 0 f) while ( a e 0) over over r@ exchange ( a e 0) siftDown swap 1- swap ( a e 0) repeat ( a e 0) drop drop drop r> drop
- noname >r cells r@ + @ swap cells r> + @ swap < ; is precedes
- noname >r cells r@ + swap cells r> + over @ over @ swap rot ! swap ! ; is exchange
- .array 10 0 do example i cells + ? loop cr ;
.array example 10 heapsort .array </lang>
Fortran
Translation of the pseudocode <lang fortran>program Heapsort_Demo
implicit none integer, parameter :: num = 20 real :: array(num) call random_seed call random_number(array) write(*,*) "Unsorted array:-" write(*,*) array write(*,*) call heapsort(array) write(*,*) "Sorted array:-" write(*,*) array
contains
subroutine heapsort(a)
real, intent(in out) :: a(0:) integer :: start, n, bottom real :: temp
n = size(a) do start = (n - 2) / 2, 0, -1 call siftdown(a, start, n); end do do bottom = n - 1, 1, -1 temp = a(0) a(0) = a(bottom) a(bottom) = temp; call siftdown(a, 0, bottom) end do
end subroutine heapsort
subroutine siftdown(a, start, bottom)
real, intent(in out) :: a(0:) integer, intent(in) :: start, bottom integer :: child, root real :: temp
root = start do while(root*2 + 1 < bottom) child = root * 2 + 1 if (child + 1 < bottom) then if (a(child) < a(child+1)) child = child + 1 end if if (a(root) < a(child)) then temp = a(child) a(child) = a (root) a(root) = temp root = child else return end if end do
end subroutine siftdown
end program Heapsort_Demo</lang>
Go
Here's an ingenious solution that makes use of the heap module. Although the heap module usually implements an independent heap with push/pop operations, we use a helper type where the "pop" operation does not actually change the size of the underlying container, but changes a "heap length" variable indicating the length of the prefix of the underlying container that is considered "the heap".
Since we want to implement a generic algorithm, we accept an argument of type sort.Interface
, and thus do not have access to the actual elements of the container we're sorting. We can only swap elements. This causes a problem for us when implementing the Pop
method, as we can't actually return an element. The ingenious step is realizing that heap.Pop()
must move the value to pop to the "end" of the heap area, because its interface only has access to a "Swap" function, and a "Pop" function that pops from the end. (It does not have the ability to pop a value at the beginning.) This is perfect because we precisely want to move the thing popped to the end and shrink the "heap area" by 1. Our "Pop" function returns nothing since we can't get the value, but don't actually need it. (We only need the swapping that it does for us.)
<lang go>package main
import (
"sort" "container/heap" "fmt"
)
type HeapHelper struct {
container sort.Interface length int
}
func (self HeapHelper) Len() int { return self.length } // We want a max-heap, hence reverse the comparison func (self HeapHelper) Less(i, j int) bool { return self.container.Less(j, i) } func (self HeapHelper) Swap(i, j int) { self.container.Swap(i, j) } // this should not be called func (self *HeapHelper) Push(x interface{}) { panic("impossible") } func (self *HeapHelper) Pop() interface{} {
self.length-- return nil // return value not used
}
func heapSort(a sort.Interface) {
helper := HeapHelper{ a, a.Len() } heap.Init(&helper) for helper.length > 0 { heap.Pop(&helper) }
}
func main() {
a := []int{170, 45, 75, -90, -802, 24, 2, 66} fmt.Println("before:", a) heapSort(sort.IntSlice(a)) fmt.Println("after: ", a)
}</lang>
- Output:
before: [170 45 75 -90 -802 24 2 66] after: [-802 -90 2 24 45 66 75 170]
If you want to implement it manually: <lang go>package main
import (
"sort" "fmt"
)
func main() {
a := []int{170, 45, 75, -90, -802, 24, 2, 66} fmt.Println("before:", a) heapSort(sort.IntSlice(a)) fmt.Println("after: ", a)
}
func heapSort(a sort.Interface) {
for start := (a.Len() - 2) / 2; start >= 0; start-- { siftDown(a, start, a.Len()-1) } for end := a.Len() - 1; end > 0; end-- { a.Swap(0, end) siftDown(a, 0, end-1) }
}
func siftDown(a sort.Interface, start, end int) {
for root := start; root*2+1 <= end; { child := root*2 + 1 if child+1 <= end && a.Less(child, child+1) { child++ } if !a.Less(root, child) { return } a.Swap(root, child) root = child }
}</lang>
Groovy
Loose translation of the pseudocode: <lang groovy>def makeSwap = { a, i, j = i+1 -> print "."; aj,i = ai,j }
def checkSwap = { list, i, j = i+1 -> [(list[i] > list[j])].find{ it }.each { makeSwap(list, i, j) } }
def siftDown = { a, start, end ->
def p = start while (p*2 < end) { def c = p*2 + ((p*2 + 1 < end && a[p*2 + 2] > a[p*2 + 1]) ? 2 : 1) if (checkSwap(a, c, p)) { p = c } else { return } }
}
def heapify = {
(((it.size()-2).intdiv(2))..0).each { start -> siftDown(it, start, it.size()-1) }
}
def heapSort = { list ->
heapify(list) (0..<(list.size())).reverse().each { end -> makeSwap(list, 0, end) siftDown(list, 0, end-1) } list
}</lang> Test: <lang groovy>println (heapSort([23,76,99,58,97,57,35,89,51,38,95,92,24,46,31,24,14,12,57,78,4])) println (heapSort([88,18,31,44,4,0,8,81,14,78,20,76,84,33,73,75,82,5,62,70,12,7,1]))</lang>
- Output:
.......................................................................[4, 12, 14, 23, 24, 24, 31, 35, 38, 46, 51, 57, 57, 58, 76, 78, 89, 92, 95, 97, 99] ..........................................................................................[0, 1, 4, 5, 7, 8, 12, 14, 18, 20, 31, 33, 44, 62, 70, 73, 75, 76, 78, 81, 82, 84, 88]
Haskell
Using package fgl from HackageDB <lang haskell>import Data.Graph.Inductive.Internal.Heap(
Heap(..),insert,findMin,deleteMin)
-- heapsort is added in this module as an example application
build :: Ord a => [(a,b)] -> Heap a b build = foldr insert Empty
toList :: Ord a => Heap a b -> [(a,b)] toList Empty = [] toList h = x:toList r
where (x,r) = (findMin h,deleteMin h)
heapsort :: Ord a => [a] -> [a] heapsort = (map fst) . toList . build . map (\x->(x,x))</lang> e.g. <lang haskell>*Main> heapsort [[6,9],[2,13],[6,8,14,9],[10,7],[5]] [[2,13],[5],[6,8,14,9],[6,9],[10,7]]</lang>
Icon and Unicon
<lang Icon>procedure main() #: demonstrate various ways to sort a list and string
demosort(heapsort,[3, 14, 1, 5, 9, 2, 6, 3],"qwerty")
end
procedure heapsort(X,op) #: return sorted list ascending(or descending) local head,tail
op := sortop(op,X) # select how and what we sort
every head := (tail := *X) / 2 to 1 by -1 do # work back from from last parent node X := siftdown(X,op,head,tail) # sift down from head to make the heap
every tail := *X to 2 by -1 do { # work between the beginning and the tail to final positions X[1] :=: X[tail] X := siftdown(X,op,1,tail-1) # re-sift next (previous) branch after shortening the heap }
return X
end
procedure siftdown(X,op,root,tail) #: the value @root is moved "down" the path of max(min) value to its level local child
while (child := root * 2) <= tail do { # move down the branch from root to tail
if op(X[child],X[tail >= child + 1]) then # choose the larger(smaller) child +:= 1 # ... child
if op(X[root],X[child]) then { # root out of order? X[child] :=: X[root] root := child # follow max(min) branch } else return X } return X
end</lang> Algorithm notes:
- This is a fairly straight forward implementation of the pseudo-code with 'heapify' coded in-line.
Implementation notes:
- Since this transparently sorts both string and list arguments the result must 'return' to bypass call by value (strings)
- Beware missing trailing 'returns' when translating pseudo-code. For amusement try comment out the return at the end of 'shiftdown'
Note: This example relies on the supporting procedures 'sortop', and 'demosort' in Bubble Sort. The full demosort exercises the named sort of a list with op = "numeric", "string", ">>" (lexically gt, descending),">" (numerically gt, descending), a custom comparator, and also a string.
- Abbreviated sample output:
Sorting Demo using procedure heapsort on list : [ 3 14 1 5 9 2 6 3 ] with op = &null: [ 1 2 3 3 5 6 9 14 ] (0 ms) ... on string : "qwerty" with op = &null: "eqrtwy" (0 ms)
J
Translation of the pseudocode <lang j>swap=: C.~ <
siftDown=: 4 : 0
'c e'=. x while. e > c=.1+2*s=.c do. before=. <&({&y) if. e > 1+c do. c=.c+ c before c+1 end. if. s before c do. y=. y swap c,s else. break. end. end. y
)
heapSort=: 3 : 0
if. 1>: c=. # y do. y return. end. z=. siftDown&.>/ (c,~each i.<.c%2),<y NB. heapify > ([ siftDown swap~)&.>/ (0,each}.i.c),z
)</lang> Examples <lang j> heapSort 1 5 2 7 3 9 4 6 8 1 1 1 2 3 4 5 6 7 8 9
heapSort &. (a.&i.) 'aqwcdhkij'
acdhijkqw</lang>
Java
Direct translation of the pseudocode. <lang java>public static void heapSort(int[] a){ int count = a.length;
//first place a in max-heap order heapify(a, count);
int end = count - 1; while(end > 0){ //swap the root(maximum value) of the heap with the //last element of the heap int tmp = a[end]; a[end] = a[0]; a[0] = tmp; //put the heap back in max-heap order siftDown(a, 0, end - 1); //decrement the size of the heap so that the previous //max value will stay in its proper place end--; } }
public static void heapify(int[] a, int count){ //start is assigned the index in a of the last parent node int start = (count - 2) / 2; //binary heap
while(start >= 0){ //sift down the node at index start to the proper place //such that all nodes below the start index are in heap //order siftDown(a, start, count - 1); start--; } //after sifting down the root all nodes/elements are in heap order }
public static void siftDown(int[] a, int start, int end){ //end represents the limit of how far down the heap to sift int root = start;
while((root * 2 + 1) <= end){ //While the root has at least one child int child = root * 2 + 1; //root*2+1 points to the left child //if the child has a sibling and the child's value is less than its sibling's... if(child + 1 <= end && a[child] < a[child + 1]) child = child + 1; //... then point to the right child instead if(a[root] < a[child]){ //out of max-heap order int tmp = a[root]; a[root] = a[child]; a[child] = tmp; root = child; //repeat to continue sifting down the child now }else return; } }</lang>
Liberty BASIC
<lang lb>wikiSample=1 'comment out for random array
data 6, 5, 3, 1, 8, 7, 2, 4
itemCount = 20
if wikiSample then itemCount = 8
dim A(itemCount) for i = 1 to itemCount A(i) = int(rnd(1) * 100) if wikiSample then read tmp: A(i)=tmp next i
print "Before Sort" call printArray itemCount
call heapSort itemCount
print "After Sort" call printArray itemCount
end
'------------------------------------------ sub heapSort count
call heapify count
print "the heap" call printArray count
theEnd = count while theEnd > 1 call swap theEnd, 1 call siftDown 1, theEnd-1 theEnd = theEnd - 1 wend
end sub
sub heapify count
start = int(count / 2) while start >= 1 call siftDown start, count start = start - 1 wend
end sub
sub siftDown start, theEnd
root = start while root * 2 <= theEnd child = root * 2 swap = root if A(swap) < A(child) then swap = child end if if child+1 <= theEnd then if A(swap) < A(child+1) then swap = child + 1 end if end if if swap <> root then call swap root, swap root = swap else exit sub end if wend
end sub
sub swap a,b
tmp = A(a) A(a) = A(b) A(b) = tmp
end sub
'=========================================== sub printArray itemCount
for i = 1 to itemCount print using("###", A(i)); next i print
end sub</lang>
LotusScript
<lang LotusScript> Public Sub heapsort(pavIn As Variant)
Dim liCount As Integer, liEnd As Integer Dim lvTemp As Variant liCount = UBound(pavIn) + 1
heapify pavIn, liCount
liEnd = liCount - 1 While liEnd > 0 lvTemp = pavIn(liEnd) pavIn(liEnd) = pavIn(0) pavIn(0) = lvTemp liEnd = liEnd -1 siftDown pavIn,0, liEnd Wend
End Sub
Private Sub heapify(pavIn As Variant,piCount As Integer)
Dim liStart As Integer liStart = (piCount - 2) / 2 While liStart >=0 siftDown pavIn, liStart, piCount -1 liStart = liStart - 1 Wend
End Sub
Private Sub siftDown(pavIn As Variant, piStart As Integer, piEnd As Integer)
Dim liRoot As Integer, liChild As Integer Dim lvTemp As Variant liRoot = piStart While liRoot *2 + 1 <= piEnd liChild = liRoot *2 + 1 If liChild +1 <= piEnd And pavIn(liChild) < pavIn(liChild + 1) Then liChild = liChild + 1 End If If pavIn(liRoot) < pavIn(liChild) Then lvTemp = pavIn(liRoot) pavIn(liRoot) = pavIn(liChild) pavIn(liChild) = lvTemp liRoot = liChild Else Exit sub End if wend
End Sub
</lang>
M4
<lang M4>divert(-1)
define(`randSeed',141592653) define(`setRand',
`define(`randSeed',ifelse(eval($1<10000),1,`eval(20000-$1)',`$1'))')
define(`rand_t',`eval(randSeed^(randSeed>>13))') define(`random',
`define(`randSeed',eval((rand_t^(rand_t<<18))&0x7fffffff))randSeed')
define(`set',`define(`$1[$2]',`$3')') define(`get',`defn(`$1[$2]')') define(`new',`set($1,size,0)') dnl for the heap calculations, it's easier if origin is 0, so set value first define(`append',
`set($1,get($1,size),$2)`'set($1,size,incr(get($1,size)))')
dnl swap(<name>,<j>,<name>[<j>],<k>) using arg stack for the temporary define(`swap',`set($1,$2,get($1,$4))`'set($1,$4,$3)')
define(`deck',
`new($1)for(`x',1,$2, `append(`$1',eval(random%100))')')
define(`show',
`for(`x',0,decr(get($1,size)),`get($1,x) ')')
define(`for',
`ifelse($#,0,``$0, `ifelse(eval($2<=$3),1, `pushdef(`$1',$2)$4`'popdef(`$1')$0(`$1',incr($2),$3,`$4')')')')
define(`ifywork',
`ifelse(eval($2>=0),1, `siftdown($1,$2,$3)`'ifywork($1,decr($2),$3)')')
define(`heapify',
`define(`start',eval((get($1,size)-2)/2))`'ifywork($1,start, decr(get($1,size)))')
define(`siftdown',
`define(`child',eval($2*2+1))`'ifelse(eval(child<=$3),1, `ifelse(eval(child+1<=$3),1, `ifelse(eval(get($1,child)<get($1,incr(child))),1, `define(`child', incr(child))')')`'ifelse(eval(get($1,$2)<get($1,child)),1, `swap($1,$2,get($1,$2),child)`'siftdown($1,child,$3)')')')
define(`sortwork',
`ifelse($2,0, `', `swap($1,0,get($1,0),$2)`'siftdown($1,0,decr($2))`'sortwork($1, decr($2))')')
define(`heapsort',
`heapify($1)`'sortwork($1,decr(get($1,size)))')
divert deck(`a',10) show(`a') heapsort(`a') show(`a')</lang>
Mathematica
<lang Mathematica>siftDown[list_,root_,theEnd_]:=
While[(root*2) <= theEnd, child = root*2; If[(child+1 <= theEnd)&&(listchild < listchild+1), child++;]; If[listroot < listchild, list[[{root,child}]] = list[[{child,root}]]; root = child;, Break[]; ] ]
heapSort[list_] := Module[{ count, start},
count = Length[list]; start = Floor[count/2]; While[start >= 1,list = siftDown[list,start,count]; start--; ] While[count > 1, list[[{count,1}]] = list[[{1,count}]]; count--; list = siftDown[list,1,count]; ]
]</lang>
- Output:
heapSort@{2,3,1,5,7,6} {1,2,3,5,6,7}
MATLAB / Octave
This function definition is an almost exact translation of the pseudo-code into MATLAB, but I have chosen to make the heapify function inline because it is only called once in the pseudo-code. Also, MATLAB uses 1 based array indecies, therefore all of the pseudo-code has been translated to reflect that difference. <lang MATLAB>function list = heapSort(list)
function list = siftDown(list,root,theEnd) while (root * 2) <= theEnd child = root * 2; if (child + 1 <= theEnd) && (list(child) < list(child+1)) child = child + 1; end if list(root) < list(child) list([root child]) = list([child root]); %Swap root = child; else return end end %while end %siftDown count = numel(list); %Because heapify is called once in pseudo-code, it is inline here start = floor(count/2); while start >= 1 list = siftDown(list, start, count); start = start - 1; end %End Heapify while count > 1 list([count 1]) = list([1 count]); %Swap count = count - 1; list = siftDown(list,1,count); end
end</lang> Sample Usage: <lang MATLAB>>> heapSort([4 3 1 5 6 2])
ans =
1 2 3 4 5 6</lang>
NetRexx
<lang NetRexx>/* NetRexx */ options replace format comments java crossref savelog symbols binary
import java.util.List
placesList = [String -
"UK London", "US New York", "US Boston", "US Washington" - , "UK Washington", "US Birmingham", "UK Birmingham", "UK Boston" -
]
lists = [ -
placesList - , heapSort(String[] Arrays.copyOf(placesList, placesList.length)) -
]
loop ln = 0 to lists.length - 1
cl = lists[ln] loop ct = 0 to cl.length - 1 say cl[ct] end ct say end ln
return
method heapSort(a = String[], count = a.length) public constant binary returns String[]
rl = String[a.length] al = List heapSort(Arrays.asList(a), count) al.toArray(rl)
return rl
method heapSort(a = List, count = a.size) public constant binary returns ArrayList
a = heapify(a, count)
iend = count - 1 loop label iend while iend > 0 swap = a.get(0) a.set(0, a.get(iend)) a.set(iend, swap) a = siftDown(a, 0, iend - 1) iend = iend - 1 end iend
return ArrayList(a)
method heapify(a = List, count = int) public constant binary returns List
start = (count - 2) % 2
loop label strt while start >= 0 a = siftDown(a, start, count - 1) start = start - 1 end strt
return a
method siftDown(a = List, istart = int, iend = int) public constant binary returns List
root = istart
loop label root while root * 2 + 1 <= iend child = root * 2 + 1 if child + 1 <= iend then do if (Comparable a.get(child)).compareTo(Comparable a.get(child + 1)) < 0 then do child = child + 1 end end if (Comparable a.get(root)).compareTo(Comparable a.get(child)) < 0 then do swap = a.get(root) a.set(root, a.get(child)) a.set(child, swap) root = child end else do leave root end end root
return a</lang>
- Output:
UK London US New York US Boston US Washington UK Washington US Birmingham UK Birmingham UK Boston UK Birmingham UK Boston UK London UK Washington US Birmingham US Boston US New York US Washington
Objeck
<lang objeck>bundle Default {
class HeapSort { function : Main(args : String[]) ~ Nil { values := [4, 3, 1, 5, 6, 2]; HeapSort(values); each(i : values) { values[i]->PrintLine(); }; } function : HeapSort(a : Int[]) ~ Nil { count := a->Size(); Heapify(a, count); end := count - 1; while(end > 0) { tmp := a[end]; a[end] := a[0]; a[0] := tmp; SiftDown(a, 0, end - 1); end -= 1; }; }
function : Heapify(a : Int[], count : Int) ~ Nil { start := (count - 2) / 2; while(start >= 0) { SiftDown(a, start, count - 1); start -= 1; }; }
function : SiftDown(a : Int[], start : Int, end : Int) ~ Nil { root := start; while((root * 2 + 1) <= end) { child := root * 2 + 1; if(child + 1 <= end & a[child] < a[child + 1]) { child := child + 1; }; if(a[root] < a[child]) { tmp := a[root]; a[root] := a[child]; a[child] := tmp; root := child; } else { return; }; }; } }
}</lang>
OCaml
<lang ocaml>let heapsort a =
let swap i j = let t = a.(i) in a.(i) <- a.(j); a.(j) <- t in
let sift k l = let rec check x y = if 2*x+1 < l then let ch = if y < l-1 && a.(y) < a.(y+1) then y+1 else y in if a.(x) < a.(ch) then (swap x ch; check ch (2*ch+1)) in check k (2*k+1) in
let len = Array.length a in
for start = (len/2)-1 downto 0 do sift start len; done;
for term = len-1 downto 1 do swap term 0; sift 0 term; done;;</lang>
Usage: <lang ocaml>let a = [|3;1;4;1;5;9;2;6;5;3;5;8;97;93;23;84;62;64;33;83;27;95|] in
heapsort a; Array.iter (Printf.printf "%d ") a;;
print_newline ();;
let s = "Just to show this is a type-checked polymorphic function" in let b = Array.init (String.length s) (String.get s) in
heapsort b; Array.iter print_char b;;
print_newline ();;</lang>
- Output:
1 1 2 3 3 4 5 5 5 6 8 9 23 27 33 62 64 83 84 93 95 97 -Jaccccdeeefhhhhiiiiklmnnoooooppprsssstttttuuwyy
Oz
A faithful translation of the pseudocode, adjusted to the fact that Oz arrays can start with an arbitrary index, not just 0 or 1. <lang oz>declare
proc {HeapSort A} Low = {Array.low A} High = {Array.high A} Count = High-Low+1 %% heapify LastParent = Low + (Count-2) div 2 in for Start in LastParent..Low;~1 do {Siftdown A Start High} end %% repeatedly put the maximum element to the end %% and re-heapify the rest for End in High..Low+1;~1 do {Swap A End Low} {Siftdown A Low End-1} end end proc {Siftdown A Start End} Low = {Array.low A} fun {FirstChildOf I} Low+(I-Low)*2+1 end Root = {NewCell Start} in for while:{FirstChildOf @Root} =< End break:Break do Child = {NewCell {FirstChildOf @Root}} in if @Child + 1 =< End andthen A.@Child < A.(@Child + 1) then Child := @Child + 1 end if A.@Root < A.@Child then {Swap A @Root @Child} Root := @Child else {Break} end end end proc {Swap A I J} A.J := (A.I := A.J) end %% create array with indices ~1..7 and fill it Arr = {Array.new ~1 7 0} {Record.forAllInd unit(~1:3 0:1 4 1 5 9 2 6 5) proc {$ I V} Arr.I := V end}
in
{HeapSort Arr} {Show {Array.toRecord unit Arr}}</lang>
Pascal
An example, which works on arrays with arbitrary bounds :-) <lang pascal>program HeapSortDemo;
type
TIntArray = array[4..15] of integer;
var
data: TIntArray; i: integer;
procedure siftDown(var a: TIntArray; start, ende: integer);
var root, child, swap: integer; begin root := start; while root * 2 - start + 1 <= ende do begin child := root * 2 - start + 1; if (child + 1 <= ende) and (a[child] < a[child + 1]) then inc(child); if a[root] < a[child] then begin
swap := a[root];
a[root] := a[child]; a[child] := swap; root := child; end else exit; end; end;
procedure heapify(var a: TIntArray);
var start, count: integer; begin count := length(a); start := low(a) + count div 2 - 1; while start >= low(a) do begin siftdown(a, start, high(a)); dec(start); end; end;
procedure heapSort(var a: TIntArray);
var ende, swap: integer; begin heapify(a); ende := high(a); while ende > low(a) do begin swap := a[low(a)]; a[low(a)] := a[ende]; a[ende] := swap; dec(ende); siftdown(a, low(a), ende); end; end;
begin
Randomize; writeln('The data before sorting:'); for i := low(data) to high(data) do begin data[i] := Random(high(data)); write(data[i]:4); end; writeln; heapSort(data); writeln('The data after sorting:'); for i := low(data) to high(data) do begin write(data[i]:4); end; writeln;
end.</lang>
- Output:
The data before sorting: 12 13 0 1 0 14 13 10 1 10 9 2 The data after sorting: 0 0 1 1 2 9 10 10 12 13 13 14
Perl
Translation of the pseudocode. <lang perl>my @my_list = (2,3,6,23,13,5,7,3,4,5); heap_sort(\@my_list); print "@my_list\n"; exit;
sub heap_sort {
my($list) = @_; my $count = scalar @$list; heapify($count,$list);
my $end = $count - 1; while($end > 0) { @$list[0,$end] = @$list[$end,0]; sift_down(0,$end-1,$list); $end--; }
} sub heapify {
my ($count,$list) = @_; my $start = ($count - 2) / 2; while($start >= 0) { sift_down($start,$count-1,$list); $start--; }
} sub sift_down {
my($start,$end,$list) = @_;
my $root = $start; while($root * 2 + 1 <= $end) { my $child = $root * 2 + 1; $child++ if($child + 1 <= $end && $list->[$child] < $list->[$child+1]); if($list->[$root] < $list->[$child]) { @$list[$root,$child] = @$list[$child,$root]; $root = $child; }else{ return } }
}</lang>
Perl 6
<lang perl6>sub heap_sort ( @list is rw ) {
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 is rw ) {
my $root = $start; while ( my $child = $root * 2 + 1 ) <= $end { $child++ if $child + 1 <= $end and [<] @list[ $child, $child+1 ]; return if @list[$root] >= @list[$child]; @list[ $root, $child ] .= reverse; $root = $child; }
}
my @data = 6, 7, 2, 1, 8, 9, 5, 3, 4; say 'Input = ' ~ @data; @data.&heap_sort; say 'Output = ' ~ @data;</lang>
- Output:
Input = 6 7 2 1 8 9 5 3 4 Output = 1 2 3 4 5 6 7 8 9
PicoLisp
<lang PicoLisp>(de heapSort (A Cnt)
(let Cnt (length A) (for (Start (/ Cnt 2) (gt0 Start) (dec Start)) (siftDown A Start (inc Cnt)) ) (for (End Cnt (> End 1) (dec End)) (xchg (nth A End) A) (siftDown A 1 End) ) ) A )
(de siftDown (A Start End)
(use Child (for (Root Start (> End (setq Child (* 2 Root)))) (and (> End (inc Child)) (> (get A (inc Child)) (get A Child)) (inc 'Child) ) (NIL (> (get A Child) (get A Root))) (xchg (nth A Root) (nth A Child)) (setq Root Child) ) ) )</lang>
- Output:
: (heapSort (make (do 9 (link (rand 1 999))))) -> (1 167 183 282 524 556 638 891 902)
PL/I
<lang pli>*process source xref attributes or(!);
/********************************************************************* * Pseudocode found here: * http://en.wikipedia.org/wiki/Heapsort#Pseudocode * Sample data from REXX * 27.07.2013 Walter Pachl *********************************************************************/ heaps: Proc Options(main); Dcl a(0:25) Char(50) Var Init( '---letters of the modern Greek Alphabet---', '==========================================', 'alpha','beta','gamma','delta','epsilon','zeta','eta','theta', 'iota','kappa','lambda','mu','nu','xi','omicron','pi', 'rho','sigma','tau','upsilon','phi','chi','psi','omega'); Dcl n Bin Fixed(31) Init((hbound(a)+1));
Call showa('before sort'); Call heapsort((n)); Call showa(' after sort');
heapSort: Proc(count); Dcl (count,end) Bin Fixed(31); Call heapify((count)); end=count-1; do while(end>0); Call swap(end,0); end=end-1; Call siftDown(0,(end)); End; End;
heapify: Proc(count); Dcl (count,start) Bin Fixed(31); start=(count-2)/2; Do while (start>=0); Call siftDown((start),count-1); start=start-1; End; End;
siftDown: Proc(start,end); Dcl (count,start,root,end,child,sw) Bin Fixed(31); root=start; Do while(root*2+1<= end); child=root*2+1; sw=root; if a(sw)<a(child) Then sw=child; if child+1<=end & a(sw)<a(child+1) Then sw=child+1; if sw^=root Then Do; Call swap(root,sw); root=sw; End; else return; End; End;
swap: Proc(x,y); Dcl (x,y) Bin Fixed(31); Dcl temp Char(50) Var; temp=a(x); a(x)=a(y); a(y)=temp; End;
showa: Proc(txt); Dcl txt Char(*); Dcl j Bin Fixed(31); Do j=0 To hbound(a); Put Edit('element',j,txt,a(j))(skip,a,f(3),x(1),a,x(1),a); End; End;
End;</lang>
Output:
element 0 before sort ---letters of the modern Greek Alphabet--- element 1 before sort ========================================== element 2 before sort alpha element 3 before sort beta element 4 before sort gamma element 5 before sort delta element 6 before sort epsilon element 7 before sort zeta element 8 before sort eta element 9 before sort theta element 10 before sort iota element 11 before sort kappa element 12 before sort lambda element 13 before sort mu element 14 before sort nu element 15 before sort xi element 16 before sort omicron element 17 before sort pi element 18 before sort rho element 19 before sort sigma element 20 before sort tau element 21 before sort upsilon element 22 before sort phi element 23 before sort chi element 24 before sort psi element 25 before sort omega element 0 after sort ---letters of the modern Greek Alphabet--- element 1 after sort ========================================== element 2 after sort alpha element 3 after sort beta element 4 after sort chi element 5 after sort delta element 6 after sort epsilon element 7 after sort eta element 8 after sort gamma element 9 after sort iota element 10 after sort kappa element 11 after sort lambda element 12 after sort mu element 13 after sort nu element 14 after sort omega element 15 after sort omicron element 16 after sort phi element 17 after sort pi element 18 after sort psi element 19 after sort rho element 20 after sort sigma element 21 after sort tau element 22 after sort theta element 23 after sort upsilon element 24 after sort xi element 25 after sort zeta
PureBasic
<lang PureBasic>Declare heapify(Array a(1), count) Declare siftDown(Array a(1), start, ending)
Procedure heapSort(Array a(1), count)
Protected ending=count-1 heapify(a(), count) While ending>0 Swap a(ending),a(0) siftDown(a(), 0, ending-1) ending-1 Wend
EndProcedure
Procedure heapify(Array a(1), count)
Protected start=(count-2)/2 While start>=0 siftDown(a(),start,count-1) start-1 Wend
EndProcedure
Procedure siftDown(Array a(1), start, ending)
Protected root=start, child While (root*2+1)<=ending child=root*2+1 If child+1<=ending And a(child)<a(child+1) child+1 EndIf If a(root)<a(child) Swap a(root), a(child) root=child Else Break EndIf Wend
EndProcedure</lang>
Python
<lang python>def heapsort(lst):
Heapsort. Note: this function sorts in-place (it mutates the list).
# in pseudo-code, heapify only called once, so inline it here for start in range((len(lst)-2)/2, -1, -1): siftdown(lst, start, len(lst)-1)
for end in range(len(lst)-1, 0, -1): lst[end], lst[0] = lst[0], lst[end] siftdown(lst, 0, end - 1) return lst
def siftdown(lst, start, end):
root = start while True: child = root * 2 + 1 if child > end: break if child + 1 <= end and lst[child] < lst[child + 1]: child += 1 if lst[root] < lst[child]: lst[root], lst[child] = lst[child], lst[root] root = child else: break</lang>
Testing:
>>> ary = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0] >>> heapsort(ary) [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
Racket
<lang racket>
- lang racket
(require (only-in srfi/43 vector-swap!))
(define (heap-sort! xs)
(define (ref i) (vector-ref xs i)) (define (swap! i j) (vector-swap! xs i j)) (define size (vector-length xs)) (define (sift-down! r end) (define c (+ (* 2 r) 1)) (define c+1 (+ c 1)) (when (<= c end) (define child (if (and (<= c+1 end) (< (ref c) (ref c+1))) c+1 c)) (when (< (ref r) (ref child)) (swap! r child)) (sift-down! child end))) (for ([i (in-range (quotient (- size 2) 2) -1 -1)]) (sift-down! i (- size 1))) (for ([end (in-range (- size 1) 0 -1)]) (swap! 0 end) (sift-down! 0 (- end 1))) xs)
</lang>
REXX
<lang rexx>/*REXX program sorts an array using the heapsort method. */ call gen@ /*generate the array elements. */ call show@ 'before sort' /*show the before array elements*/ call heapSort highItem /*invoke the heap sort. */ call show@ ' after sort' /*show tge after array elements*/ exit /*stick a fork in it, we're done.*/ /*──────────────────────────────────HEAPSORT subroutine─────────────────*/ heapSort: procedure expose @.; parse arg n
do j=n%2 by -1 to 1 call shuffle j,n end /*j*/ do n=n by -1 to 2 _=@.1; @.1=@.n; @.n=_; call shuffle 1,n end /*n*/
return /*──────────────────────────────────SHUFFLE subroutine──────────────────*/ shuffle: procedure expose @.; parse arg i,n; _=@.i
do while i+i<=n j=i+i; k=j+1 if k<=n & @.k>@.j then j=k if _>=@.j then leave @.i=@.j; i=j end /*while i+i<=n*/
@.i=_ return /*──────────────────────────────────GEN@ subroutine─────────────────────*/ gen@: @.= /*assign default value for array.*/ @.1 ='---letters of the modern Greek Alphabet---' ; @.14='mu' @.2 ='==========================================' ; @.15='nu' @.3 ='alpha' ; @.16='xi' @.4 ='beta' ; @.17='omicron' @.5 ='gamma' ; @.18='pi' @.6 ='delta' ; @.19='rho' @.7 ='epsilon' ; @.20='sigma' @.8 ='zeta' ; @.21='tau' @.9 ='eta' ; @.22='upsilon' @.10='theta' ; @.23='phi' @.11='iota' ; @.24='chi' @.12='kappa' ; @.25='psi' @.13='lambda' ; @.26='omega'
do highItem=1 while @.highItem\== /*find how many entries. */ end /*highitem*/
highItem=highItem-1 /*adjust highItem slightly. */ return /*──────────────────────────────────SHOW@ subroutine────────────────────*/ show@: widthH=length(highItem) /*maximum width of any line. */
do j=1 for highItem say 'element' right(j,widthH) arg(1)':' @.j end /*j*/
say copies('-', 79) /*show a separator line. */ return </lang>
- Output:
element 1 before sort: ---letters of the modern Greek Alphabet--- element 2 before sort: ========================================== element 3 before sort: alpha element 4 before sort: beta element 5 before sort: gamma element 6 before sort: delta element 7 before sort: epsilon element 8 before sort: zeta element 9 before sort: eta element 10 before sort: theta element 11 before sort: iota element 12 before sort: kappa element 13 before sort: lambda element 14 before sort: mu element 15 before sort: nu element 16 before sort: xi element 17 before sort: omicron element 18 before sort: pi element 19 before sort: rho element 20 before sort: sigma element 21 before sort: tau element 22 before sort: upsilon element 23 before sort: phi element 24 before sort: chi element 25 before sort: psi element 26 before sort: omega ──────────────────────────────────────────────────────────────────────────────── element 1 after sort: eta element 2 after sort: ========================================== element 3 after sort: chi element 4 after sort: beta element 5 after sort: delta element 6 after sort: ---letters of the modern Greek Alphabet--- element 7 after sort: theta element 8 after sort: iota element 9 after sort: omicron element 10 after sort: lambda element 11 after sort: omega element 12 after sort: kappa element 13 after sort: nu element 14 after sort: mu element 15 after sort: epsilon element 16 after sort: alpha element 17 after sort: phi element 18 after sort: pi element 19 after sort: psi element 20 after sort: rho element 21 after sort: sigma element 22 after sort: tau element 23 after sort: gamma element 24 after sort: upsilon element 25 after sort: xi element 26 after sort: zeta ────────────────────────────────────────────────────────────────────────────────
Output looks incorrect!?! --Walterpachl (talk) 21:08, 27 July 2013 (UTC)
Version 2
<lang rexx>/* REXX ***************************************************************
- Translated from PL/I
- 27.07.2013 Walter Pachl
- /
list='---letters of the modern Greek Alphabet---|'||, '==========================================|'||, 'alpha|beta|gamma|delta|epsilon|zeta|eta|theta|'||, 'iota|kappa|lambda|mu|nu|xi|omicron|pi|'||, 'rho|sigma|tau|upsilon|phi|chi|psi|omega' Do i=0 By 1 While list<> Parse Var list a.i '|' list End n=i-1
Call showa 'before sort' Call heapsort n Call showa ' after sort' Exit
heapSort: Procedure Expose a. Parse Arg count Call heapify count end=count-1 do while end>0 Call swap end,0 end=end-1 Call siftDown 0,end End Return
heapify: Procedure Expose a. Parse Arg count start=(count-2)%2 Do while start>=0 Call siftDown start,count-1 start=start-1 End Return
siftDown: Procedure Expose a. Parse Arg start,end root=start Do while root*2+1<= end child=root*2+1 sw=root if a.sw<a.child Then sw=child child_1=child+1 if child+1<=end & a.sw<a.child_1 Then sw=child+1 if sw<>root Then Do Call swap root,sw root=sw End else return End Return
swap: Procedure Expose a. Parse arg x,y temp=a.x a.x=a.y a.y=temp Return
showa: Procedure Expose a. n Parse Arg txt Do j=0 To n-1 Say 'element' format(j,2) txt a.j End Return</lang>
Output: see PL/I
Ruby
<lang ruby>class Array
def heapsort self.dup.heapsort! end
def heapsort! # in pseudo-code, heapify only called once, so inline it here ((length - 2) / 2).downto(0) {|start| siftdown(start, length - 1)}
# "end" is a ruby keyword (length - 1).downto(1) do |end_| self[end_], self[0] = self[0], self[end_] siftdown(0, end_ - 1) end self end
def siftdown(start, end_) root = start loop do child = root * 2 + 1 break if child > end_ if child + 1 <= end_ and self[child] < self[child + 1] child += 1 end if self[root] < self[child] self[root], self[child] = self[child], self[root] root = child else break end end end
end</lang> Testing:
irb(main):035:0> ary = [7, 6, 5, 9, 8, 4, 3, 1, 2, 0] => [7, 6, 5, 9, 8, 4, 3, 1, 2, 0] irb(main):036:0> ary.heapsort => [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
Scala
This code is not written for maximum performance, though, of course, it preserves the O(n log n) characteristic of heap sort. <lang scala>def heapSort[T](a: Array[T])(implicit ord: Ordering[T]) {
import scala.annotation.tailrec // Ensure functions are tail-recursive import ord._ val indexOrdering = Ordering by a.apply
def numberOfLeaves(heapSize: Int) = (heapSize + 1) / 2 def children(i: Int, heapSize: Int) = { val leftChild = i * 2 + 1 leftChild to leftChild + 1 takeWhile (_ < heapSize) }
def swap(i: Int, j: Int) = { val tmp = a(i) a(i) = a(j) a(j) = tmp } // Maintain partial ordering by bubbling down elements @tailrec def siftDown(i: Int, heapSize: Int) { val childrenOfI = children(i, heapSize) if (childrenOfI nonEmpty) { val biggestChild = childrenOfI max indexOrdering if (a(i) < a(biggestChild)) { swap(i, biggestChild) siftDown(biggestChild, heapSize) } } } // Prepare heap by sifting down all non-leaf elements for (i <- a.indices.reverse drop numberOfLeaves(a.size)) siftDown(i, a.size) // Sort from the end of the array forward, by swapping the highest element, // which is always the top of the heap, to the end of the unsorted array for (i <- a.indices.reverse) { swap(0, i) siftDown(0, i) }
}</lang>
Scheme
<lang scheme>; swap two elements of a vector (define (swap! v i j)
(define temp (vector-ref v i)) (vector-set! v i (vector-ref v j)) (vector-set! v j temp))
- sift element at node start into place
(define (sift-down! v start end)
(let ((child (+ (* start 2) 1))) (cond ((> child end) 'done) ; start has no children (else (begin ; if child has a sibling node whose value is greater ... (and (and (<= (+ child 1) end) (< (vector-ref v child) (vector-ref v (+ child 1)))) ; ... then we'll look at the sibling instead (set! child (+ child 1))) (if (< (vector-ref v start) (vector-ref v child)) (begin (swap! v start child) (sift-down! v child end)) 'done))))))
- transform v into a binary max-heap
(define (heapify v)
(define (iter v start) (if (>= start 0) (begin (sift-down! v start (- (vector-length v) 1)) (iter v (- start 1))) 'done)) ; start sifting with final parent node of v (iter v (quotient (- (vector-length v) 2) 2)))
(define (heapsort v)
; swap root and end node values, ; sift the first element into place ; and recurse with new root and next-to-end node (define (iter v end) (if (zero? end) 'done (begin (swap! v 0 end) (sift-down! v 0 (- end 1)) (iter v (- end 1))))) (begin (heapify v) ; start swapping with root and final node (iter v (- (vector-length v) 1))))
- testing
(define uriah (list->vector '(3 5 7 9 0 8 1 4 2 6))) (heapsort uriah) uriah</lang>
- Output:
done #(0 1 2 3 4 5 6 7 8 9)
Seed7
<lang seed7>const proc: downheap (inout array elemType: arr, in var integer: k, in integer: n) is func
local var elemType: help is elemType.value; var integer: j is 0; begin if k <= n div 2 then help := arr[k]; repeat j := 2 * k; if j < n and arr[j] < arr[succ(j)] then incr(j); end if; if help < arr[j] then arr[k] := arr[j]; k := j; end if; until help >= arr[j] or k > n div 2; arr[k] := help; end if; end func;
const proc: heapSort (inout array elemType: arr) is func
local var integer: n is 0; var integer: k is 0; var elemType: help is elemType.value; begin n := length(arr); for k range n div 2 downto 1 do downheap(arr, k, n); end for; repeat help := arr[1]; arr[1] := arr[n]; arr[n] := help; decr(n); downheap(arr, 1, n); until n <= 1; end func;</lang>
Original source: [1]
Tcl
Based on the algorithm from Wikipedia:
<lang tcl>package require Tcl 8.5
proc heapsort {list {count ""}} {
if {$count eq ""} {
set count [llength $list]
} for {set i [expr {$count/2 - 1}]} {$i >= 0} {incr i -1} {
siftDown list $i [expr {$count - 1}]
} for {set i [expr {$count - 1}]} {$i > 0} {} {
swap list $i 0 incr i -1 siftDown list 0 $i
} return $list
} proc siftDown {varName i j} {
upvar 1 $varName a while true {
set child [expr {$i*2 + 1}] if {$child > $j} { break } if {$child+1 <= $j && [lindex $a $child] < [lindex $a $child+1]} { incr child } if {[lindex $a $i] >= [lindex $a $child]} { break } swap a $i $child set i $child
}
} proc swap {varName x y} {
upvar 1 $varName a set tmp [lindex $a $x] lset a $x [lindex $a $y] lset a $y $tmp
}</lang> Demo code: <lang tcl>puts [heapsort {1 5 3 7 9 2 8 4 6 0}]</lang>
- Output:
0 1 2 3 4 5 6 7 8 9
TI-83 BASIC
Store list with a dimension of 7 or less into L1 (if less input will be padded with zeros), run prgmSORTHEAP, look into L2 for the sorted version of L1. It is possible to do this without L3 (thus, in place), but I coded this when I was paying attention to a math lecture. Could you make a better version that accepts any input, without having to use my clunky If
structure? Could you make it in-place?
:If dim(L1)>7 :Then :Disp "ERR:7" :Stop :End :If dim(L1)<7 :Then :For(A,1,7) :If A>dim(L1) :0→L1(A) :End :End :{0}→L2 :For(B,2,7) :0→L2(B) :End :L1→L3 :For(B,0,6) :If L3(4)>L3(2) :Then :L3(2)→A :L3(4)→L3(2) :A→L3(4) :End :If L3(5)>L3(2) :Then :L3(2)→A :L3(5)→L3(2) :A→L3(5) :End :If L3(6)>L3(3) :Then :L3(3)→A :L3(6)→L3(3) :A→L3(6) :End :If L3(7)>L3(3) :Then :L3(3)→A :L3(7)→L3(3) :A→L3(7) :End :If L3(2)>L3(1) :Then :L3(1)→A :L3(2)→L3(1) :A→L3(2) :End :If L3(3)>L3(1) :Then :L3(1)→A :L3(3)→L3(1) :A→L3(3) :End :L3(1)→L2(7-B) :If L3(2)>L3(3) :Then :L3(2)→L3(1) :0→L3(2) :Else :L3(3)→L3(1) :0→L3(3) :End :End :DelVar A :DelVar B :DelVar L3 :Return
- Programming Tasks
- Sorting Algorithms
- WikipediaSourced
- ActionScript
- Ada
- AutoHotkey
- BBC BASIC
- BCPL
- C
- C++
- C sharp
- Clojure
- CoffeeScript
- Common Lisp
- D
- Dart
- E
- F Sharp
- Forth
- Fortran
- Go
- Groovy
- Haskell
- Icon
- Unicon
- J
- Java
- Liberty BASIC
- LotusScript
- M4
- Mathematica
- MATLAB
- Octave
- NetRexx
- Objeck
- OCaml
- Oz
- Pascal
- Perl
- Perl 6
- PicoLisp
- PL/I
- PureBasic
- Python
- Racket
- REXX
- Ruby
- Scala
- Scheme
- Seed7
- Tcl
- TI-83 BASIC
- GUISS/Omit