Source code in the action! programming language

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