#
c  mini-explor.  by ken knowlton, bell labs, murray hill, n.j. 2/21/75
c  especially for minicomputers with at least 8k of 16 bit words
c
c  a 140x140 image, consisting of numbers 0-3, is packed 7 to a word
c  as powers of 4 (20 words wide) and addressed as a 1-d array.
c  an additional array /sngls/  holds up to 4 lines of unpacked numbers
c  used by locop, where 3 unpacked lines are used to compute the new
c  line into the 4th, and by show, which unpacks one line and composes
c  in the other 3 the line images for overprinted output.
c
c  percentages not 100, in change, locop and combin, treated as follows.
c  each routine takes numbers 0-198 directly from random table /rand/
c  and compares with iprob = (percent*2-percent/51). if latter is .gt.
c  table value, treat this cell.  the sequence taken from table is
c  determined by random selection of a starting point (ipoint), a skip-
c  ping distance (iskip), and a change in iskip (idlskp) between rows.
c
c store 16 numbers in a horizontal string, starting at ix,iy
      subroutine put16(ix,iy,n1,n2,n3,n4)
           if(iy.lt.1.or.iy.gt.140)return
           if(ix.lt.(-14).or.ix.gt.140)return
        call put4(ix   ,iy,n1)
        call put4(ix+ 4,iy,n2)
        call put4(ix+ 8,iy,n3)
        call put4(ix+12,iy,n4)
      return
      end
#
c store 4 numbers in a horizontal string, starting at ix,iy
      subroutine put4(ix,iy,n)
           if(iy.lt.1.or.iy.gt.140.or.n.lt.0)return
           if(ix.lt.(-2).or.ix.gt.140)return
        call put(ix  ,iy,mod(n/1000,10))
        call put(ix+1,iy,mod(n/ 100,10))
        call put(ix+2,iy,mod(n/  10,10))
        call put(ix+3,iy,mod(n     ,10))
      return
      end
#
c store one number on the map
      subroutine put(ix,iy,n)
#define maxary 2800
#include "common.h"
           integer idiv(8)
           logical frzzt
           data frzzt /.true./
           data idiv(1),idiv(2),idiv(3),idiv(4) /16384,4096,1024,256/
           data idiv(5),idiv(6),idiv(7),idiv(8) /64,16,4,1/
        if(frzzt)call klear(frzzt)
           if(n.gt.3.or.n.lt.0)return
           if(ix.lt.1.or.ix.gt.140)return
           if(iy.lt.1.or.iy.gt.140)return
        index = 20*(iy-1)+(ix+6)/7
        ib = ix-1
        ibyte = ib-(ib/7)*7+1
        i7 = line(index)
        mpy = idiv(ibyte+1)
        line(index) = ((i7/idiv(ibyte))*4+n)*mpy+i7-(i7/mpy)*mpy
      return
      end
#
c
c the number stored at ix,iy.  if off map, num = 4
      integer function num(ix,iy)
#define maxary 2800
#include "common.h"
           integer idiv(7)
           logical frzzt
           data frzzt /.true./
           data idiv(1),idiv(2),idiv(3),idiv(4) /4096,1024,256,64/
           data idiv(5),idiv(6),idiv(7)         /16,4,1/
        if(frzzt)call klear(frzzt)
        num = 4
           if(ix.lt.1.or.ix.gt.140)return
           if(iy.lt.1.or.iy.gt.140)return
        index = 20*(iy-1)+(ix+6)/7
        ib = ix-1
        ibyte = ib-(ib/7)*7+1
        iword = line(index)/idiv(ibyte)
        num = iword-(iword/4)*4
      return
      end
#
c
c random choice from n1 thru n2.  pronounced like any. max range=199
      integer function ne(n1,n2)
#define maxary 2800
#include "common.h"
           logical first
           data first /.true./
        if(.not.first)go to 20
c     initialize table with 0-199, then scramble by exchanges
           first = .false.
           jump = 1
           jdel = 2
           index = 1
           iswap = 17
           do 5 j = 1,199
    5         iran(j) = j-1
           do 10 j = 1,199
              itemp = iran(j)
              iran(j) = iran(iswap)
              iran(iswap) = itemp
  10          iswap = mod(iswap+ (j/2)*j+j+53,199)+1
