%begin; ! ESDL:L1SKETCH

!include "inc:dict.imp"
%include "inc:util.imp"
%include "inc:level1.imp"

!ESDL -> ^S [0:eic,1:fic,2:cic,3:bic] UNIT*
!UNIT -> ^U [1:spec,2:unit,3:chip,4:board,5:pack] HEAD UNIT*
!        ^J nsubs HEAD* {^N{^A netname nfans {subno tno}*}+}*
!        ^E
!HEAD -> ^H0 nin nout nio nt label name
!        {^T tno<<2+[0:dup,1:out,2:in,3:inout] coords/pinname signalname}*
!        {^P [1:at,2:on,3:pack,4:subpack,5:delay,6:value,7:size,8:place] parm}*
!        ^G

!  Clipping, scaling, zooming

%integer xoffset=0,yoffset=0
%real xscale=1,yscale=1
%integer vl = 0,vr = 688,vb = 0,vt = 512; !Viewport (physical coordinates)
%integer wl = 0,wr = 688,wb = 0,wt = 512; !Window   (virtual  coordinates)
%real screen aspect ratio = ((vt-vb)*4)/((vr-vl)*3)

%routine scale(%integername x,y); !Map to device coords
  x = intpt(x*xscale)+xoffset
  y = intpt(y*yscale)+yoffset
%end

%routine align window with viewport
! Make sure scaled middle of virtual window
! maps to middle of device window
%integer vx = (vl+vr)//2, vy = (vb+vt)//2
%integer wx = (wl+wr)//2, wy = (wb+wt)//2
  xoffset = 0; yoffset = 0; scale(wx,wy)
  xoffset = vx-wx; yoffset = vy-wy
%end

%routine aspect ratio
%real f
  f = |yscale/xscale/screen aspect ratio|
  %if f>1 %then yscale = yscale/f %else xscale = xscale*f
  align window with viewport
%end

%routine compute scalings
  xscale = (vr-vl)/(wr-wl)
  yscale = (vt-vb)/(wt-wb)
  aspect ratio
%end

%routine viewport(%integer x1,y1,x2,y2)
  vl = x1; vb = y1; vr = x2; vt = y2
  compute scalings
%end

%routine window(%integer x1,y1,x2,y2)
  wl = x1; wr = x2; wt = y2; wb = y1
  compute scalings
%end

%routine zoom(%integer tx,ty,%real f)
! TX, TY are the centre of the new window
%integer wx = intpt((wr-wl)/f)
%integer wy = intpt((wt-wb)/f)
  wl = tx-wx//2; wr = wl+wx
  wb = ty-wy//2; wt = wb+wy
  compute scalings
%end

%integerfn clipcode(%integer x,y)
%integer c=0
  c = 1 %if x<vl
  c = c+2 %if x>vr
  c = c+4 %if y<vb
  c = c+8 %if y>vt
  %result=c
%end

%routine clipped line(%integer x1,y1,x2,y2)
%integer c1 = clipcode(x1,y1)
%integer c2 = clipcode(x2,y2)
%integer dx,dy

  %routine into range(%integername x,y)
    y = intpt((vl-x)*dy/dx)+y %and x = vl %if x<vl
    y = intpt((vr-x)*dy/dx)+y %and x = vr %if x>vr
    x = intpt((vb-y)*dx/dy)+x %and y = vb %if y<vb
    x = intpt((vt-y)*dx/dy)+x %and y = vt %if y>vt
  %end

  %returnunless c1&c2=0
  %unless c1!c2=0 %start
    dx = x2-x1; dy = y2-y1
    into range(x1,y1)
    into range(x2,y2)
  %finish
  line(x1,y1,x2,y2)
%end

%routine scaled line(%integer x1,y1,x2,y2)
  scale(x1,y1); scale(x2,y2)
  clipped line(x1,y1,x2,y2)
%end

