!!  *** ZAP ***
!! V0.2 [01/03/83]: mods for IMP8
!! V0.3 [05/06/85]: error trap {jhb}

%conststring(6) version = "0.3"

%begin

%conststring(20) defaults = ".BIC/%I1.BIC"
%externalintegerfnspec defStreams(%string(127) cli,defaults)
!%externalrealfnspec sqrt(%real n)


!! streams
%constinteger icode=1, report=0, results=1


!! machine dependent constants
%constinteger maxint = 20000000;        !! largest positive integer
%constinteger laupw=2;                  !! log addressing units per word
%constinteger cpw=4;                    !! characters per word
%constinteger lcpw=2;                   !! log characters per word
%constinteger sipw=2;                   !! shortintegers per word (1 or 2)


!! parameterisation
%owninteger tracing = 0;                !! diagnostic information control
%constinteger stackLen = 50000;         !! length of stack (in words)


!! character interface
%constinteger ctrl=128,   cntrlchar='^',   end of file=-1
%constinteger end of string=-1
%integer copying;                       !! non-zero if copying in->out
%integer col;                           !! column of output


!! I-code constants
%constinteger at=1,   on=2,   size=7,   place=8


!! recordformats and constants for data strucures
%recordformat cpinf(%integer x,y)
%recordformat chipf(%string(255)%name name, %integer nt,
                    %record(cpinf)%array pin(1:1000))
%constinteger cpinLen=2, chipLen=2

%recordformat chiplistf(%record(chipf)%namearray chip(0:1000))

%recordformat npinf(%shortinteger subno,tno)
%recordformat netf(%record(netf)%name link, %integer length,
                   %string(255)%name name, %integer nt,
                   %record(npinf)%array pin(1:1000))
%constinteger npinLen=2//sipw, netLen=4


!! work stack
%integerarray stack(0:stackLen)
%integer tos;                           !! increasing, used for records
%integer bos;                           !! decreasing, used for strings


!! I-code interface routines
%integer baseTime = cpuTime;            !! cpu time on entry to program
%integer stringLen;                     !! length of current string
%integer ch;                            !! current i-code character
%integer pending;                       !! pending character


!! global values pertaining to the data structure
%constinteger left=0, right=1;          !! hands
%integer hand;                          !! handedness of zapper
%integer boardnsubs;                    !! number of chips
%integer boardxdim,boardydim;           !! size of board (in grids)
%integer boardnt;                       !! number of edge connectors
%integer maxNetSize;                    !! largest net in circuit
%string(255)%name circuitName;          !! name of circuit
%record(chiplistf)%name chips;          !! root of chip data structure
%record(*)%name nil;                    !! end of lists
%record(netf)%name neth;                !! head of list of nets
%integer boardnnets;                    !! number of (ok) nets

!!*********************************!!
!! routines for managing the stack !!
!!*********************************!!

%routine claim(%integer nwords)
! take nwords off the top of the stack
   tos = tos+nwords<<laupw
%end

%routine check(%integer nwords)
! check that nwords of stackspace are remaining
   %if tos>>laupw+nwords>=bos %start
      printstring("* workspace of ");
      write(stackLen,0)
      printstring(" words exhausted")
      %stop
   %finish
%end

%record(*)%map getRecord(%integer nwords)
   %record(*)%name r
   check(nwords)
   r == record(tos)
   claim(nwords)
   %result == r
%end


!!*********************!!
!! diagnostic routines !!
!!*********************!!

%routine pstring(%string(63) what)
   selectoutput(report)
   printstring(what); newline
   selectoutput(results)
%end

%routine pdec(%integer n)
   write(n,0)
%end