c     pick a number
  20    ne = n1
        if(n1.eq.n2)return
        min = min0(n1,n2)
        max = max0(n1,n2)
  25    irang = max-min+1
        if(irang.gt.199)irang = 199
        mult = 199/irang
        maxok = mult*irang-1
  30    itry = iran(index)
           index = mod(index+jump,199)+1
           jump = mod(jump+jdel,197)
           jdel = mod(jdel+1,193)
        if(itry.gt.maxok)go to 30
        ne = min+itry/mult
      return
      end
#
c
c
c produce 3-times-overprinted output on printer.  expands line into
c lowest tier of /sngls/  and uses other 3 for output line images
c control characters inew  = form feed, iplus  = overprint, iskip  =
c next line ( * for dec-10 system, blank for most others)
      subroutine show(inx,iny,inw,inh)
#define maxary 2800
#include "common.h"
           logical ok,newpg,frzzt
           integer outa(4),outb(4),outc(4)
           data outa(1),outa(2),outa(3),outa(4) /1h ,1h^,1hx,1h$/
           data outb(1),outb(2),outb(3),outb(4) /1h ,1h ,1h-,1hm/
           data outc(1),outc(2),outc(3),outc(4) /1h ,1h ,1h ,1hw/
           data iskip,iblk,iplus,inew           /1h ,1h ,1h+,1h1/
           data frzzt /.true./
        if(frzzt)call klear(frzzt)
        iw = min0(132,inw)
        call rctfy (inx,iny,inw,inh,il,ir,ib,it,ok)
           if(.not.ok)return
        newpg = .true.
        line = it
        ill = il-1
        do 10 j = ib,it
c     expand line into 3 alphanumeric images for printing
           call xpand(il,line,ir,0)
           line1 = ill
           line2 = ill
           line3 = ill
           do 15 k = il,ir
              num = nm(k)+1
              if(outa(num).ne.iblk)line1 = k
              nm(k+140) = outa(num)
              new = outb(num)
              if(new.ne.iblk)line2 = k
              nm(k+280) = new
              new = outc(num)
              if(new.ne.iblk)line3 = k
  15          nm(k+420) = new
c     (over)print 1 to 3 lines
           nm(ill+140) = iskip
           if(newpg)  nm(ill+140) = inew
           ileft = ill+140
           irite = line1+140
           write(5,101)  (nm(k),k = ileft,irite)
  101            format (133a1)
           if(line2.eq.ill)go to 20
              nm(ill+280) = iplus
              ileft = ill+280
              irite = line2+280
              write(5,101)  (nm(k),k = ileft,irite)
              if(line3.eq.ill)go to 20
                 nm(ill+420) = iplus
                 ileft = ill+420
                 irite = line3+420
                 write(5,101)  (nm(k),k = ileft,irite)
  20       line = line-1
           newpg = .false.
  10    continue
      return
      end
#
c
c transliterate, according to irule, indicated rectangle.  by columns
      subroutine chanj (inx,iny,inw,inh,ipct,irule)
#define maxary 2800
#include "common.h"
           logical ok,frzzt
           integer idiv(7),skip
           data frzzt /.true./
           data idiv(1),idiv(2),idiv(3)         /4096,1024,256/
           data idiv(4),idiv(5),idiv(6),idiv(7) /64,16,4,1/
           data skip /0/
        if(frzzt)call klear(frzzt)
           if(irule.lt.0.or.irule.gt.3333)return
        call rctfy (inx,iny,inw,inh,il,ir,ib,it,ok)
           if(.not.ok)return
        iprob = 2*ipct-ipct/51
        ipont = ne(1,199)
        iskip = ne(0,197)
        idlsk = ne(0,195)
        call setxl(irule)
c     if 0000,1111,2222,3333 and ipct=100 need not read for full words
c     complete word is 5461 times 0,1,2, or 3. forget it if ipct not 100
        mdrul = mod(irule,1111)
        if(ipct.lt.100)mdrul = 1
        konst = mod(irule,10)*5461
        iwrd1 = (ib-1)*20+(il+6)/7
        iwrdl = iwrd1+(it-ib)*20
c     attend to one column at a time
        do 30 j = il,ir
           ibyte = mod(j-1,7)+1
           if(mdrul.ne.0)go to 12
           if(skip.le.0)go to 5
           skip = skip-1
           go to 25
    5      if(ibyte.ne.1.or.ir-j.lt.6)go to 12