%routine clipped fill(%integer x1,y1,x2,y2)
%integer c1 = clipcode(x1,y1)
%integer c2 = clipcode(x2,y2)

  %routine sw(%integername a,b)
  %integer c
    c = a; a = b; b = c
  %end

  %returnunless c1&c2=0
  sw(x1,x2) %if x1>x2
  sw(y1,y2) %if y1>y2
  x1 = vl %if x1<vl
  y1 = vb %if y1<vb
  x2 = vr %if x2>vr
  y2 = vt %if y2>vt
  fill(x1,y1,x2,y2)
%end

%routine scaled fill(%integer x1,y1,x2,y2)
  scale(x1,y1); scale(x2,y2)
  clipped fill(x1,y1,x2,y2)
%end

%recordformatspec pinf
%recordformatspec netf

%recordformat chipf(%record(chipf)%name next,%record(pinf)%name pins,
                    %integer name,type,pack,on,at,wide,high,x,y)
%recordformat pinf(%record(pinf)%name nextinchip,nextinnet,
                   %record(chipf)%name chip,%record(netf)%name net,
                   %integer number,flags,pin,signal,index,x,y)
%recordformat netf(%record(netf)%name nextnet,nextsubnet,net,
                   %record(pinf)%name pins, %integer signal,index)

%constinteger pat=1,on=2,pack=3,subpack=4,delay=5,value=6,size=7,place=8

%integer i
%integer ztop,zbot
%string(255)file
%owninteger state=0
%integer ww,hh
%integer curx=0,cury=0,curs=10
%record(chipf)%name chips == nil
%record(netf)%name nets
%integer sym;          !Current I-code symbol
%string(255)s;         !Current I-code string
%integer si;           !Signal name index, normally -1, but for
                       !a signal A<17>, si would be 17 and s A

  %onevent 3,9 %start
    selectoutput(0);printstring(event_message);newline
    %stopunless state=1
    openinput(0,":"); selectinput(0)
    state=2
    ->mainloop
  %finish

! Colours:
!
! Background     Blue
! Board          Black
! Chips          Green
! Pins           Yellow
! Power pads     Red
! Ground pads    Blue
! Through pads   White
! Cursor         Complement

%record(*)%map reverse(%record(*)%name list)
%recordformat f(%record(f)%name next)
%record(f)%name head,tail,temp
  head == list; tail == nil; %result == nil %if list==nil
  %cycle
    temp==head; head==temp_next; temp_next==tail; tail==temp
  %repeatuntil head==nil
  %result==tail
%end

!  Drawing stuff

%routine draw pads(%record(pinf)%name p)
%on8%start;%return;%finish
  colour(yellow)
  %while p##nil %cycle
    scaled fill(p_x-2,p_y-2,p_x+2,p_y+2)
    p == p_nextinchip
  %repeat
%end

%routine draw chip(%record(chipf)%name c)
  colour(green)
  scaled fill(c_x,c_y,c_x+c_wide,c_y+c_high)
  draw pads(c_pins)
%end

%routine draw chips(%record(chipf)%name c)
  %while c##nil %cycle
    draw chip(c); c == c_next
  %repeat
%end

%routinespec putstring(%integer tag)
%routinespec putindex(%integer index)

%routine draw net(%record(netf)%name n)
%record(pinf)%name p
%integer x0,y0,x1,y1
  colour(8); enable(\7)
!{}printstring("Drawing ");putstring(n_signal);putindex(n_index);newline
  %while n##nil %cycle
    p == n_pins
    %unless p==nil %start
      x0 = p_x; y0 = p_y; p == p_nextinnet
      %while p##nil %cycle
        x1 = p_x; y1 = p_y
        scaled line(x0,y0,x1,y1)
        x0 = x1; y0 = y1
        p == p_nextinnet
      %repeat
    %finish
    n == n_nextsubnet
  %repeat
  enable(\0)
%end

%routine draw nets(%record(netf)%name n)
  %while n##nil %cycle
    draw net(n); n == n_nextnet
  %repeat
