/* Program to sort numbers using heapsort */
N=5
Name.0=5
Name.1="Chris"
Name.2="Bill"
Name.3="Tom"
Name.4="Fred"
Name.5="Henry"
Weight.0=5
Weight.1=155
Weight.2=180
Weight.3=220
Weight.4=125
Weight.5=175
Height.0=5
Height.1=6.0
Height.2=5.96
Height.3=5.75
Height.4=6.2
Height.5=6.1

Arrays="Weight. Name. Height."

Say "Original stems:"
Do i=1 to N
  Say Name.i Weight.i Height.i
End

Say ""

et=HeapSort()

Say "Stems after sorting:" 
Do i=1 to N
  Say Name.i Weight.i Height.i
End

Say "Heapsort took" et "seconds"
Exit

 /* ------------------------------------------------------------------ */
 /* function: heap sort routine that tracks multiple stems             */
 /*                                                                    */
 /* call:     HeapSort                                                 */
 /*                                                                    */
 /* returns:  nothing                                                  */
 /*                                                                    */
 /* notes:    The variable Arrays must be a string containing the names*/
 /*           of the stems that will be sorted. The first stem listed  */
 /*           is the one that is used as the key (i.e., the values that*/
 /*           will be sorted) and the others are the ones whose values */
 /*           follow the items in the key array. For example, suppose  */
 /*           you have a stem called Names., another array Weights.,   */
 /*           and another array Heights. and you want to sort the      */
 /*           arrays by the weights. You would call HeapSort with the  */
 /*           Arrays variable set as Arrays="Weights. Names. Heights." */
 /*           (The order of the secondary stems Names. and Heights. is */
 /*           not important.)                                          */
 /*                                                                    */
 /* reference: Sedgewick, "Algorithms"                                 */
 /*                                                                    */
 Heapsort: PROCEDURE expose (Arrays)
   start=Time("R")
   NArrays=Words(Arrays)
   Interpret "NItems="||Word(Arrays,1)||"0"

/* Copy the original stems to temporary ones */
Do i=0 to NItems
   Interpret "Stem.i="||Word(Arrays,1)||i
   Do j=2 to NArrays
      Interpret "Stem.i.j="||Word(Arrays,j)||i
   end /* do */
end /* do */

   M = stem.0
   N = M
 
   do k=M % 2 to 1 by -1
     call DownHeap k N
   end /* do */
 
   do while N>1
     t = stem.1
     Do i=2 to NArrays
        t.i=Stem.1.i
     end /* do */
     stem.1 = stem.n
     Do i=2 to NArrays
        Stem.1.i=Stem.n.i
     end /* do */
     stem.n = t
     Do i=2 to NArrays
        Stem.n.i=t.i
     end /* do */
     n = n-1
     call DownHeap 1 N
   end /* do */

/* Re-order the original stems */
   Do i=0 to NItems
      Interpret Word(Arrays,1)||i||"="||"Stem.i"
      Do j=2 to NArrays
         Interpret Word(Arrays,j)||i||"="||"Stem.i.j"
      end /* do */
   end /* do */
/* Stop the timer */
   end=time("R")
   elapsed=end-start

 RETURN elapsed
 
 /* subroutine of HeapSort                                             */
 DownHeap: PROCEDURE expose stem. NArrays
   parse Arg k N
 
   v = stem.k
   Do i=2 to NArrays
      v.i=Stem.k.i
   end /* do */
 
   do while k <= N%2
     j = k+k
     if j < n then
     do
       i = j+1
       if stem.j < stem.i then
         j=j+1
     end  /* do */
 
     if v >= stem.j then
       signal label
 
     stem.k = stem.j
     Do i=2 to NArrays
        Stem.k.i=Stem.j.i
     end /* do */
     k = j
   end /* do */
 
 Label:
   stem.k = v
   Do i=2 to NArrays
      Stem.k.i=v.i
   end /* do */
 RETURN