c     else do column of full words, then skip 6 columns
           do 10 k = iwrd1,iwrdl,20
   10        line(k) = konst
           skip = 6
           go to 25
   12      ifact = idiv(ibyte)
           iskip = mod(iskip+idlsk,198)
           do 15 k = iwrd1,iwrdl,20
              if(ipct.ge.100)go to 14
                 ip = ipont+iskip
                 ipont = ip-(ip/199)*199+1
                 if(iran(ipont).ge.iprob)go to 15
   14         i7 = line(k)
              idivd = i7/ifact
              ioldn = idivd-(idivd/4)*4
              newn = into(ioldn+1)
              line(k) = (idivd-ioldn+newn)*ifact+i7-(i7/ifact)*ifact
   15      continue
   25      if(ibyte.ne.7)go to 30
              iwrd1 = iwrd1+1
              iwrdl = iwrdl+1
   30   continue
      return
      end
#
c
c local operation.  works by expanding appropriate parts of 3 lines
c into top 3 tiers of /sngls/ , computes new line in bottom tier.
c effects do not propagate during one call
      subroutine locop(ix,iy,iw,ih,ipct,konts,nabrs,nums,irule)
#define maxary 2800
#include "common.h"
           logical okont(10),oknms(10),ok,frzzt
           integer mods(8),idel(8),ndel(8)
           data frzzt /.true./
           data mods(1),mods(2),mods(3),mods(4) /400,200,100,40/
           data mods(5),mods(6),mods(7),mods(8) /10,4,2,1/
           data idel(1),idel(2),idel(3),idel(4) /139,140,141,-1/
           data idel(5),idel(6),idel(7),idel(8) /1,-141,-140,-139/
        if(frzzt)call klear(frzzt)
           if(konts.gt.8888.or.konts.lt.0.or.nabrs.gt.757)return
           if(nabrs .lt.1.or.nums.gt.8888.or.nums.lt.0)return
        call rctfy (ix,iy,iw+2,ih+2,il,ir,ib,it,ok)
           if((.not.ok).or.irule.lt.0.or.irule.gt.3333)return
        ill = il+1
        irr = ir-1
        ibb = ib+1
        itt = it-1
           if(ibb.gt.itt.or.ill.gt.irr)return
        iprob = 2*ipct-ipct/51
        ipont = ne(1,199)
        iskip = ne(0,197)
        idlsk = ne(0,195)
        call setxl(irule)
c     zero out tables of counts, numbers
        do 10 j = 1,10
           oknms(j) = .false.
  10       okont(j) = .false.
c     set counts.  if zero is an ok count, it must be last
        k = konts/1000
        if(k.ne.0)okont(k+1) = .true.
        k = mod(konts/100,10)
        if(k.ne.0)okont(k+1) = .true.
        k = mod(konts/10,10)
        if(k.ne.0)okont(k+1) = .true.
        k = mod(konts,10)
        okont(k+1) = .true.
c     set numnb = number of neighbors, their delta-addresses into ndel
c     e.g. delta-address of neighbor up and right is +141
        n = nabrs
        numnb = 0
        do 16 j = 1,8
           if(n.lt.mods(j))go to 15
              numnb = numnb+1
              ndel(numnb) = idel(j)
  15       n = mod(n,mods(j))
  16    continue
c     set ok numbers.  if zero is ok, it must be last
        k = nums/1000
        if(k.ne.0) oknms(k+1) = .true.
        k = mod(nums/100,10)
        if(k.ne.0) oknms(k+1) = .true.
        k = mod(nums/10,10)
        if(k.ne.0) oknms(k+1) = .true.
        k = mod(nums,10)
        oknms(k+1) = .true.
c     expand first two lines and begin main processing loop
c     initially output = original line.  (xpand + cpress do full words)
        ifrst = ((il-1)/7)*7+1
        ilast = ((ir+6)/7)*7
        call xpand(il,ib,ir,280)
        call xpand(il,ib+1,ir,420)
  100   do 500 k = ibb,itt
           do 110 j = ifrst,ilast
              nm(j+140) = nm(j+280)
              nnn = nm(j+420)
              nm(j+280) = nnn
  110         nm(j) = nnn
           call xpand(il,k+1,ir,420)
