* KEXX
/* ---------------------------------------------------------------- */
/* SORTSTEM.REX                                                     */
/* Algorithms and techniques for sorting stemmed "arrays"           */
/* 18 Oct 1998  Rex Swain, Independent Consultant, rex@rexswain.com */
/* 02 Jan 1999  Added sort3(); added built-in timings               */
/* ---------------------------------------------------------------- */

 parse arg n                          /* How many elements to test? */
 if n = '' then n = 200               /* Default to 200             */
 call test n                          /* Run tests                  */
 exit

/* ---------------------------------------------------------------- */

/* Suppose you want to sort the stem "foo."                         */
/*   so that:       is changed to:                                  */
/*     foo.0 = 4      foo.0 = 4                                     */
/*     foo.1 = 25     foo.1 = -3                                    */
/*     foo.2 = -3     foo.2 = 0                                     */
/*     foo.3 = 0      foo.3 = 12                                    */
/*     foo.4 = 12     foo.4 = 25                                    */

/* Due to limitations in the REXX language, the only reasonable way */
/* to do this is to pass the stem as a global to an internal        */
/* subroutine.                                                      */

/* ---------------------------------------------------------------- */

/* If you want to sort using the dead minimum amount of code, use   */
/* sort1, changing all occurences of "foo" to your stem name.       */
/* This is a vanilla "bubble sort".                                 */

/* Usage:                                                           */
/*    /* create foo.        */                                      */
/*    call sort1                                                    */
/*    /* foo. is now sorted */                                      */

sort1: procedure expose foo.
 n = foo.0
 do i = 1 to n
    do j = i+1 to n
       if foo.i > foo.j then do
          temp = foo.i
          foo.i = foo.j
          foo.j = temp
       end
    end
 end
 return

/* ---------------------------------------------------------------- */

/* While sort1 is small, it is also slow.  A much faster algorithm, */
/* but requiring a little more code, is sort2.  Again, change all   */
/* occurences of "foo" to the name of your stem.                    */

/* Usage:                                                           */
/*    /* create foo.        */                                      */
/*    call sort2                                                    */
/*    /* foo. is now sorted */                                      */

sort2: procedure expose foo.
 n = foo.0
 h = n
 do while h > 1
    h = h % 2
    do i = 1 to n-h
       j = i
       k = h + i
       do while foo.k < foo.j
          temp = foo.j
          foo.j = foo.k
          foo.k = temp
          if h >= j then leave
          j = j - h
          k = k - h
       end
    end
 end
 return

/* ---------------------------------------------------------------- */

/* Here is a recursive "quick sort" routine, which can be           */
/* significantly faster than sort2 for large arrays.                */
/* Again, change all occurences of "foo" to the name of your stem.  */

/* Warning:  A large array will generate extensive recursion, which */
/* may cause "control stack full" problems with some Rexx           */
/* implementations.                                                 */

/* Usage:                                                           */
/*    /* create foo.        */                                      */
/*    call sort3                                                    */
/*    /* foo. is now sorted */                                      */

sort3:
 call sort3a 1,foo.0
 return

sort3a: procedure expose foo.
 parse arg first,last
 k = (first+last) % 2
 middle = foo.k
 i = first
 j = last
 do while i <= j /* RHS: Like "do until i > j" but handles n=0 case */
    do i = i while foo.i < middle
    end
    do j = j by -1 while middle < foo.j
    end
    if i <= j then do
       if i < j then do      /* RHS: Avoid swap if values are equal */
          temp = foo.i
          foo.i = foo.j
          foo.j = temp
       end
       i = i + 1
       j = j - 1
    end
 end
 if j - first > last - i then do
    if i < last then
       call sort3a i,last
    if first < j then
       call sort3a first,j
 end
 else do
    if first < j then
       call sort3a first,j
    if i < last then
       call sort3a i,last
 end
 return

/* ---------------------------------------------------------------- */

/* If you need to sort several stems in your program, you can make  */
/* several copies of the subroutines above, changing the name of    */
/* the stem in each.                                                */

/* But a better solution is to use a more general (albeit somewhat  */
/* slower) approach that can sort any stem name.  The subroutines   */
/* below use the same logic as those above, but instead of          */
/* referring to "foo.", they use the Rexx value() function to refer */
/* to a named stem.                                                 */

/* The only additional requirement is that prior to calling one of  */
/* these subroutines, you must create a variable named "stemname"   */
/* that contains the name of the stem to be sorted.                 */

/* Usage:                                                           */
/*    /* create foo. and data. and etcetera */                      */
/*    stemname = 'foo.'                                             */
/*    call sortstem2                                                */
/*    /* foo. is now sorted                 */                      */
/*    stemname = 'data.'                                            */
/*    call sortstem2                                                */
/*    /* data. is now sorted                */                      */
/*    /* etcetera                           */                      */

sortstem1: procedure expose stemname (stemname)
 n = value(stemname||0)
 do i = 1 to n
    do j = i+1 to n
       if value(stemname||i) > value(stemname||j) then do
          temp = value(stemname||i,value(stemname||j))
          sink = value(stemname||j,temp)
       end
    end
 end
 return

