home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / fortran / ratfor.lbr / QSORT.RTF < prev    next >
Text File  |  1986-04-27  |  5KB  |  193 lines
  1. #  msort.rtf - sort lines in memory
  2. #
  3. #  this program allocates both a buffer (linbuf) and pointers into that
  4. #  buffer (linptr) above then end of the program using ialloc.
  5. #  note that when words are allocated, 2*LEN+1 must be allocated, the +1
  6. #  in case the array address is on an odd word boundary.  However,
  7. #  as long as all of the pointer and buffer manipulations are done in
  8. #  subroutines, these irregularities disappear by using linbuf(bptr) and
  9. #  linptr(lptr) as the argument to the subroutine.
  10.  
  11. include "b:ratdefn.rtf"
  12.  
  13. define(MERGEORDER,7)
  14. define(NAMESIZE,20)
  15. define(MAXTEXT,10000)
  16. define(MAXPTR,2000)
  17. define(LOGPTR,20)
  18. # sort - sort text lines in memory
  19.    character linbuf(ARB)
  20.    character argbuf(MAXLINE)
  21.    character clower
  22.    integer gtext,ialloc,iaddr, getarg
  23.    integer linptr(ARB), nlines, lptr, bptr
  24.    integer isp
  25.    logical rvflag
  26.  
  27.    call initio
  28.  
  29.    rvflag = NO
  30.  
  31.    if (getarg(1,argbuf,MAXLINE)!=EOF)
  32.     if (argbuf(1)==MINUS & clower(argbuf(2))==LETR & argbuf(3)==EOS)
  33.         rvflag = YES
  34.     else 
  35.         call error("usage: sort [-r].")
  36.  
  37.    isp = ialloc(2*MAXPTR+1)    # allocating words is more difficult than chars
  38.    if (isp==NO) call error("cannot allocate memory.")
  39.     else lptr=(isp+1-iaddr(linptr))/2+1
  40.    isp=ialloc(MAXTEXT)
  41.    if (isp==NO) call error("cannot allocate memory.")
  42.     else bptr=isp-iaddr(linbuf)+1
  43.    if (gtext(linptr(lptr), nlines, linbuf(bptr), STDIN) == EOF) {
  44.       call quick(linptr(lptr), nlines, linbuf(bptr))
  45.       call ptext(linptr(lptr), nlines, linbuf(bptr), rvflag, STDOUT)
  46.       call putch(EOF,STDOUT)
  47.       }
  48.    else
  49.       call error("too big to sort.")
  50.    stop
  51.    end
  52. # shell - Shell sort for character lines
  53.    subroutine shell(linptr, nlines, linbuf)
  54.    character linbuf(ARB)
  55.    integer compar
  56.    integer gap, i, ig, j, k, linptr(ARB), nlines
  57.  
  58.    for (gap = nlines/2; gap > 0; gap = gap/2)
  59.       for (j = gap + 1; j <= nlines; j = j + 1)
  60.      for (i = j - gap; i > 0; i = i - gap) {
  61.         ig = i + gap
  62.         if (compar(linptr(i), linptr(ig), linbuf) <= 0)
  63.            break
  64.         call exchan(linptr(i), linptr(ig), linbuf)
  65.         }
  66.    return
  67.    end
  68. # gtext - get text lines into linbuf
  69.    integer function gtext(linptr, nlines, linbuf, infile)
  70.    character linbuf(ARB)
  71.    integer getlin
  72.    integer infile, lbp, len, linptr(ARB), nlines
  73.  
  74.    nlines = 0
  75.    lbp = 1
  76.    repeat {
  77.       len = getlin(linbuf(lbp), infile)
  78.       if (len == EOF)
  79.      break
  80.       nlines = nlines + 1
  81.       linptr(nlines) = lbp
  82.       lbp = lbp + len + 1   # "1" = room for EOS
  83.       } until (lbp >= MAXTEXT-MAXLINE | nlines >= MAXPTR)
  84.    gtext = len
  85.    return
  86.    end
  87. # ptext - output text lines from linbuf
  88.    subroutine ptext(linptr, nlines, linbuf, rvflag, outfil)
  89.    character linbuf(MAXTEXT)
  90.    logical rvflag
  91.    integer i, j, linptr(MAXPTR), nlines, outfil
  92.  
  93.    if (rvflag == YES)
  94.     for (i = nlines; i >= 1; i = i - 1) {
  95.        j = linptr(i)
  96.        call putlin(linbuf(j), outfil)
  97.        }
  98.    else
  99.     for (i = 1; i <= nlines; i = i + 1) {
  100.        j = linptr(i)
  101.        call putlin(linbuf(j), outfil)
  102.        }
  103.    return
  104.    end
  105. # compar - compare linbuf(lp1) with linbuf(lp2)
  106.    integer function compar(lp1, lp2, linbuf)
  107.    character linbuf(ARB)
  108.    integer i, j, lp1, lp2
  109.  
  110.    i = lp1
  111.    j = lp2
  112.    while (linbuf(i) == linbuf(j)) {
  113.       if (linbuf(i) == EOS) {
  114.      compar = 0
  115.      return
  116.      }
  117.       i = i + 1
  118.       j = j + 1
  119.       }
  120.    if (linbuf(i) < linbuf(j))
  121.       compar = -1
  122.    else
  123.       compar = +1
  124.    return
  125.    end
  126. # exchan - exchange linbuf(lp1) with linbuf(lp2)
  127.    subroutine exchan(lp1, lp2, linbuf)
  128.    character linbuf(ARB)
  129.    integer k, lp1, lp2
  130.  
  131.    k = lp1
  132.    lp1 = lp2
  133.    lp2 = k
  134.    return
  135.    end
  136. # quick - quicksort for character lines
  137.    subroutine quick(linptr, nlines, linbuf)
  138.    character linbuf(ARB)
  139.    integer compar
  140.    integer i, j, linptr(ARB), lv(LOGPTR), nlines, p, pivlin, uv(LOGPTR)
  141.  
  142.    lv(1) = 1
  143.    uv(1) = nlines
  144.    p = 1
  145.    while (p > 0)
  146.       if (lv(p) >= uv(p))      # only one element in this subset
  147.      p = p - 1    # pop stack
  148.       else {
  149.      i = lv(p) - 1
  150.      j = uv(p)
  151.      pivlin = linptr(j)   # pivot line
  152.      while (i < j) {
  153.         for (i=i+1; compar(linptr(i), pivlin, linbuf) < 0; i=i+1)
  154.            ;
  155.         for (j = j - 1; j > i; j = j - 1)
  156.            if (compar(linptr(j), pivlin, linbuf) <= 0)
  157.           break
  158.         if (i < j)        # out of order pair
  159.            call exchan(linptr(i), linptr(j), linbuf)
  160.         }
  161.      j = uv(p)       # move pivot to position i
  162.      call exchan(linptr(i), linptr(j), linbuf)
  163.      if (i-lv(p) < uv(p)-i) {   # stack so shorter done first
  164.         lv(p+1) = lv(p)
  165.         uv(p+1) = i - 1
  166.         lv(p) = i + 1
  167.         }
  168.      else {
  169.         lv(p+1) = i + 1
  170.         uv(p+1) = uv(p)
  171.         uv(p) = i - 1
  172.         }
  173.      p = p + 1       # push onto stack
  174.      }
  175.    return
  176.    end
  177. 
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.