begin ; !6-valued logic simulator

constinteger  low=-2,falling=-1,rising=1,high=2
constinteger  open=0,undef=((-1)>>1)!!(-1)

record (*)name  nil==record(0)

recordformat  hfm(record (hfm)name  next,integer  state,since)
constinteger  slotmax=11; !slots @ 2 lines each, leaves 2 for command etc
constinteger  eqmax=800;  !event queue cells
constinteger  hmax=5000;  !heap words

constinteger  csize=5,psize=5,ssize=10; !size (in words) of heap records
constinteger  hsize=3
recordformatspec  pinf
recordformatspec  sigf
recordformat  compf(record (compf)name  next,
                    integer  type {indexes into behaviour switch},
                    record (pinf)name  ins,outs,private)
recordformat  pinf(record (pinf)name  next {pin in component},
                   chain {next pin in net},record (compf)name  comp,
                   record (sigf)name  signal, integer  state)
recordformat  sigf(record (sigf)name  next {for identification},
                   integer  state,record (pinf)name  from,to,
                   integer  screenslot,record (hfm)name  history,
                   string (15)name)
recordformat  eqf(record (eqf)name  next,record (pinf)name  pin,
                  integer  state,when)

record (sigf)namearray  slot(1:slotmax)
record (eqf)name  eventqueue,eclist
record (eqf)array  ecell(1:eqmax)
integer  now=0

integer  heapspace=1
integerarray  heap(1:hmax)
record (sigf)name  nets==nil
record (compf)name  components==nil

routine  initialise arrays
integer  i
  slot(i)==nil for  i=1,1,slotmax
  ecell(i)_next==ecell(i-1) for  i=2,1,eqmax
  eclist==ecell(eqmax)
  ecell(1)_next==nil
  eventqueue==nil
end 

record (*)map  new(integer  size)
!This assumes that array elements with increasing
!indices have increasing addresses
  signal  15 if  heapspace>hmax
  heap(heapspace)=size; heapspace=heapspace+size+1
  result ==record(addr(heap(heapspace-size)))
end 

record (pinf)map  newpin
record (pinf)name  x==new(psize)
  x=0; result ==x
end 

record (compf)map  newcomp
record (compf)name  x==new(csize)
  x=0; result ==x
end 

record (sigf)map  newsignal
record (sigf)name  x==new(ssize)
  x=0; x_state=undef; result ==x
end 

record (hfm)name  history archive==nil

record (hfm)map  get hist
record (hfm)name  h
  h==history archive
  if  h==nil then  h==new(hsize) else  history archive==h_next
  h=0; result ==h
end 

routine  put hist(record (hfm)name  h)
  h_next==history archive
  history archive==h
end 

constinteger  esc=27,cur='Y',graph='F',nograph='G',delete='O'
constinteger  up='A',home='H',clearscreen='v',clearline='K'
constinteger  insert='i',noinsert='j'

routine  escape(integer  x)
  printsymbol(esc); printsymbol(x)
end 

routine  cursor(integer  x,y)
  escape(cur); printsymbol(y+' '); printsymbol(x+' ')
end 

integerfn  upper(integer  old,new)
  old=old+old if  |old|=rising
  new=new+new if  |new|=rising
  if  old=high start 
    result ='`' if  new=high
    result ='l' if  new=low
    result ='d' if  new=open
    result ='l'
  finish 
  if  old=low start 
    result ='s' if  new=high
    result =' ' if  new=low
    result ='s' if  new=open
    result =' '
  finish 
  if  old=open start 
    result ='d' if  new=high
    result ='l' if  new=low
    result ='d' if  new=open
    result ='l'
  finish 
  result ='s' if  new=high
  result =' ' if  new=low
  result =' ' if  new=open
  result =' '
end 