c     process middle row
           iskip = mod(iskip+idlsk,198)
           do 200 l = ill,irr
              if(ipct.ge.100)go to 120
                 ip = ipont+iskip
                 ipont = ip-(ip/199)*199+1
                 if(iran(ipont) .ge.iprob)go to 200
  120         kcnt = 1
              ihere = 280+l
              do 300 m = 1,numnb
                 index = ihere+ndel(m)
                 kar = nm(index)+1
                 if(oknms (kar))kcnt = kcnt+1
  300         continue
              if(.not.okont(kcnt))go to 200
              kar = nm(l+280)
              nm(l) = into(kar+1)
  200      continue
           call cpres(ifrst,k,ilast)
  500   continue
      return
      end
#
c
c combine two areas.  i.e. transliterate contents of x,y,w,h according
c to 4 rules depending on contents of cells of area centered at kx,ky
      subroutine combn (ix,iy,iw,ih,ipct,kx,ky,iway,ir0,ir1,ir2,ir3)
#define maxary 2800
#include "common.h"
           integer ftrul(4,4),idiv(8),ixx(8),ixy(8),iyx(8),iyy(8)
           logical frzzt,ok
           data frzzt /.true./
           data idiv(1),idiv(2),idiv(3),idiv(4) /16384,4096,1024,256/
           data idiv(5),idiv(6),idiv(7),idiv(8) /64,16,4,1/
c     ixy is +1,0, or -1 depending on whether +1 in y on affected area
c     x,y,w,h corresp. to +1, 0, or -1 from pickup area (8 orientations)
           data ixx(1),ixx(2),ixx(3),ixx(4) / 1, 0,-1, 0/
           data ixx(5),ixx(6),ixx(7),ixx(8) /-1, 0, 1, 0/
           data ixy(1),ixy(2),ixy(3),ixy(4) / 0,-1, 0, 1/
           data ixy(5),ixy(6),ixy(7),ixy(8) / 0, 1, 0,-1/
           data iyx(1),iyx(2),iyx(3),iyx(4) / 0, 1, 0,-1/
           data iyx(5),iyx(6),iyx(7),iyx(8) / 0, 1, 0,-1/
           data iyy(1),iyy(2),iyy(3),iyy(4) / 1, 0,-1, 0/
           data iyy(5),iyy(6),iyy(7),iyy(8) / 1, 0,-1, 0/
        if(frzzt)call klear(frzzt)
c     rectify bounds, check validity of parameters
        call rctfy (ix,iy,iw,ih,il,ir,ib,it,ok)
           if(.not.ok)return
           if(min0(ir0,ir1,ir2,ir3).lt.0)return
           if(max0(ir0,ir1,ir2,ir3).gt.3333)return
           if(iway.lt.1.or.iway.gt.8.or.ipct.lt.1)return
c     initialize random skipping
        iprob = 2*ipct-ipct/51
        ipont = ne(1,199)
        iskip = ne(0,197)
        idlsk = ne(0,195)
c     initialize from-to transliteration matrix
        ftrul (1,1) = ir0
        ftrul (2,1) = ir1
        ftrul (3,1) = ir2
        ftrul (4,1) = ir3
        do 10 j = 1,4
           irule = ftrul(j,1)
           ftrul (j,1) = mod(mod(irule/1000,10),4)
           ftrul (j,2) = mod(mod(irule/ 100,10),4)
           ftrul (j,3) = mod(mod(irule/  10,10),4)
  10       ftrul (j,4) = mod(mod(irule     ,10),4)
c     do affected area column by column left to right
        do 20 j = il,ir
           ibyte = mod(j-1,7)+1
           index = 20*(ib-1)+(j+6)/7
           iskip = mod(iskip+idlsk,198)
c     start cursor(ixf,iyf) as displacement from kx,ky according to iway
           ixf = kx-(ix-j)*ixx(iway)-(iy-ib)*ixy(iway)
           iyf = ky-(iy-ib)*iyy(iway)-(ix-j)*iyx(iway)
           idivv = idiv(ibyte)
           mpy = idiv(ibyte+1)
c     process the column
           do 20 k = ib,it
              if(ipct.ge.100)go to 15
              mdarg = ipont+iskip
              ipont = mdarg-(mdarg/199)*199+1
              if(iran(ipont).ge.iprob)go to 18
  15       if(ixf.lt.1.or.ixf.gt.140.or.iyf.lt.1.or.iyf.gt.140)go to 18