%end

%predicate global(%record(netf)%name net)
  %falseif net_signal=0
  %trueif byte(net_signal+1)='.'
  %false
%end

%routine draw chip nets(%record(chipf)%name chip)
%record(pinf)%name pin
  pin == chip_pins
  %while pin##nil %cycle
    %unless pin_net==nil %start
      draw net(pin_net) %unless global(pin_net)
    %finish
    pin == pin_next in chip
  %repeat
%end

!  I-code input etc

%routine readsym
  readsymbol(sym) %until sym#nl
  %returnunless sym='^'
  readsymbol(sym); sym=sym+'^'<<8
%end

%routine verify(%integer want)
  %routine p(%integer x)
    printsymbol(x>>8) %unless x>>8=0
    printsymbol(x)
  %end
  %returnif sym=want
  selectoutput(0); printstring("** Got ")
  p(sym); printstring(" when expecting "); p(want)
  newline; %stop
%end

%routine readstring
%integer indexed=0
%integer len,i
  si = -1
  read(len); readsym; verify(':')
  length(s) = len
  %for i=1,1,len %cycle
    readsym
    indexed = i %if indexed=0 %and sym='<'
!    %if sym='<' %start; !Indexed signal name
!      read(si); readsym; verify('>')
!      length(s) = i-1; %return
!    %finish
    charno(s,i) = sym
  %repeat
  %if indexed#0 %start
    length(s) = indexed-1
    si = 0
    %cycle
      indexed = indexed+1; i = charno(s,indexed)-'0'
      %exitunless 0<=i<=9
      si = si*10+i
    %repeat
  %finish
%end

%integerfn codestring
%recordformat stringfm(%record(stringfm)%name next,%string(255)s)
%ownrecord(stringfm)%name stringlist == nil
%record(stringfm)%name this
  %result = 0 %if length(s)=0
  this == stringlist
  %while this##nil %cycle
    %result = addr(this_s) %if this_s=s
    this == this_next
  %repeat
  this == record(heapget(sizeof(this)-255+length(s)))
  this_next == stringlist
  stringlist == this
  this_s = s
  %result = addr(this_s)
%end

%routine putstring(%integer tag)
  %returnif tag=0
  printstring(string(tag))
%end

%integerfn getnum; !From string s
%integer n=0,sign=0,pos=1
  %while pos<=length(s) %cycle
    sym = charno(s,pos); pos = pos+1
    %if sym='-' %start
      sign = 1
    %finishelseif '0'<=sym<='9' %start
      n = n*10-'0'+sym
    %finishelseexit
  %repeat
  s = substring(s,pos,length(s))
  %result = n %if sign=0
  %result=-n
%end

%routine putindex(%integer i)
  %returnif i<0
  printsymbol('<'); write(i,0); printsymbol('>')
%end

%record(netf)%map readnets
  %record(netf)%map readsubnets
  %record(netf)%name head,tail
  %record(pinf)%name p,term
  %record(chipf)%name sub
  %integer nfans,subno,tno
    tail == nil
    %while sym='^A' %cycle
      head == new(head); head = 0
      head_nextsubnet == tail; tail == head
      readstring; head_signal = codestring; head_index = si
      read(nfans); p == nil
!{}printstring("Reading ");putstring(head_signal);putindex(head_index)
!{}write(nfans,1);printstring(" fans");newline
      %while nfans>0 %cycle
        nfans = nfans-1; read(subno); read(tno)
!{}write(nfans+1,0);printsymbol(':');write(subno,0);printsymbol('_');write(tno,0)
        sub == chips; sub == sub_next %and subno = subno-1 %while subno>0
!{}space;putstring(sub_name);putstring(sub_pack);putstring(sub_at)
        term == sub_pins; term == term_nextinchip %while term_number#tno