integerfn  lower(integer  old,new)
  old=old+old if  |old|=rising
  new=new+new if  |new|=rising
  if  old=high start 
    result =' ' if  new=high
    result ='e' if  new=low
    result ='e' if  new=open
    result =' '
  finish 
  if  old=low start 
    result ='m' if  new=high
    result ='`' if  new=low
    result ='c' if  new=open
    result ='m'
  finish 
  if  old=open start 
    result ='m' if  new=high
    result ='c' if  new=low
    result ='c' if  new=open
    result ='m'
  finish 
  result ='e' if  new=high
  result ='e' if  new=low
  result ='%' if  new=open
  result =' '
end 

routine  refresh(integer  i)
integer  old,new
record (sigf)name  s
record (hfm)name  h
  s==slot(i); returnif  s==nil
  cursor(0,i+i+1); escape(clearline)
  cursor(0,i+i);   escape(clearline)
  cursor(65,i+i+1); printstring(s_name)
  cursor(65,i+i);   printstring(s_name); newline
!rest not in yet
end 

routine  log(record (sigf)name  s,integer  old)
integer  new,i
record (hfm)name  h,hh
  escape(graph)
  if  s==nil start ; ! Time has passed: old=ticks
    while  old>0 cycle 
      old=old-1
      escape(insert)
      for  i=slotmax,-1,1 cycle 
        unless  slot(i)==nil start 
          new=slot(i)_state
          cursor(0,i+i+1); escape(delete); cursor(63,i+i+1)
          printsymbol(lower(new,new))
          cursor(0,i+i); escape(delete);   cursor(63,i+i)
          printsymbol(upper(new,new))
          newline; !??
        finish 
      repeat 
      escape(noinsert)
    repeat 
  finishelsestart ; ! Signal has changed: old=previous state
    new=s_state
    h==s_history
    if  h==nil start 
      h==get hist; h_next==h; s_history==h
      h_since=now; h_state=new
    finishelsestart 
      old=h_state; ! overriding
      hh==get hist; hh_next==h_next; h_next==hh; s_history==hh
      hh_since=now; hh_state=new
      h==hh
    finish 
    while  h_next_next_since <= now-64 cycle ; !scavenge
      hh==h_next; h_next==hh_next; put hist(hh)
    repeat 
    i=s_screenslot
    if  i#0 start 
      cursor(63,i+i+1); printsymbol(lower(old,new))
      cursor(63,i+i);   printsymbol(upper(old,new))
      newline; !??
    finish 
  finish 
  escape(nograph); newline; !??
end 

routine  print(integer  state)
  if  state=high    then  printstring("high")      elsec 
  if  state=low     then  printstring("low")       elsec 
  if  state=undef   then  printstring("undefined") elsec 
  if  state=open    then  printstring("open")      elsec 
  if  state=rising  then  printstring("rising")    elsec 
  if  state=falling then  printstring("falling")
  newline
end 


routinespec  excite(record (compf)name  c)

routine  propagate(record (sigf)name  signal)
integer  new,y,old
record (pinf)name  p

  old=signal_state
  p==signal_from
  if  p==nil start ;     ! External input
    new=old; old=undef
  finishelsestart ;      ! Establish agreement from all sources
    new=open
    cycle 
      y=p_state; new=y if  new#y and  new=open
      new=undef andexitif  new#y and  y#open; !Conflict
      p==p_chain
    repeatuntil  p==nil
    returnif  signal_state=new
    if  |old|=rising start ; !Forced: Set all sources
      new=old+old; p==signal_from
      cycle 
        p_state=new; p==p_chain
      repeatuntil  p==nil
      newline
    finish 
    signal_state=new
  finish 

  log(signal,old)

! Excite all components with inputs connected to this signal

  p==signal_to
  y=new; y=rising if  y=high; y=falling if  y=low
  whilenot  p==nil cycle 
    p_state=y; excite(p_comp)
    p_state=new; excite(p_comp); p==p_chain
  repeat 
end 

