!!  *** VZAP ***
!! V0.2 [01/03/83]: mods for IMP8
!! V0.3 [28/07/83]: mods for Fred board
!! V0.4 [17/06/84]: now uses EDWIN modes properly

%const %string (3) version = "0.4"

%record %format POINTFM (%integer X, Y)

%include "edwin:consts.inc"
%include "edwin:specs.inc"
%include "edwin:shapes.inc"
%include "Inc:maths.imp"

%begin

%constinteger middleButton=2, rightButton=4, leftButton=1
%conststring(20) defaults = ".BIC/%I1.BIC"
%externalintegerfnspec defStreams(%string(127) cli,defaults)

!! 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
%integer threshold;                     !! threshold for consideration
%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(pointfm) c1,c2,
                    %record(cpinf)%array pin(1:1000))
%constinteger cpinLen=2, chipLen=6

%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
%integer device;                        !! edwin device
%integer boardnsubs;                    !! number of chips
%integer boardxdim,boardydim;           !! size of board (in grids)
%integer boardnt;                       !! number of edge connectors
%string(255)%name circuitName;          !! name of circuit
%record(chiplistf)%name chips;          !! root of chip data structure
!%const %record(*)%name nil == 0;        !! end of lists
%record(netf)%name neth;                !! head of list of nets
%integer boardnnets;                    !! number of (ok) nets
%integer maxNetSize;                    !! largest net

!!*********************************!!
!! 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)
   %on 3,9 %start
      selectoutput(0)
      printstring("Premature end of file"); newline
      %stop
   %finish
   %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
   rch
   maxNetSize = -1
%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,ntail
   %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
   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
         %finish %else %if pno=size %start
            rnum(chip_c2_x); rnum(chip_c2_y)
            flush
         %finish %else %if pno=place %start
            rnum(chip_c1_x); rnum(chip_c1_y)
            flush
         %else
            skipString
         %finish
      %repeat
      chip_c2_x = chip_c2_x+chip_c1_x
      chip_c2_y = chip_c2_y+chip_c1_y
   %repeat

   copying = 0;                          ! stop transcribing
   neth == nil; boardnnets = 0; ntail == nil
   rch
   %while ch=ctrl+'N' %cycle
      net == getRecord(netLen)
      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
         rdec(nt)
         %for f = 1,1,nt %cycle
            rdec(subno); rdec(tno)
            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)
      %else
         %if ntail==nil %then neth == net %else ntail_link == net
         net_link == nil; ntail == net
         boardnnets = boardnnets+1
         net_name == stackString(netName)
         %if net_nt>maxNetSize %then maxNetSize = net_nt
      %finish
   %repeat
%end


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

%routine orderNets
   %record(netf)%name net

   %routine drawBoxes
      %integer f
      %record(chipf)%name chip
      newFrame
      set colour mode (or mode)
      setColour(Blue)
      %for f = 1,1,boardnsubs %cycle
         chip == chips_chip(f)
         rectangle(chip_c1_x, chip_c1_y, chip_c2_x, chip_c2_y)
      %repeat
   %end

   %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) cursorPin
      %record(pinf)%name pin
      %record(npinf)%name npin
      %integer f,g,d,nt,button,x,y,atx,aty,md,h,finishOff

      %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

      %routine blob(%integer x,y)
         rectangle (x-4, y-4, x+4, y+4)
      %end

      %routine drawNet(%record(netf)%name net)
         %integer f
         %record(pinf)%name pin
         %record(chipf)%name chip
         set colour (yellow)
         set colour mode (or mode)
         setColour(0)
         Drive device(12, 0, 0)
         Drive device(13, 1023, 1023)
         set colour mode (or mode)
         setcolour(red)
         %for f = 1,1,net_nt %cycle
            pin == pins(f)
            blob(pin_x,pin_y)
         %repeat
         moveAbs(0,0)
         text(net_name)
      %end

      %routine removeNet
         set colour (green)
         set colour mode (or mode)
         setColour(0)
         Drive device(12, 0, 0)
         Drive device(13, 1023, 1023)
         set colour mode (or mode)
      %end

      ! load up the pin array
      nt = net_nt
      %for f = 1,1,nt %cycle
         load(net_pin(f), pins(f))
      %repeat
      -> count %if nt<threshold

      ! display the net
      drawNet(net)
      setColour(green)
      moveAbs(pins(1)_x,pins(1)_y)
      lineAbs(pins(f)_x,pins(f)_y) %for f = 2,1,nt
      request input(button,x,y) %until button#0
      -> count %if button=leftButton {ok as it is}
restart:
      removeNet
      finishOff = 0
      visited(f) = 0 %for f = 1,1,nt
      %for f = 1,1,nt %cycle
         finishOff = 1 %if f=nt
         %cycle
            %if finishOff=0 %start
               request input(button,x,y)
               -> restart %if button=rightButton
               %if button&(middlebutton+leftbutton)=(middlebutton+leftbutton) %start
                  finishOff = 1 %if button=middleButton+rightButton+leftbutton
                  button = middleButton
                  x = atx %and y = aty %if f#1
               %finish
            %else
               button = middleButton; x = atx; y = aty
            %finish
         %repeat %until button=middleButton
         cursorPin_x = x; cursorPin_y = y
         md = maxint
         %for h = 1,1,nt %cycle
            %continue %unless visited(h)=0
            pin == pins(h)
            d = metric(pin,cursorPin)
            %if d<md %start
               g = h; md = d
            %finish
         %repeat
         pin == pins(g)
         setColour(green); blob(pin_x,pin_y)
         %if f#1 %start
            moveAbs(atx,aty)
            lineAbs(pin_x,pin_y)
         %finish
         atx = pin_x; aty = pin_y
         visited(g) = f
      %repeat
      %cycle
         request input(button,x,y)
         -> restart %if button=rightbutton
      %repeat %until button=left button
      %for f = 1,1,nt %cycle
         load(net_pin(f),pins(visited(f)))
      %repeat

count:
      d = 0
      %for f = 2,1,nt %cycle
         d = d + metric(pins(f-1),pins(f))
      %repeat
      net_length = d
      %return %if nt<threshold

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

   drawBoxes
   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)
selectinput(report)
printstring("VZAP version "); printstring(version); newline
device = default device
initialise for (device)
print string ("Terminal set to ");   print string (device data_name);   newline
prompt("Threshold: ")
read(threshold)
threshold = 2 %if threshold<2
newline
printstring("Buttons on mouse are:"); newline
printstring("RIGHT  reject current route"); newline
printstring("MIDDLE join to point nearest mouse"); newline
printstring("LEFT   accept current completed route"); newline
printstring("M + L  join to nearest neighbour"); newline
printstring("L+M+R  join rest up on nearest neighbour basis"); newlines(2)

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

! read in the circuit and construct spanning trees
readIcode
window(0,boardxdim,0,boardydim)

orderNets
newframe
terminateEdwin

neth == sort(neth)

outputNets

%endofprogram