!{}space;putstring(term_pin);space;putstring(term_signal);putindex(term_index)
!{}newline
        %if term_flags&4=0 %start
          term_flags = term_flags!4; term_net == head
          term_nextinnet == p; p == term
        %finishelseunless term_net==head %start
          printstring("Terminal"); write(term_number,1)
          printstring(", pin "); putstring(term_pin)
          space; putstring(term_signal)
          printstring(" of "); putstring(term_chip_name); space
          putstring(term_chip_type); printstring(" at ")
          putstring(term_chip_at); newline
          printstring("is already connected to ")
          putstring(term_net_signal); putindex(term_net_index)
          printstring(", cannot also connect to ".s)
          putindex(si); newline
        %finish
      %repeat
      head_pins == p
      readsym
    %repeat
    head == tail
    %cycle
      tail_net == head; tail == tail_nextsubnet
    %repeatuntil tail==nil
    %result == head
  %end

%record(netf)%name head,tail

  tail == nil
  %while sym='^N' %cycle
    readsym; head == readsubnets; draw net(head)
    head_nextnet == tail; tail == head
  %repeat
  %result == head
%end

%record(chipf)%map readchips
%integer i,nt
%record(chipf)%name chead,ctail
%record(pinf)%name phead,ptail
  ctail == nil
  readsym
  %while sym='^H' %cycle
    chead == new(chead); chead = 0
    chead_next == ctail; ctail == chead
    read(nt) %for i=1,1,5
    readstring; chead_name = codestring
    readstring; chead_type = codestring
    ptail == nil; readsym
    %while sym='^T' %cycle
      read(i)
      %if i&3#0 %start
        phead == new(phead); phead = 0; phead_chip == chead
        phead_nextinchip == ptail; ptail == phead
        phead_number = i>>2; phead_flags = i&3
        readstring; phead_x = getnum; verify(':')
                    phead_y = getnum; verify('/')
        phead_pin = codestring
        readstring; phead_signal = codestring; phead_index = si
      %finishelsestart
        readstring; readstring
      %finish
      readsym
    %repeat
    chead_pins == reverse(phead)
    %while sym='^P' %cycle
      read(i); readstring
      %if i=pack %start
        chead_pack = codestring
      %finishelseif i=on %start
        chead_on = codestring
      %finishelseif i=pat %start
        chead_at = codestring
      %finishelseif i=size %start
        chead_wide = getnum; verify(':')
        chead_high = getnum
      %finishelseif i=place %start
        chead_x = getnum; verify(':')
        chead_y = getnum
      %finish
      readsym
    %repeat
    verify('^G')
    draw chip(chead) %unless chips==nil
    readsym
  %repeat
  %result == chead
%end

%record(pinf)%map pin at(%integer x,y)
! Finds pins nearest to (or at) x,y
%record(pinf)%name p,q
%record(chipf)%name c
%integer minsep=0,sep
  c == chips; p == nil
  %cycle
    %result == p %if c==nil
    q == c_pins
    %while q##nil %cycle
      sep = |q_x-x|+|q_y-y|
      %result == q %if sep=0;  ! Exact match
      %if sep<minsep %or minsep=0 %start
        minsep = sep; p == q
      %finish
      q == q_nextinchip
    %repeat
    c == c_next
  %repeat
%end

%record(chipf)%map chip at(%integer x,y)
%record(chipf)%name chip
%record(pinf)%name pin
  pin == pin at(x,y)
  chip == pin_chip
  putstring(chip_name); printsymbol(':'); putstring(chip_type)
  printstring(" at ") %and putstring(chip_at) %unless chip_at=0
  newline
  %result == chip
%end

%record(netf)%map net at(%integer x,y)
%record(pinf)%name p
%record(netf)%name n
%record(chipf)%name c
  p == pin at(x,y)
  %stopif p==nil
  c == p_chip
  n == p_net
  %if n==nil %start
    printstring("Unconnected")
  %finishelsestart
    putstring(n_signal); putindex(n_index); printsymbol(':')
    n == n_net
  %finish
  printstring(" input") %if p_flags&2#0
  printstring(" output") %if p_flags&1#0
  printstring(" pin "); putstring(p_pin)
  printstring(" of ") %and putstring(c_type) %unless c==chips
  printstring(" at ") %and putstring(c_at) %unless c_at=0
  newline
  %result == n