routine  make(record (pinf)name  pin,integer  new,when)
record (eqf)name  e,f
integer  old
  new=new+new if  |new|=rising
  unless  when=now start ;   ! Insert this event in event queue
    e==eclist; signal  15 if  e==nil
    eclist==e_next; e_next==nil
    e_pin==pin; e_state=new; e_when=when
    f==eventqueue
    if  f==nil start 
      eventqueue==e; return 
    finish 
    if  when<f_when start 
      e_next==f; eventqueue==e; return 
    finish 
    cycle 
      if  f_next==nil start 
        f_next==e; return 
      finish 
      if  when<f_next_when start 
        e_next==f_next; f_next==e; return 
      finish 
      f==f_next
    repeat 
  finish 
  old=pin_state; returnif  old=new
  pin_state=new; returnif  pin_signal==nil
  propagate(pin_signal)
end 

routine  aftermath;  ! Flush event queue
record (eqf)name  e
  cycle 
    e==eventqueue; returnif  e==nil
    eventqueue==e_next; e_next==eclist; eclist==e
    log(nil,e_when-now)
    now=e_when
    make(e_pin,e_state,now)
  repeat 
end 

! Basic logic primitives
! Note that NOT is just minus

integerfn  float(integer  x)
  x=high if  x=open
  x=x+x if  |x|=rising
  result =x
end 

integerfn  edgefloat(integer  x)
  x=undef if  x=open
  result =x
end 

integerfn  setupfloat(integer  x)
  x=high if  x=open or  x=falling
  x=low if  x=rising
  result =x
end 

integerfn  and(integer  x,y)
  result =low if  x=low or  y=low
  result =undef if  x=undef or  y=undef
  result =high
end 

integerfn  or(integer  x,y)
  result =high if  x=high or  y=high
  result =undef if  x=undef or  y=undef
  result =low
end 

integerfn  xor(integer  x,y)
  result =undef if  x=undef or  y=undef
  result =low if  x=y
  result =high
end 

integerfn  oc(integer  x); !open collector
  result =open if  x=high or  x=rising
  result =x
end 

constinteger  known=13
conststring (15)array  type(0:known)="???",
"INV",  "INVO",
"AND",  "NAND",
"NANDO","OR",
"NOR",  "NORO",
"XOR",  "U74",
"TSBUF","U374",
"U123"

routine  fail(record (compf)name  c,record (sigf)name  s,string (15)m)
record (pinf)name  p
integer  n
  printstring(m)
  unless  s==nil start 
    printstring(" Net "); printstring(s_name)
    p==s_from; n=0
    whilenot  p==nil cycle 
      n=n+1; p==p_chain
    repeat 
    write(n,1)
    p==s_to; n=0
    whilenot  p==nil cycle 
      n=n+1; p==p_chain
    repeat 
    write(n,1); newline
  finish 
  unless  c==nil start 
    printstring(type(c_type)); printstring(" (")
    p==c_ins
    whilenot  p==nil cycle 
      printstring(p_signal_name); p==p_next; printsymbol(',') unless  p==nil
    repeat 
    printsymbol('/')
    p==c_outs
    whilenot  p==nil cycle 
      printstring(p_signal_name); p==p_next; printsymbol(',') unless  p==nil
    repeat 
    printsymbol(')'); newline
  finish 
  signal  15
end 

routine  excite(record (compf)name  comp)
record (pinf)name  in1,in2,more,out
integer  i1,i2
switch  s(0:known)
switch  t(3:9)

  more==nil; in2==nil
  in1==comp_ins
  unless  in1==nil start 
    i1=in1_state; in2==in1_next
    unless  in2==nil start 
      more==in2_next; i2=in2_state
    finish 
  finish 
  out==comp_outs
  ->s(comp_type)

s(9): {xor}    i1=xor(float(i1),float(i2)); ->generic
s(3): {and}
s(4): {nand}
s(5): {nando}  i1=and(float(i1),float(i2)); ->generic
s(6): {or}
s(7): {nor}
s(8): {noro}   i1=or(float(i1),float(i2))
generic:
  ->t(comp_type) if  more==nil
  i2=more_state; more==more_next; ->s(comp_type)

t(9): {xor}
t(6): {or}
t(3): {and}    make(out,i1,now+1); return 
s(1): {inv}
t(7): {nor}
t(4): {nand}   make(out,-float(i1),now+1); return 
s(2): {invo}
t(8): {noro}
t(5): {nando}  make(out,oc(-float(i1)),now+1); return 