%routine pcpu
   %integer n
   n = (cpuTime-baseTime)//100
   write(n//10,0)
   printsymbol('.')
   printsymbol(rem(n,10)+'0')
   printsymbol('s')
%end

%routine pco(%integer x,y)
   printsymbol('['); write(x,0); printsymbol(',')
   write(y,0); printsymbol(']')
%end


!!*****************!!
!! useful routines !!
!!*****************!!

%integerfn sign(%integer x)
   %result = -1 %if x<0
   %result = 1 %if x>0
   %result = 0
%end

%routine swop(%integername x,y)
   %integer t
   t = x; x = y; y = t
%end

%integerfn min(%integer x,y)
   %result = x %if x<=y
   %result = y
%end

%integerfn max(%integer x,y)
   %result = x %if x>=y
   %result = y
%end

%integerfn pos(%integer n)
   n = 0 %if n<0
   %result = n
%end

%routine order(%integername l,h)
   swop(l,h) %if l>h
%end


!!**********************************!!
!! routines for handling the i-code !!
!!**********************************!!

%routine psym(%integer ch)
   %owninteger nlAllowed = 1
   %return %if ch=nl
   %if nlAllowed#0 %and col>65 %start
      newline; col = 0
   %finish
   printsymbol(ch)
   col = col+1
   nlAllowed = 1
   nlAllowed = 0 %if ch='^' %or '0'<=ch<='9' %or ch='-'
%end

%routine pinum(%integer n)
   %if n<0 %then psym('-') %and pinum(-n) %c
   %else %start
      %if n>=10 %then pinum(n//10)
      psym(rem(n,10)+'0')
   %finish
%end

%routine pistring(%string(255) s)
   %integer f
   pinum(length(s))
   psym(':')
   %for f = 1,1,length(s) %cycle
      psym(charno(s,f))
   %repeat
%end

%routine rsym(%integername ch)
   %if pending#0 %start
      ch = pending; pending = 0; %return
   %finish
   readsymbol(ch)
   psym(ch) %if copying#0
%end

%routinespec rdec(%integername n)

%routine rch
! put next input character into ch, ignoring comments and
! reconstucting control characters
   %integer i,   len
   %on 3,9 %start
      ch=end of file
      %return
   %finish
   %cycle
      rsym(ch) %until ch#nl
      %if ch=cntrlchar %start
         rsym(ch);   ch=ch+ctrl
         %exit %if ch#ctrl+'k'
         ! discard comment
         rdec(len);   rch
         rch %for i=1,1,len
      %finish %else %exit
   %repeat
%end

%routine rdec(%integername n)
   %integer ch,s
   s = 1
   rsym(ch) %until ch#nl %and ch#' '
   %if ch='-' %then s = -1 %and rsym(ch)
   n = 0
   %cycle
      %exit %unless '0'<=ch<='9'
      n = n*10+ch-'0'
      rsym(ch)
   %repeat
   n = n*s
   pending = ch
%end

%routine initialise
   selectinput(icode)
   selectoutput(results)
   pending = 0
   stringLen = -1
   col = 0; copying = 1
   maxNetSize = -1
   rch
%end

%routine getch
! read next (or perhaps first) character from an i-code string
   rdec(stringLen) %and rch %if stringLen<0
   ch=end of string %and %return %if stringLen=0
   rch
   stringLen=stringLen-1
%end

%routine flush
! discard remainder of an i-code string
   getch %while stringLen>0
   stringLen=-1
%end

%routine rnum(%integername result)
! read a signed decimal integer from within an i-code string
   %integer sign,   n
   getch
   %if ch='-' %then sign=-1 %and getch %else sign=1
   n=0
   %while '0'<=ch<='9' %cycle
      n=n*10+ch-'0'
      getch
   %repeat
   n=-n %if sign<0
   result=n
%end

%string(255)%map stackString(%string(255) s)
! stack a string and map it
   %integer i,l
   %string(255)%name sn
   l = length(s)
   check((l+cpw)>>lcpw)
   bos = bos-(l+cpw)>>lcpw
   sn == string(bos<<laupw)
   sn = s
   %result == sn
%end

%string(255)%fn readString
! read an i-code string but do not stack it
   %string(255) s
   %integer i
   rdec(stringLen) %and rch %if stringLen<0
   s = ""
   %for i = 1,1,stringLen %cycle
      rch;  s = s.tostring(ch)
   %repeat
   stringLen = -1
   %result = s
%end

%string(255)%map storeString
   %result == stackString(readString)
%end

%routine skipNum
! discard an i-code number
   %integer discard
   rdec(discard)
%end

%routine skipString
! discard an i-code string
   getch; flush
%end


!!*****************************************!!
!! read in i-code and build data structure !!
!!*****************************************!!

%routine readIcode
   ! read in all the i-code for the board and build a data
   ! structure.  the data structure consists of a vector
   ! chips which locates each chip on the board, and a list
   ! of nets headed by neth which enumerates all the nets.
   ! many of the global variables such as boardnsubs or
   ! groundNet are also given their values
   %integer nt,f,pno,subno,tno,n,x,y,g,md,mf,mg,d
   %record(cpinf)%name cpin,cpin2
   %record(chipf)%name chip,edges
   %record(netf)%name net
   %record(npinf)%name npin
   %string(255) netName,netPartname

   initialise

   rch %while ch#ctrl+'H';              ! flags, type etc
   rdec(boardnt) %for f = 1,1,5;        ! opt,nin,nout,nio,nt
   circuitName == storeString
   pstring(circuitName) %if tracing&1#0
   skipString;                          ! board name

   edges == getRecord(chipLen)
   edges_name == circuitname
   edges_nt = boardnt
   %for tno = 1,1,boardnt %cycle
      rch; skipNum;                     ! ^T info
      cpin == getRecord(cpinLen)
      rnum(cpin_x); rnum(cpin_y)
      %if ch='+' %start
         selectoutput(report)
         printstring("Multiple occurrence of signal on edge ignored")
         newline
         selectoutput(results)
      %finish
      flush
      skipString;                       ! signal name
   %repeat
   
   boardxdim = 0; boardydim = 0
   rch
   %while ch=ctrl+'P' %cycle
      rdec(pno)
      %if pno=size %start
         rnum(boardxdim); rnum(boardydim); flush
         boardxdim = boardxdim-1; boardydim = boardydim-1
      %else
         skipString
      %finish
      rch
   %repeat

   rch;                                 ! ^J
   rdec(boardnsubs)
   chips == getRecord(boardnsubs+1)
   chips_chip(0) == edges
   %for subno = 1,1,boardnsubs %cycle
      chip == getRecord(chipLen)
      chips_chip(subno) == chip
      rch;                              ! ^H
      rdec(nt) %for f = 1,1,5;          ! opt,nin,nout,nio,nt
      skipString;                       ! chip name
      skipString;                       ! chip type
      chip_nt = nt
      %for tno = 1,1,nt %cycle
         rch; skipNum;                  ! flags
         cpin == getRecord(cpinLen)
         rnum(cpin_x); rnum(cpin_y)
         flush;                         ! pin name
         skipString;                    ! signal name
      %repeat
      %cycle
         rch
         %exit %unless ch=ctrl+'P'
         rdec(pno)
         %if pno=at %start
            chip_name == storeString;    ! name of slot on board
            pstring(chip_name) %if tracing&1#0
         %else
            skipString
         %finish
      %repeat
   %repeat

   copying = 0;                          ! stop transcribing
   neth == nil; boardnnets = 0
   rch
   %while ch=ctrl+'N' %cycle
      net == getRecord(netLen)
      net_link == neth; neth == net
      net_nt = 0; net_length = 0
      netName = ""
      rch
      %while ch=ctrl+'A' %cycle
         netPartName = readString
         %if netName="" %then netName = netPartName %c
                        %else netName = netName."_&_".netPartName
         pstring("Net ".netPartName) %if tracing&1#0
         rdec(nt)
         %for f = 1,1,nt %cycle
            rdec(subno); rdec(tno)
{jhb}       %unless 0<=subno<=1000 %and 1<=tno<=1000 %start
{jhb}          selectoutput(report)
{jhb}          printstring("Pin reference out of range: NT")
{jhb}          write(nt, 3); printstring(" Subno"); write(subno, 3)
{jhb}          printstring(" Tno"); write(tno, 3); newline
{jhb}          %stop
{jhb}       %finish
            cpin == chips_chip(subno)_pin(tno)
            x = cpin_x; y = cpin_y
            %for g = 1,1,net_nt %cycle
               npin == net_pin(g)
               cpin2 == chips_chip(npin_subno)_pin(npin_tno)
               -> omit %if cpin2_x=x %and cpin2_y=y
            %repeat
            net_nt = net_nt+1
            npin == getRecord(npinLen)
            npin_subno = subno; npin_tno = tno
omit:
         %repeat
         rch
      %repeat
      %if net_nt<=1 %start
         selectoutput(report)
         printstring(netName); printstring(" degenerate"); newline
         selectoutput(results)
         neth == neth_link
      %else
         boardnnets = boardnnets+1
         net_name == stackString(netName)
         %if net_nt>maxNetSize %then maxNetSize = net_nt
      %finish
   %repeat
   %if ch#ctrl+'E' %start
      printstring("Broken i-code"); newline
      %stop
   %finish
%end


!!***************!!
!! ordering nets !!
!!***************!!

%routine orderNets
   %record(netf)%name net

   ! permutations of 1-5 in which 1 is left of 2
   %constintegerarray permute(0:60*5-1) = %c
      1,2,3,4,5, 1,3,2,4,5, 3,1,2,4,5,
      1,2,4,3,5, 1,3,4,2,5, 3,1,4,2,5,
      1,4,2,3,5, 1,4,3,2,5, 3,4,1,2,5,
      4,1,2,3,5, 4,1,3,2,5, 4,3,1,2,5,
      1,2,3,5,4, 1,3,2,5,4, 3,1,2,5,4,
      1,2,4,5,3, 1,3,4,5,2, 3,1,4,5,2,
      1,4,2,5,3, 1,4,3,5,2, 3,4,1,5,2,
      4,1,2,5,3, 4,1,3,5,2, 4,3,1,5,2,
      1,2,5,3,4, 1,3,5,2,4, 3,1,5,2,4,
      1,2,5,4,3, 1,3,5,4,2, 3,1,5,4,2,
      1,4,5,2,3, 1,4,5,3,2, 3,4,5,1,2,
      4,1,5,2,3, 4,1,5,3,2, 4,3,5,1,2,
      1,5,2,3,4, 1,5,3,2,4, 3,5,1,2,4,
      1,5,2,4,3, 1,5,3,4,2, 3,5,1,4,2,
      1,5,4,2,3, 1,5,4,3,2, 3,5,4,1,2,
      4,5,1,2,3, 4,5,1,3,2, 4,5,3,1,2,
      5,1,2,3,4, 5,1,3,2,4, 5,3,1,2,4,
      5,1,2,4,3, 5,1,3,4,2, 5,3,1,4,2,
      5,1,4,2,3, 5,1,4,3,2, 5,3,4,1,2,
      5,4,1,2,3, 5,4,1,3,2, 5,4,3,1,2

   %routine orderNet(%record(netf)%name net)
      %recordformat pinf(%short subno,tno, %integer x,y)
      %record(pinf)%array pins(1:maxNetSize)
      %byteintegerarray visited(1:maxNetSize)
      %record(pinf)%name pin
      %record(npinf)%name npin
      %integer f,nt,forw,back,at,x,distance,g,n,b,md,mp,d,mx,my,
               next,h,mind,nearest,mmd
      %integerarray triDist(1:(maxNetSize*(maxNetSize-1))//2)

      %integermap dist(%integer f,g)
          %integer t
          order(g,f)
          t = ((f-1)*(f-2))//2+g
          %result == triDist(t)
      %end

      %routine load(%record(npinf)%name npin, %record(pinf)%name pin)
         %record(cpinf)%name cpin
         pin_subno = npin_subno; pin_tno = npin_tno
         cpin == chips_chip(npin_subno)_pin(npin_tno)
         pin_x = cpin_x; pin_y = cpin_y
      %end

      %integerfn metric(%record(pinf)%name p1,p2)
         %real sumsq,x,y
         x = |p1_x-p2_x|; y = |p1_y-p2_y|
         sumsq = x*x + y*y
         %result = int(sqrt(sumsq))
      %end

      %if tracing&2#0 %then pstring("Ordering ".net_name)
      ! load up the pin array
      nt = net_nt
      %for f = 1,1,nt %cycle
         load(net_pin(f), pins(f))
      %repeat
      ! load up the distance matrix
      mx = maxint; my = maxint
      %for f = 1,1,nt %cycle
         visited(f) = 0
         pin == pins(f)
         %if pin_x<mx %or (pin_x=mx %and pin_y<my) %start
            mp = f; mx = pin_x; my = pin_y
         %finish
         %for g = f+1,1,nt %cycle
            d = metric(pins(f),pins(g))
            dist(g,f) = d
         %repeat
      %repeat

      ! decide on an undirected route
      %if 2<nt<=5 %start
         ! perfect solution (3, 4 and 5 pins)
         %if nt=5 %then n = 59 %else %if nt=4 %then n = 11 %else n = 2
         md = maxInt
         %for f = 0,1,n %cycle
            b = f*5; d = 0
            at = permute(b)
            %for g = 1,1,nt-1 %cycle
               next = permute(b+g)
               d = d+dist(at,next)
               at = next
            %repeat
            %if d<md %start
               md = d; mp = f
            %finish
         %repeat
         ! put back the best route
         b = mp*5
         %for f = 1,1,nt %cycle
            load(net_pin(permute(b+f-1)), pins(f))
         %repeat
      %finish %else %if 20>=nt>5 %start
         ! large net solution
         ! algorithm is start in bottom left
         visited(mp) = 1
         %for f = 2,1,nt %cycle
            at = mp; x = pins(at)_x
            md = maxint
            %for g = 1,1,nt %cycle
               %continue %if visited(g)#0
               d = dist(g,at)
               mx = pins(g)_x
               %if mx<=x %then d = d//3
               %if d<md %then md = d %and mp = g
            %repeat
            visited(mp) = f
         %repeat
         %for f = 1,1,nt %cycle
            load(net_pin(f),pins(visited(f)))
         %repeat
      %finish

      ! choose the direction
      forw = 0; at = pins(1)_x; d = 0
      %for f = 2,1,nt %cycle
         x = pins(f)_x
         %if (hand=right %and x>at) %c
         %or (hand=left %and x<at) %then forw = forw+1
         d = d + metric(pins(f-1),pins(f))
      %repeat
      net_length = d
      back = 0; at = pins(nt)_x
      %for f = nt-1,-1,1 %cycle
         x = pins(f)_x
         %if (hand=right %and x>at) %c
         %or (hand=left %and x<at) %then back = back+1
      %repeat

      ! put the route back into the net
      %for f = 1,1,nt %cycle
         pin == pins(f)
         g = f
         %if back<forw %then g = nt-f+1
         npin == net_pin(g)
         npin_subno = pin_subno; npin_tno = pin_tno
      %repeat
   %end

   net == neth
   %while net##nil %cycle
      orderNet(net)
      net == net_link
   %repeat
%end


!!***********!!
!! sort nets !!
!!***********!!

%record(netf)%map sort(%record(netf)%name head)
! quicksort the nets into ascending length
   %recordformat bitf(%record(netf)%name head,tail)
   %record(bitf) data
   %record(netf)%name stick,st

   %routine stickSubSort(%record(bitf)%name data)
      %record(netf)%name this,next
      %record(bitf) less,equal,greater
      %integer median,v

      %routine move(%record(netf)%name stick, %record(bitf)%name bit)
         stick_link == nil
         %if bit_head==nil %then bit_head == stick %c
                            %else bit_tail_link == stick
         bit_tail == stick
      %end

      %routine join(%record(bitf)%name first,second)
         %if first_head==nil %then first_head == second_head %c
                              %else first_tail_link == second_head
         first_tail == second_tail %unless second_head==nil
      %end

      less_head == nil; equal_head == nil; greater_head == nil
      this == data_head; next == this_link
      median = this_length
      move(this,equal)
      %while next##nil %cycle
         this == next; next == next_link
         v = this_length
         %if v=median %then move(this,equal) %c
         %else %if v<median %then move(this,less) %c
         %else move(this,greater)
      %repeat
      %if less_head##nil %then stickSubSort(less)
      %if greater_head##nil %then stickSubSort(greater)
      data_head == nil
      join(data,less); join(data,equal); join(data,greater)
   %end

   data_head == head
   stickSubSort(data) %unless head==nil
   %result == data_head
%end


!!*****************!!
!! outputting nets !!
!!*****************!!

%routine outputNets
   %record(netf)%name net
   %integer f
   net == neth
   selectoutput(results)
   %while net##nil %cycle
      psym('^'); psym('N')
      psym('^'); psym('A')
      pistring(net_name)
      pinum(net_nt)
      %for f = 1,1,net_nt %cycle
         psym(' '); pinum(net_pin(f)_subno)
         psym(' '); pinum(net_pin(f)_tno)
      %repeat
      net == net_link
   %repeat
   psym('^'); psym('E'); newline
%end

!! main program
%integer f

%if defStreams(cliParam,defaults)#1 %then %stop
selectoutput(report)
printstring("ZAP version "); printstring(version); newlines(2)
selectinput(0); prompt("Hand (L or R): ")
%cycle
   readsymbol(ch)
   %if 'a'<=ch<='z' %then ch = ch-'a'+'A'
   %continue %if ch=' '
   %if '0'<=ch<='9' %then tracing = ch-'0'
   %exit %if ch='L' %or ch='R'
%repeat
hand = right
%if ch='L' %then hand=left
readsymbol(ch) %until ch=nl

nil == record(0)
tos = addr(stack(0))
bos = addr(stack(stackLen))>>laupw+1

! read in the circuit and construct spanning trees
readIcode
selectoutput(report)
printstring("Circuit "); printstring(circuitName)
printstring(" with "); pdec(boardnsubs); printstring(" packages")
printstring(" and "); pdec(boardnnets); printstring(" nets")
newline

orderNets

neth == sort(neth)

outputNets

%endofprogram
