========== programs from chapter 4 ==========
# bubble - bubble sort v(1) ... v(n) increasing
   subroutine bubble(v, n)
   integer i, j, k, n, v(n)
   for (i = n; i > 1; i = i - 1)
      for (j = 1; j < i; j = j + 1)
         if (v(j) > v(j+1)) {      # compare
            k = v(j)      # exchange
            v(j) = v(j+1)      #
            v(j+1) = k      #
            $@$
   return
   end
# shell - Shell sort v(1)...v(n) increasing
   subroutine shell(v, n)
   integer gap, i, j, jg, k, n, v(n)
   for (gap = n/2; gap > 0; gap = gap/2)
      for (i = gap + 1; i <= n; i = i + 1)
         for (j = i - gap; j > 0; j = j - gap) {
            jg = j + gap
            if (v(j) <= v(jg))   # compare
               break
            k = v(j)      # exchange
            v(j) = v(jg)      #
            v(jg) = k      #
            $@$
   return
   end
define(MERGEORDER,7)
define(NAMESIZE,20)
define(MAXTEXT,400)
define(MAXPTR,1000)
define(LOGPTR,20)
# sort - sort text lines in memory
   character linbuf(MAXTEXT)
   integer gtext
   integer linptr(MAXPTR), nlines
   if (gtext(linptr, nlines, linbuf, STDIN) == EOF) {
      call shell(linptr, nlines, linbuf)
      call ptext(linptr, nlines, linbuf, STDOUT)
      $@$
   else
      call error("too big to sort.")
   stop
   end
# shell - Shell sort for character lines
   subroutine shell(linptr, nlines, linbuf)
   character linbuf(ARB)
   integer compar
   integer gap, i, ig, j, k, linptr(ARB), nlines
   for (gap = nlines/2; gap > 0; gap = gap/2)
      for (j = gap + 1; j <= nlines; j = j + 1)
         for (i = j - gap; i > 0; i = i - gap) {
            ig = i + gap
            if (compar(linptr(i), linptr(ig), linbuf) <= 0)
               break
            call exchan(linptr(i), linptr(ig), linbuf)
            $@$
   return
   end
# gtext - get text lines into linbuf
   integer function gtext(linptr, nlines, linbuf, infile)
   character linbuf(MAXTEXT)
   integer getlin
   integer infile, lbp, len, linptr(MAXPTR), nlines
   nlines = 0
   lbp = 1
   repeat {
      len = getlin(linbuf(lbp), infile)
      if (len == EOF)
         break
      nlines = nlines + 1
      linptr(nlines) = lbp
      lbp = lbp + len + 1   # "1" = room for EOS
      $@$ until (lbp >= MAXTEXT-MAXLINE | nlines >= MAXPTR)
   gtext = len
   return
   end
# ptext - output text lines from linbuf
   subroutine ptext(linptr, nlines, linbuf, outfil)
   character linbuf(MAXTEXT)
   integer i, j, linptr(MAXPTR), nlines, outfil
   for (i = 1; i <= nlines; i = i + 1) {
      j = linptr(i)
      call putlin(linbuf(j), outfil)
      $@$
   return
   end
# compar - compare linbuf(lp1) with linbuf(lp2)
   integer function compar(lp1, lp2, linbuf)
   character linbuf(ARB)
   integer i, j, lp1, lp2
   i = lp1
   j = lp2
   while (linbuf(i) == linbuf(j)) {
      if (linbuf(i) == EOS) {
         compar = 0
         return
         $@$
      i = i + 1
      j = j + 1
      $@$
   if (linbuf(i) < linbuf(j))
      compar = -1
   else
      compar = +1
   return
   end
# exchan - exchange linbuf(lp1) with linbuf(lp2)
   subroutine exchan(lp1, lp2, linbuf)
   character linbuf(ARB)
   integer k, lp1, lp2
   k = lp1
   lp1 = lp2
   lp2 = k
   return
   end
# quick - quicksort for character lines
   subroutine quick(linptr, nlines, linbuf)
   character linbuf(ARB)
   integer compar
   integer i, j, linptr(ARB), lv(LOGPTR), nlines, p, pivlin, uv(LOGPTR)
   lv(1) = 1
   uv(1) = nlines
   p = 1
   while (p > 0)
      if (lv(p) >= uv(p))      # only one element in this subset
         p = p - 1      # pop stack
      else {
         i = lv(p) - 1
         j = uv(p)
         pivlin = linptr(j)   # pivot line
         while (i < j) {
            for (i=i+1; compar(linptr(i), pivlin, linbuf) < 0; i=i+1)
               ;
            for (j = j - 1; j > i; j = j - 1)
               if (compar(linptr(j), pivlin, linbuf) <= 0)
                  break
            if (i < j)      # out of order pair
               call exchan(linptr(i), linptr(j), linbuf)
            $@$
         j = uv(p)         # move pivot to position i
         call exchan(linptr(i), linptr(j), linbuf)
         if (i-lv(p) < uv(p)-i) {   # stack so shorter done first
            lv(p+1) = lv(p)
            uv(p+1) = i - 1
            lv(p) = i + 1
            $@$
         else {
            lv(p+1) = i + 1
            uv(p+1) = uv(p)
            uv(p) = i - 1
            $@$
         p = p + 1         # push onto stack
         $@$
   return
   end
# sort - external sort of text lines
   character linbuf(MAXTEXT), name(NAMESIZE)
   integer gtext, makfil, min, open
   integer infil(MERGEORDER), linptr(MAXPTR), nlines
   integer high, lim, low, outfil, t
   high = 0
   repeat {         # initial formation of runs
      t = gtext(linptr, nlines, linbuf, STDIN)
      call quick(linptr, nlines, linbuf)
      high = high + 1
      outfil = makfil(high)
      call ptext(linptr, nlines, linbuf, outfil)
      call close(outfil)
      $@$ until (t == EOF)
   for (low = 1; low < high; low = low + MERGEORDER) {   # merge
      lim = min(low+MERGEORDER-1, high)
      call gopen(infil, low, lim)
      high = high + 1
      outfil = makfil(high)
      call merge(infil, lim-low+1, outfil)
      call close(outfil)
      call gremov(infil, low, lim)
      $@$
   call gname(high, name)   # final cleanup
   outfil = open(name, READ)
   call fcopy(outfil, STDOUT)
   call close(outfil)
   call remove(name)
   stop
   end
# gname - make unique name for file id  n
   subroutine gname(n, name)
   character name(NAMESIZE)
   integer itoc, length
   integer i, junk, n
#   string stemp "stemp"
   integer stemp(6)
   data stemp(1), stemp(2), stemp(3)/ LETS, LETT, LETE/
   data stemp(4), stemp(5), stemp(6)/ LETM, LETP, EOS/
   call scopy(stemp, 1, name, 1)
   i = length(stemp) + 1
   junk = itoc(n, name(i), NAMESIZE-i)
   return
   end
# makfil - make new file for number  n
   integer function makfil(n)
   character name(NAMESIZE)
   integer create
   integer n
   call gname(n, name)
   makfil = create(name, READWRITE)
   if (makfil == ERR)
      call cant(name)
   return
   end
# gopen - open group of files low ... lim
   subroutine gopen(infil, low, lim)
   character name(NAMESIZE)
   integer i, infil(MERGEORDER), lim, low
   integer open
   for (i = 1; i <= lim-low+1; i = i + 1) {
      call gname(low+i-1, name)
      infil(i) = open(name, READ)
      if (infil(i) == ERR)
         call cant(name)
      $@$
   return
   end
# gremov - remove group of files  low ... lim
   subroutine gremov(infil, low, lim)
   character name(NAMESIZE)
   integer i, infil(MERGEORDER), lim, low
   for (i = 1; i <= lim-low+1; i = i + 1) {
      call close(infil(i))
      call gname(low+i-1, name)
      call remove(name)
      $@$
   return
   end
define(MERGETEXT,900)
# merge - merge infil(1) ... infil(nfiles) onto outfil
   subroutine merge(infil, nfiles, outfil)
   character linbuf(MERGETEXT)
   integer getlin
   integer i, inf, lbp, lp1, nf, nfiles, outfil
   integer infil(MERGEORDER), linptr(MERGEORDER)
   lbp = 1
   nf = 0
   for (i = 1; i <= nfiles; i = i + 1)   # get one line from each file
      if (getlin(linbuf(lbp), infil(i)) ~= EOF) {
         nf = nf + 1
         linptr(nf) = lbp
         lbp = lbp + MAXLINE   # room for largest line
         $@$
   call quick(linptr, nf, linbuf)         # make initial heap
   while (nf > 0) {
      lp1 = linptr(1)
      call putlin(linbuf(lp1), outfil)
      inf = lp1 / MAXLINE + 1      # compute file index
      if (getlin(linbuf(lp1), infil(inf)) == EOF) {
         linptr(1) = linptr(nf)
         nf = nf - 1
         $@$
      call reheap(linptr, nf, linbuf)
      $@$
   return
   end
# reheap - propagate linbuf(linptr(1)) to proper place in heap
   subroutine reheap(linptr, nf, linbuf)
   character linbuf(MAXTEXT)
   integer compar
   integer i, j, nf, linptr(nf)
   for (i = 1; 2 * i <= nf; i = j) {
      j = 2 * i
      if (j < nf)      # find smaller child
         if (compar(linptr(j), linptr(j+1), linbuf) > 0)
            j = j + 1
      if (compar(linptr(i), linptr(j), linbuf) <= 0)
         break      # proper position found
      call exchan(linptr(i), linptr(j), linbuf)   # percolate
      $@$
   return
   end