s(10):{u74}
  begin 
  integer  d,s0,r0,c
  record (pinf)name  out0

    d=setupfloat(i1); s0=float(i2); r0=float(more_state)
    c=edgefloat(more_next_state)
    out0==out_next

    if  r0=undef start 
      make(out,high,now+1) if  s0=low
    finishelseif  s0=undef start 
      make(out0,high,now+1) if  r0=low
    finishelseif  r0=low and  s0=low start 
      make(out,high,now+1); make(out0,high,now+1)
    finishelseif  r0=low start 
      make(out,low,now+1); make(out0,high,now+1)
    finishelseif  s0=low start 
      make(out,high,now+1); make(out0,low,now+1)
      if  c=rising and  (d=low or  d=undef) start 
        make(out0,-d,now+2); make(out0,low,now+3)
      finish 
    finishelseif  c=rising start 
      make(out,d,now+2); make(out0,-d,now+2)
    finish 
  end 
  return 

s(11): {tsbuf: non-inverting, low-active enable}
  i1=float(i1); i2=float(i2)
  if  i2=low then  i2=i1 elsec 
  if  i2=high then  i2=open else  i2=undef
  make(out,i2,now+1)
  return 

s(12): {u374: clock, enable¬ i(0:7) / o(0:7)}
!%begin
!%record(pinf)%namearray in,state,out(0:7)
!%record(pinf)%name p
!%integer i
!  p==comp_private
!  %if p==nil %start
!    %for i=0,1,7 %cycle
!      p==newpin; state(i)==p; p_comp==comp
!    %repeat
!    comp_private==state(0)
!    %for i=0,1,6 %cycle
!      state(i)_next==state(i+1)
!    %repeat
!    state(7)_next==nil
!  %finishelsestart
!    %for i=0,1,7 %cycle
!      state(i)==p; p==p_next
!    %repeat
!  %finish
!  p==comp_outs
!  %for i=0,1,7 %cycle
!    out(i)==p; p==p_next
!  %repeat
!  p==more
!  %for i=0,1,7 %cycle
!    in(i)==p; p==p_next
!  %repeat
!  %if i1=rising %start
!    state(i)_state=setupfloat(in(i)_state) %for i=0,1,7
!  %finish
!  i2=float(i2)
!  %if i2=low %start
!    make(out(i),state(i)_state,now+1) %for i=0,1,7
!  %finishelsestart
!    %if i2=high %then i2=open %else i2=undef
!    make(out(i),i2,now+1) %for i=0,1,7
!  %finish
!%end
  return 

s(13): {u123: a0, b, c0, timeout / q, q0}
  begin 
 integer  a0,b,c0,timeout
  record (pinf)name  out0
  a0=float(i1); b=float(i2); c0=float(more_state)
  timeout=more_next_state
  out0==out_next
  if  c0=low start 
    make(out,low,now+1); make(out0,high,now+1)
  finishelseif  c0=undef start 
    make(out,undef,now+1); make(out0,undef,now+1)
  finishelsestart 
    b=and(-a0,b)
    if  b=high and  out_state=low start 
      make(out,high,now+1)
      make(out0,low,now+1)
    finishelseif  |timeout|=rising start 
      make(out,low,now+1)
      make(out0,high,now+1)
    finish 
  finish 
  end 
  return 

s(0):
end 

string (15)atom,pend=""
integer  sym=nl
constbyteintegerarray  symtype(0:127)=
1(33),0(3),2,0(3),2,2,0,0,2,2,0,2,0(16),0(33),3(26),0(5)
!          $      ( )     , -   /
! 0 normal 1 separator 2 special 3 lower-case