c     do process the cell. fetch both, look up, replace if different
              ibt = ixf-1
              ibytf = ibt-(ibt/7)*7+1
              indxf = 20*(iyf-1)+(ixf+6)/7
              mdarg = line(indxf) /idiv(ibytf+1)
              numf = mdarg-(mdarg/4)*4
              i7 = line(index)
              mdarg = i7/mpy
              numt = mdarg-(mdarg/4)*4
              newn = ftrul(numf+1,numt+1)
              if(newn.eq.numt)go to 18
              line(index) = ((i7/idivv)*4+newn)*mpy+i7-(i7/mpy)*mpy
c     for next pass of inner loop, prepare to index, jog ixf,iyf cursor
  18          index = index+20
              ixf = ixf+ixy(iway)
              iyf = iyf+iyy(iway)
  20    continue
      return
      end
#
c
c rectify boundaries.  not ok if bottom above top, etc.
c input params  x, y, w, h.  output params left, right, bot, top, ok
      subroutine rctfy (inx,iny,inw,inh,il,ir,ib,it,ok)
           logical ok
        ok = .true.
           il = max0(1,inx-(inw-1) /2)
           ir = min0(140,inx+inw/2)
           ib = max0(1,iny-(inh-1)/2)
           it = min0(140,iny+inh/2)
           if(il.gt.ir.or.ib.gt.it)ok = .false.
      return
      end
#
c
c expands ix1,y-ix2,y into /sngls/ (full words). idel = 0,140,280,420
      subroutine xpand(ix1,iy,ix2,idel)
#define maxary 2800
#include "common.h"
        if(iy.lt.1.or.iy.gt.140)return
        minwd = max0(1,(ix1+6)/7)
        maxwd = min0(20,(ix2+6)/7)
        if(minwd.gt.maxwd)return
        index = minwd+20*(iy-1)
        idx = (minwd-1)*7+1+idel
        do 10 j = minwd,maxwd
           call splt(line(index),nm(idx))
           idx = idx+7
  10       index = index+1
      return
      end
#
c
c split word into 7 bytes.  may want machine language replacement
      subroutine splt(iword,ar)
           integer ar(7)
        i4096 = iword/4096
        i1024 = iword/1024
        i256  = iword/ 256
        i64   = iword/  64
        i16   = iword/  16
        i4    = iword/   4
           ar(1) = i4096-(i4096/4)*4
           ar(2) = i1024-(i1024/4)*4
           ar(3) = i256 -( i256/4)*4
           ar(4) = i64  -(  i64/4)*4
           ar(5) = i16  -(  i16/4)*4
           ar(6) = i4   -(   i4/4)*4
           ar(7) = iword-(iword/4)*4
      return
      end
#
c
c pack 7 numbers.  may want machine-language replacement
      integer function ipak(a)
           integer a(7)
        ipak = (((((a(1)*4+a(2))*4+a(3))*4+a(4))*4+a(5))*4+a(6))*4+a(7)
      return
      end
#
c
c
c
c inverse of xpand.  always compresses lowest tier of /sngls/
      subroutine cpres (ix1,iy,ix2)
#define maxary 2800
#include "common.h"
        if(iy.lt.1.or.iy.gt.140)return
        minwd = max0(1,(ix1+6)/7)
        maxwd = min0(20,(ix2+6)/7)
           if(minwd.gt.maxwd)return
        index = minwd+20*(iy-1)
        i = (minwd-1)*7+1
        do 10 j = minwd,maxwd
           line(index) = ipak(nm(i))
           i = i+7
  10       index = index+1
      return
      end
#
c
c decompose n into digits, set entries in xlit table
c used by chanj and locop
      subroutine setxl(n)
#define maxary 2800
#include "common.h"
           integer lastn
           data lastn /9999/
        if(n.eq.lastn)return
        lastn = n
        into(1) = mod(mod(n/1000,10),4)
        into(2) = mod(mod(n/ 100,10),4)
        into(3) = mod(mod(n/  10,10),4)
        into(4) = mod(mod(n     ,10),4)
      return
      end
#
c
c clear entire map to zeros at beginning of first map-changing op
      subroutine klear(frzzt)
#define maxary 2800
#include "common.h"
           logical first,frzzt
           data first/.true./
        frzzt = .false.
           if(.not.first)return
        first = .false.
        do 5 j = 1,maxary
    5      line(j) = 0
      return
      end