%end

%routine draw cursor(%integer c)
  enable(\7); colour(c)
  scaled line(curx,cury-25,curx,cury+25)
  scaled line(curx-25,cury,curx+25,cury)
  enable(\0)
%end

%integerfn keyboard
%own %integer mouse = 1
%constinteger esc=27
%integer sym,i
%integer mx,my,dx,dy,cx,cy
%integer mscale = 20
  %on 0 %start
      %stop %if mouse=0
      mouse = 0
  %finish
  %signal 9 %if state=1
  draw cursor(8)
  mx = mousex//mscale %and my = mousey//mscale %if mouse=1
  %cycle
    cx = curx; cy = cury
    sym = testsymbol
    %if sym=esc %start
      sym = testsymbol %until sym>=0 %and 'O'#sym#'['
      draw cursor(0)
      %if sym='D' %start; !left
        curx = curx-curs
      %finishelseif sym='C' %start; !right
        curx = curx+curs
      %finishelseif sym='A' %start; !up
        cury = cury+curs
      %finishelseif sym='B' %start; !down
        cury = cury-curs
      %else
        printsymbol(sym;'?';nl)
      %finish
      draw cursor(8)
    %elseif sym>0
      %result = sym
    %else %if mouse = 1
      dx = mousex//mscale-mx; dy = mousey//mscale-my
      mx = mx+dx; my = my+dy
      %if dx#0 %or dy#0 %start
        draw cursor(0)
        curx = cx+dx*curs; cury = cy+dy*curs
        draw cursor(8)
      %finish
    %finish
  %repeat
%end

  file = cliparam; file = file.".bic"; openinput(1,file)
  selectoutput(0); selectinput(1)
  readsym; verify('^S')
  readsym; verify('3')
  readsym; verify('^U')
  readsym; verify('4')
  chips == readchips
  !setup
  ww = chips_wide; curx = ww//2
  hh = chips_high; cury = hh//2
  colour(blue); fill(0,0,1023,1023)
  window(-1,-1,ww+1,hh+1); colour(black); scaled fill(0,0,ww,hh)
  draw pads(chips_pins)

  verify('^J')
  read(i)
  chips_next == reverse(readchips)
  nets == readnets
  verify('^E')

  selectinput(0)
  printstring("e: Erase wire plane
N:  Draw all nets
n:  Draw nearest net
z:  Zoom (0: back to full board, <0 shrink, >0 grow)
C:  Set cursor speed
c:  Draw all nets on nearest chip
")
  state = 1
mainloop:
  %cycle
    prompt("")
    i = keyboard
    %exitif i='.'
    %if i='C' %start
      prompt("Cursor speed: "); read(curs)
    %finishelseif i='c' %start
      draw chip nets(chip at(curx,cury))
    %finishelseif i='n' %start
      draw net(net at(curx,cury))
    %finishelseif i='N' %start
      draw nets(nets)
    %finishelseif i='e' %start
      enable(\7); colour(0); scaled fill(0,0,ww,hh); enable(\0)
    %finishelseif i='z' %start
      prompt("Zoom factor: "); read(ztop)
      %if ztop=0 %start
        window(-1,-1,ww+1,hh+1)
      %finishelseunless ztop=1 %start
        %if ztop>0 %then zbot=1 %else zbot=-ztop %and ztop=1
        zoom(curx,cury,ztop/zbot)
      %finish
      colour(blue); fill(0,0,1023,1023)
      colour(black); scaled fill(0,0,ww,hh)
      draw pads(chips_pins)
      draw chips(chips_next)
    %finish
  %repeat

%endofprogram