routine  readatom
integer  st
  unless  pend="" start 
    atom=pend; pend=""; return 
  finish 
  cycle 
    cycle 
      st=symtype(sym&127); exitunless  st=1
      readsymbol(sym)
    repeat 
    exitunless  sym='$'
    readsymbol(sym) until  sym='$' or  sym=nl
    readsymbol(sym)
  repeat 
  sym=sym-32 if  st=3
  atom=tostring(sym)
  if  st=2 start ; !Special on its own
    if  sym='-' start ; ! "->" or "/" or "-" equivalent
      atom="/"
      readsymbol(sym); returnunless  sym='>'
    finish 
    readsymbol(sym); return 
  finish 
  readsymbol(sym)
  cycle 
    st=symtype(sym&127); sym=sym-32 and  st=0 if  st=3
    exitunless  st=0
    atom=atom.tostring(sym) unless  length(atom)=15
    readsymbol(sym)
  repeat 
end 

record (sigf)map  findsignal
record (sigf)name  s
  s==nets
  whilenot  s==nil cycle 
    result ==s if  s_name=atom
    s==s_next
  repeat 
  s==newsignal; s_next==nets; nets==s; s_name=atom
  result ==s
end 

routine  readcomponent
record (compf)name  c
record (pinf)name  p,plist
record (sigf)name  s
integer  t,slashes

record (pinf)map  reverse(record (pinf)name  this)
record (pinf)name  tail,next
  tail==nil; result ==nil if  this==nil
  cycle 
    next==this_next; this_next==tail; tail==this
    result ==this if  next==nil; this==next
  repeat 
end 

!%record(pinf)%map reversecopy(%record(pinf)%name list)
!%record(pinf)%name x,y
!  x==nil
!  %cycle
!    %result==x %if list==nil
!    y==newpin; y_next==x; x==y
!    y_comp==c; y_signal==list_signal
!    list==list_next
!  %repeat
!%end
!
!%record(pinf)%map append(%record(pinf)%name tail,list)
!%record(pinf)%name p
!  %result==tail %if list==nil
!  p==list; p==p_next %whilenot p_next==nil; p_next==tail
!  %result==list
!%end

  readatom; signal  9 if  atom="END"
  for  t=1,1,known cycle 
    ->ok if  type(t)=atom
  repeat 
  printstring("Unknown component "); printstring(atom); newline
  t=0
ok: c==newcomp; c_type=t
  c_next==components; components==c
  slashes=0; plist==nil
  readatom
  printstring("( expected") and  newline unless  atom="("
!Non-ESDL-compatible notation:  comp(ins{{/inouts}/outs})
!  readatom
!  %cycle
!    %if atom="/" %or atom=")" %start
!      %if slashes=0 %start
!        c_ins==reverse(plist); %exitif atom=")"
!        slashes=1
!      %finishelsestart
!        %if atom=")" %start
!          c_outs==append(reverse(plist),c_outs); %exit
!        %finish
!        c_ins==append(reversecopy(plist),c_ins)
!        c_outs==reverse(plist)
!      %finish
!      plist==nil
!      readatom
!    %finishelsestart
!      printstring("Unexpected (") %and newline %if atom="("
!      printstring("Unexpected ,") %and newline %if atom=","
!      s==nil; s==findsignal %unless atom="?"
!      p==newpin; p_next==plist; plist==p
!      p_comp==c; p_signal==s; p_state=open %if s==nil
!      readatom
!      %if atom="," %then readatom %elsestart
!        printstring(", expected") %and newline %unless atom="/" %or atom=")"
!      %finish
!    %finish
!  %repeat
!ESDL-compatible notation: comp(ins)->outs
! This requires pending atom and disallows inouts
  cycle 
    readatom
    if  atom=")" or  atom="," or  atom="/" start 
      printstring(atom); printstring(" not expected"); newline
      exit 
    finish 
    s==nil; s==findsignal unless  atom="?"
    p==newpin; p_next==plist; plist==p
    p_comp==c; p_signal==s; p_state=open if  s==nil
    readatom
    exitif  atom=")" or  atom="/"
    printstring(", expected") and  newline unless  atom=","
  repeat 
  readatom if  atom=")"
  printstring("-> expected") and  newline unless  atom="/"
  c_ins==reverse(plist); plist==nil
  cycle 
    readatom
    printstring(", not expected") and  newline if  atom=","
    s==nil; s==findsignal unless  atom="?"
    p==newpin; p_next==plist; plist==p
    p_comp==c; p_signal==s; p_state=open if  s==nil
    readatom; exitunless  atom=","
  repeat 
  pend=atom unless  atom=")"
  c_outs==reverse(plist); plist==nil
  p==c_ins
  whilenot  p==nil cycle 
    s==p_signal
    p_chain==s_to and  s_to==p unless  s==nil
    p==p_next
  repeat 
  p==c_outs
  whilenot  p==nil cycle 
    s==p_signal
    p_chain==s_from and  s_from==p unless  s==nil
    p==p_next
  repeat 