sortstem2: procedure expose stemname (stemname)
 n = value(stemname||0)
 h = n
 do while h > 1
    h = h % 2
    do i = 1 to n-h
       j = i
       k = h + i
       do while value(stemname||k) < value(stemname||j)
          temp = value(stemname||j,value(stemname||k))
          sink = value(stemname||k,temp)
          if h >= j then leave
          j = j - h
          k = k - h
       end
    end
 end
 return

sortstem3:
 call sortstem3a 1,value(stemname||0)
 return

sortstem3a: procedure expose stemname (stemname)
 parse arg first,last
 i = (first+last) % 2
 middle = value(stemname||i)
 i = first
 j = last
 do while i <= j /* RHS: Like "do until i > j" but handles n=0 case */
    do i = i while value(stemname||i) < middle
    end
    do j = j by -1 while middle < value(stemname||j)
    end
    if i <= j then do
       if i < j then do      /* RHS: Avoid swap if values are equal */
          temp = value(stemname||i,value(stemname||j))
          sink = value(stemname||j,temp)
       end
       i = i + 1
       j = j - 1
    end
 end
 if j - first > last - i then do
    if i < last then
       call sortstem3a i,last
    if first < j then
       call sortstem3a first,j
 end
 else do
    if first < j then
       call sortstem3a first,j
    if i < last then
       call sortstem3a i,last
 end
 return

/* ---------------------------------------------------------------- */

/* You can avoid repeatedly re-defining the "stemname" variable by  */
/* introducing an intermediate subroutine like those below.  Its    */
/* sole job is to create "stemname" and pass it along to sortstem.  */
/* Just be careful because it's less obvious that a global variable */
/* is being created.                                                */

/* Usage:                                                           */
/*    /* create foo. and data. and etcetera */                      */
/*    call sortstemnamed2 'foo.'                                    */
/*    /* foo. is now sorted                 */                      */
/*    call sortstemnamed2 'data.'                                   */
/*    /* data. is now sorted                */                      */
/*    /* etcetera                           */                      */

sortstemnamed1:        /* Note: this is NOT a procedure             */
 parse arg stemname    /* Note: global being created or re-assigned */
 call sortstem1
 return

sortstemnamed2:        /* Note: this is NOT a procedure             */
 parse arg stemname    /* Note: global being created or re-assigned */
 call sortstem2
 return

sortstemnamed3:        /* Note: this is NOT a procedure             */
 parse arg stemname    /* Note: global being created or re-assigned */
 call sortstem3
 return






/* ---------------------------------------------------------------- */
/* Timing and verification stuff follows                            */
/* ---------------------------------------------------------------- */

test: procedure
 parse arg n

 algs = 3
 cases = 4

 case.1 = 'Ascend'
 case.2 = 'Descend'
 case.3 = 'Alternate'
 case.4 = 'Random'

 algw = 3                             /* Display width              */
 casew = 9                            /* Display width              */

 seed = time('S')                     /* Capture consistent seed    */

 say 'Elapsed times for' n 'elements:'

 s = right('Alg',algw)
 do case = 1 to cases
    s = s right(case.case,casew)
 end
 say s right('Total',casew)           /* Column titles              */

 do tech = 1 to 3                     /* For each technique         */

    select
       when tech = 1 then
          todo = "call sort?"
       when tech = 2 then
          todo = "stemname = 'foo.' ; call sortstem?"
       when tech = 3 then
          todo = "call sortstemnamed? 'foo.'"
    end

    i = pos('?',todo)
    say 'Technique:' delstr(todo,i,1)

    do alg = 1 to algs                /* For each algorithm         */

       td = left(todo,i-1) || alg || substr(todo,i+1)

       do case = 1 to cases           /* For each data case         */
          call create case            /* Create foo.                */
          call time 'R'               /* Reset timer                */
          interpret td                /* Perform the sort           */
          elap.alg.case = time('E')   /* Record elapsed time        */
          call verify alg,case        /* Make sure sort worked!     */
       end                            /* Next case                  */

       t = 0
       s = right(alg,algw)
       do case = 1 to cases
          t = t + elap.alg.case
          s = s right(elap.alg.case,casew)
       end
       say s right(t,casew)

    end                               /* Next alg                   */
 end                                  /* Next technique             */
 return

create: procedure expose n foo. seed case.
 parse arg case

 select
    when case = 1 then do             /* case.1 = 'Ascend'          */
       do i = 1 to n
          foo.i = i
       end
    end
    when case = 2 then do             /* case.2 = 'Descend'         */
       do i = 1 to n
          foo.i = n-i+1
       end
    end
    when case = 3 then do             /* case.3 = 'Alternate'       */
       do i = 1 to n
          if 0 = i // 2 then          /* Even                       */
             foo.i = i
          else                        /* Odd                        */
             foo.i = n-i
       end
    end
    when case = 4 then do             /* case.4 = 'Random'          */
       i = random(,,seed)             /* Set seed                   */
       do i = 1 to n
          foo.i = random(1,n)
       end
    end
 end
 foo.0 = n
 return

verify: procedure expose n foo.
 parse arg alg,case
 do i = 2 to n
    j = i - 1
    if foo.i < foo.j then do
       say '*** Alg' alg 'Case' case 'sort did not work!'
       leave
    end
 end
 return