end 

routine  simulate
integer  command,i
record (compf)name  c
record (sigf)name  s

routine  identify
  readatom
  s==findsignal
  if  s_from==nil and  s_to==nil start 
    s==nil; printstring("Not connected"); newline
  finish 
end 

  initialise arrays
  escape(clearscreen); newline

cycle 
  escape(home); escape(clearline); newline
  prompt(tostring(esc).tostring(up)."scuovpdr+-?:")
  escape(clearline); newline
  readsymbol(command) until  command>' '
  command=command!32
  stopif  command=':'
  if  command='-' start 
    identify
    unless  s==nil start 
      i=s_screenslot
      unless  i=0 start 
        slot(i)==nil
        s_screenslot=0
        cursor(0,i+i+1); escape(clearline)
        cursor(0,i+i);   escape(clearline)
        newline; !??
      finish 
    finish 
  finishelseif  command='+' start 
    identify
    unless  s==nil start 
      if  s_screenslot=0 start 
        for  i=1,1,slotmax cycle 
          if  slot(i)==nil start 
            slot(i)==s; s_screenslot=i
            refresh(i)
            exit 
          finish 
        repeat 
      finish 
    finish 
  finishelseif  command='r' start 
    refresh(i) for  i=1,1,slotmax
  finishelseif  command='?' start 
    identify
    unless  s==nil start 
      printstring(atom); printstring(" = "); print(s_state); newline
    finish 
  finishelseif  command='s' start 
    identify
    unless  s==nil start 
      s_state=rising; propagate(s)
      s_state=high; propagate(s)
      aftermath
    finish 
  finishelseif  command='c' start 
    identify
    unless  s==nil start 
      s_state=falling; propagate(s)
      s_state=low; propagate(s)
      aftermath
    finish 
  finishelseif  command='u' start 
    identify
    unless  s==nil start 
      s_state=undef; propagate(s)
      aftermath
    finish 
  finishelseif  command='o' start 
    identify
    unless  s==nil start 
      s_state=open; propagate(s)
      aftermath
    finish 
  finishelseif  command='v' start 
    identify
    unless  s==nil start 
    if  |s_state|=high start 
      s_state=-s_state//2; propagate(s)
      s_state=s_state<<1; propagate(s)
      aftermath
    finish 
    finish 
  finishelseif  command='p' start 
    identify
    unless  s==nil start 
    if  |s_state|=high start 
      s_state=-s_state//2; propagate(s)
      s_state=s_state<<1; propagate(s)
      aftermath
      s_state=-s_state//2; propagate(s)
      s_state=s_state<<1; propagate(s)
      aftermath
    finish 
    finish 
  finishelseif  command='d' start 
    s==nets
    cycle 
      if  s_state=undef start 
        prompt(s_name." = "); readsymbol(sym)
        if  sym#nl start 
          sym=sym!32
          if  sym='h' start 
            s_state=rising; propagate(s)
            s_state=high; propagate(s)
          finishelseif  sym='l' start 
            s_state=falling; propagate(s)
            s_state=low; propagate(s)
          finishelseif  sym='o' start 
            s_state=open; propagate(s)
          finishelse  sym=0
          aftermath unless  sym=0
          readsymbol(sym) until  sym=nl
        finish 
      finish 
      s==s_next
    repeatuntil  s==nil
  finish 
repeat 
end 

integer  stream=1

onevent  9 start 
  stopif  stream=0; stream=0
finish 

selectinput(stream)
simulate if  stream=0
cycle 
  readcomponent
repeat 

endofprogram