% mpcirc

if unknown mpcirc_included_:
mpcirc_included_:=0;

input ttex;					% macros for tex labels
%%--------------------------------------------------
pair inc_pos;					% incremental position
transform labeltransform;
labeltransform:=identity;

let stk = scantokens;				% it is used quite a bit :-)

def begincirc =
  begingroup
  save preparedelems;				% allows nested circuits
  string preparedelems;
  preparedelems := "";
  def preparedwires = enddef;
  inc_pos := (2u,2u);
enddef;

% clear variables
def endcirc =
  if preparedelems <> "": unprepare; fi;
  endgroup;
enddef;

extra_beginfig := extra_beginfig & "begincirc;";
extra_endfig := extra_endfig & "endcirc;" &
  "currentpicture := currentpicture shifted ((0.2in,0.2in)-llcorner currentpicture);";
%%--------------------------------------------------
%% general macros

def isdigit primary c = ((c>="0") and (c<="9")) enddef;

def str_append (suffix s)(expr a) =
  s := if unknown s: a
  elseif s = "": a
  else: s & "," & a fi;
enddef;

% if |v| is unknown set it to |xdef|
def condset (suffix v)(expr xdef) =
  if unknown v: v = xdef fi;
enddef;

% MFbook p. 289
def cand (text q) = startif true q else: false fi enddef;
def cor (text q) = startif true true else: q fi enddef;
tertiarydef p startif true = if p: enddef;

%%--------------------------------------------------
% The following macros adapted from boxes.mp (by J. Hobby)

% Find the length of the prefix of string s for which cond is true for each
% character c of the prefix
vardef str_prefix(expr s)(text cond) =
  save i_, c; string c;
  i_ = 0;
  forever:
    c := substring (i_,i_+1) of s;
    exitunless cond;
    exitif incr i_>=length s;			% was |=|
  endfor
  i_
enddef;

% Take a string returned by the str operator and return the same string
% with explicit numeric subscripts replaced by generic subscript symbols [].
vardef generisize(expr ss) =
  save res, s, l; string res, s;
  res = "";             % result so far
  s = ss;               % left to process
  forever:
    exitif s="";
    l := str_prefix(s, (c<>"[") and not(isdigit c));
    res := res & substring (0,l) of s;
    s := substring (l,infinity) of s;
    if s<>"":
      res := res & "[]";
      l := if s>="[":  1 + str_prefix(s, c<>"]")
           else:  str_prefix(s, (c=".") or (isdigit c)) fi;
      s := substring(l,infinity) of s;
    fi
  endfor
  res
enddef;

string _n_, _n_cur_, _n_gen_;
_n_cur_ := "]";					% this won't match |_n_|

% Make sure the string |_n_gen_| is |generisize(_n_)|:
vardef set_n_gen_ =
  if _n_ <> _n_cur_:
    _n_cur_:=_n_;
    _n_gen_:=generisize(_n_);
  fi
enddef;


% Given a type |t| and list of variable names |vars|, make sure that they are
% of type |t| and redeclare them as necessary.  In the vars list |_n|
% represents scantokens |_n_|, a suffix that might contain numeric subscripts.
% This suffix needs to be replaced by scantokens |_n_gen_| in order to get
% a variable that can be declared to be of type |t|.
vardef generic_decl(text t) text vars =
  set_n_gen_;
  forsuffixes v_=vars:
    if  forsuffixes _n=scantokens _n_: not t v_ endfor:
      def _gdmac_ text _n = t v_ enddef;	% was  |= t v_|
      expandafter _gdmac_ scantokens _n_gen_;
    fi
  endfor
enddef;

% Clear variables by declaring them as numeric
vardef generic_clear text vars =
  set_n_gen_;
  def _gdmac_ text _n = numeric vars enddef;
  expandafter _gdmac_ scantokens _n_gen_;
enddef;

%%--------------------------------------------------
% Element type is determined by its first token (|str| never returns |[]|'s)
def etype_ (expr s) =
  substring (0, str_prefix(s, (c<>".") and not (isdigit c)) ) of s
enddef;

vardef eindex_ (expr s) =			% string index of an element for labeling
  save c, i_, isnum; string c; boolean isnum;
  i_ = length s;				% start at the end
  isnum := isdigit substring (i_-1,i_) of s;	% negative indices are silently ignored
  forever:
    exitif decr i_ < 1;
    c := substring (i_-1,i_) of s;
    exitunless (if isnum: isdigit(c) else: not(isdigit c) and (c<>".") fi);
  endfor
%  if (i_<1): errmessage "No valid index found in `" & s & "'"; fi;
  if (i_<1): "" else: substring(i_,infinity) of s fi
enddef;

%%--------------------------------------------------
% library interface

% Store element definition in the macro with the name |etype_draw_|.
def defelem (suffix $)(text edraw) =
  expandafter def stk(str$ & "_draw_") = edraw; enddef;
enddef;

% in the future use dynamic library loading
input circlib;

string emptystr;
emptystr := "$$";

% add |cntr| to the list of recognized positions from plain.mp
% because empty tex arguments cause trouble in |setlabel|.
pair laboff.cntr;
laboff.cntr = laboff; labxf.cntr = labxf; labyf.cntr = labyf;

% return a corner of picture |p| described by suffix |@#|
% (adapted from |thelabel|)
vardef picpos@# (expr p) =
  labxf@#*ulcorner p + labyf@#*lrcorner p + (1-labxf@#-labyf@#)*urcorner p
enddef;

% find position on elements bbox
vardef epos@# (suffix $) =
  picpos@# (stk (etype_(str $) & "._.pic")) + $ - center (stk (etype_(str $) & "._.pic"))
enddef;

% define label/value parameters: text |lab|, anchor |z| in current picture,
% direction from anchor |o|, |@#| lab/val
vardef addlab__@# (expr lab)(text z)(text o) =
  save lft,rt,top,bot;				% hide pen primary macros
  if picture lab: picture @# else: string @#; fi;
  @# = lab;
  pair @#pos, @#ori;
  if known (z): @#pos = z
  elseif known labxf.z: @#pos = picpos.z (currentpicture) fi;
  if known (o): @#ori = o
  elseif known laboff.o: @#ori = laboff.o fi;
enddef;

% Used by draw library routines. |_ename_| is assumed to hold element type.
vardef addlab@# (expr lab)(text z)(text o) =
  str_append (stk (_ename_)._.labnames, str @#);
  addlab__.stk(_ename_)._.@# (lab)(z)(o)
enddef;


vardef setlab@# (expr lab)(text z)(text o) =
  save lft,rt,top,bot;				% hide pen primary macros
  if picture lab: picture @# else: string @#; fi; % redeclare
  @# := lab;
  if known (z): @#pos := z
  elseif known labxf.z: @#pos := picpos.z (stk (etype_(str @#))._.pic) fi;
  if known (o): @#ori := o
  elseif known laboff.o: @#ori := laboff.o fi;
enddef;

vardef addpin__@# (text z) (text o) =
  save lft,rt,top,bot;				% hide pen primary macros
  pair @#;					% declare pin pos for type
  if known (z): @# = z
  elseif known labxf.z: @# = picpos.z (currentpicture) fi;
enddef;

vardef addpin@# (text z) (text o) =
  str_append (stk (_ename_)._.pinnames, str @#);
  addpin__.stk(_ename_)._.@# (z) (o)
enddef;


% graphical!!!
neg_rad:=.2u;
vardef addnegpin@# (expr z)(text o) =
  save lft,rt,top,bot;				% hide pen primary macros
  save p,d; path p; pair d;
  d := if known (o): o
  elseif known laboff.o: laboff.o fi;
  p:=fullcircle scaled 2neg_rad shifted (z + d*neg_rad);
%  pickup pencircle scaled normalline;
  draw p;					% uses current pen!!!
  addpin@# (z + 2neg_rad*d)(o);
enddef;


string roman[];
roman[1] := "i"; roman[2] := "ii"; roman[3] := "iii"; roman[4] := "iv";
roman[5] := "v"; roman[6] := "vi"; roman[7] := "vii"; roman[8] := "viii";

def defromanelem (suffix e) (text t) (text extra) =
  defelem (e, t(2); extra);
  for i = 3 upto 8:
    defelem (scantokens (str e & roman[i]), t(i); extra);
  endfor;
enddef;


%%--------------------------------------------------
% Element type setup, |$$| is an element type
def require suffix $$ =
begincirc					% open new group
  picture $$pic;				% one per element type
  string $$pinnames, $$labnames;

  save x, y, _ename_, currentpicture;		% make variables used by draw routines local
  string _ename_;				% enables nesting
  picture currentpicture;			% |image| inlined here

  $$pinnames := "";				% for elements with no pins
  $$labnames := "";				% for elements with no labels

  _ename_ := etype_ (str $$);			% required by |addlab| and |addpin|
  clearit;
  stk (_ename_ & "_draw_");			% execute draw macro
  $$pic := currentpicture;
%  $$pic = image(stk (_ename_ & "_draw_"));

    if unknown $$lab:
      str_append ($$labnames, "lab");
      addlab__$$lab (_ename_)(picpos.top ($$pic))(up); % above upper middle
    fi;
    if unknown $$val:
      str_append ($$labnames, "val");
      addlab__$$val (emptystr)(picpos.bot ($$pic))(down); % below lower middle
    fi;
    if 0=1:
      $$lab := _ename_;
      $$val := "X";
    fi;
endcirc;
enddef;

def unrequire suffix $$ =
  numeric $$pic, $$pinnames, $$labnames;
enddef;


%%--------------------------------------------------
%% x

def prepare_pinlab (suffix $, $$) =
  if $$pinnames <> "":				% if elem has pins
    forsuffixes pint = stk ($$pinnames):
        generic_decl (pair) _n.pint; % declare pin pos for elem
        $pint = $ + $$pint transformed $t;	% relate it to the center
    endfor;
  fi;
  if $$labnames <> "":				% if elem has labs
    forsuffixes labt = stk ($$labnames):
        if picture $$labt: generic_decl (picture) _n.labt
        else: generic_decl (string) _n.labt fi;
        generic_decl (pair) _n.labt.pos, _n.labt.ori;
    endfor;
  fi;
enddef;

def sprepare (text tt) =			% outside begingroup
  string s_;
  forsuffixes $ = tt:
    s_ := etype_(str $);
    if known stk(s_).pic: save stk s_; fi;
  endfor;
  prepare (tt)
enddef;

vardef prepare@# (text tt) =			% add element topo equations
  save s; string s;
  save labeltransform; transform labeltransform;
  labeltransform := if str @# <> "": inverse T.@#
    else: identity fi;

  forsuffixes $ = tt:
    s := etype_(str $) & "._";
    if unknown stk(s).pic: require stk s; fi; % declare element type

    _n_ := str $;				% for generic_decl
    generic_decl (pair) _n;			% one per element
    generic_decl (transform) _n.t;
    if str @# <> "": $t = T.@#; fi;

    prepare_pinlab ($, stk s);
    str_append (preparedelems, _n_);
  endfor;
enddef;


def unprepare_pinlab (suffix $, $$) =
  if known $$pinnames:				% for next elems of the same type
    if $$pinnames <> "":			% if elem has pins
      forsuffixes pint = stk ($$pinnames):
        generic_clear _n.pint;
        numeric $$.pint;			% clear type variable here
      endfor;
    fi;
  fi;
  if known $$labnames:				% for next elems of the same type
    if $$labnames <> "":			% if elem has labs
      forsuffixes labt = stk ($$labnames):
        generic_clear _n.labt, _n.labt.pos, _n.labt.ori;
        numeric $$labt, $$labt.pos, $$labt.ori; % clear type variables here
      endfor;
    fi;
  fi;
enddef;

% Clear all variables for |preparedelems| which is assumed to be nonempty.
def unprepare =
  save s; string s;
  forsuffixes $ = stk preparedelems:
    _n_ := str $;				% for |generic_clear|
    generic_clear _n, _n.t;

    s := etype_(_n_) & "._";
    unprepare_pinlab ($, stk s);
    unrequire stk s;				% clear type variables
  endfor;
  preparedelems := "";				% clear elem list
enddef;

% Set missing positions for prepared elems. Transformation is checked
% first because it can solve the rest.
vardef efixpos_ =
  forsuffixes $ = stk preparedelems:
    condset ($t, identity);
  endfor;
  forsuffixes $ = stk preparedelems:
    inc_pos:=(uniformdeviate 30u, uniformdeviate 30u);
    if unknown xpart $: message "Unknown xpart " & str $; xpart $ = xpart inc_pos; fi
    if unknown ypart $: message "Unknown ypart " & str $; ypart $ = ypart inc_pos; fi
  endfor;
enddef;


% Position label |s| relative to |labpos| in direction |labori|
vardef elabeli (expr s, labpos, labori) =
  save p, z, ll, ur, t;
  picture p; pair z[], ll, ur;
  p = (if picture s: s
      else: s infont defaultfont scaled defaultscale fi) transformed labeltransform;
  ll = llcorner p;
  ur = urcorner p;
  z1 = center p + labori scaled (abs ((ur - ll) / 2));
  interim bboxmargin:=0;
  (t, whatever) = ((center p)--z1) intersectiontimes (bbox p);
  z2 = if t < 0: z1 else: point t of ((center p)--z1) fi - center p;
%drawarrow labpos--(z1-center p)+labpos;
%drawarrow labpos--z2+labpos;
  draw p shifted (labpos - center p + z2 + labeloffset * labori);
enddef;

vardef elabel@# (expr s, labpos, t) =
  elabeli (s, labpos, laboff@# transformed t)
enddef;


def edraw_int_ (suffix $, $$) =
  tr := identity transformed $t shifted $;
  draw $$pic transformed tr;

  if $$labnames <> "":
    forsuffixes labt = stk ($$labnames):
      boolean _automatic_;
      _automatic_ := unknown $labt;
      condset ($labt, $$labt);			% type label (always known)
      condset ($labt.pos, $$labt.pos);		% inherit defaults
      condset ($labt.ori, $$labt.ori);

      if (picture $labt) cor ($labt <> emptystr):
%show str $, $labt;
        elabeli (
          if _automatic_ and (str labt = "lab"): % real automatic label
            indexedtxt ($labt, eindex_(strs))
          else:
            txt ($labt)
          fi,
          $labt.pos transformed tr, $labt.ori transformed $t); % do not rotate labels
      fi;
    endfor;
  fi;

enddef;

vardef edraw =
  if preparedelems <> "":
    efixpos_;

    save strs, tr;
    string strs; transform tr;
    forsuffixes $ = stk preparedelems:
      strs := str $;				% used in |edraw_int_|
      edraw_int_ ($, stk (etype_(strs))._);
    endfor;
  fi;
  preparedwires;				% draw wires
  def preparedwires = enddef;			% clear wire list
enddef;
%%--------------------------------------------------
%%--------------------------------------------------
transform T, T.h, T.v;
T = identity rotated 45;			% something different from 0
T.h = identity;
T.v = T.h rotated 90;

transform T.l, T.u, T.r, T.d, T.L, T.U, T.R, T.D;
T.r = identity;
T.u = T.r rotated 90;
T.l = T.r rotated 180;
T.d = T.r rotated 270;
T.R = T.r yscaled -1;
T.U = T.u xscaled -1;
T.L = T.l yscaled -1;
T.D = T.d xscaled -1;

vardef wire@# (expr a, b) = pickup wirepen;
  draw a if yxpart T.@# = 0: --(xpart b,ypart a)
         elseif xxpart T.@# = 0: --(xpart a,ypart b) fi
         --b;
enddef;


vardef xidraw@# (expr z) text t =
  pair lz__; lz__ := z;
  pickup wirepen;
  if str @# = "":
    draw z for $ = t: -- hide(lz__ := lz__ + $) lz__ endfor;
  else:
    pair w__; w__ := wiredir@#;
    draw z for $ = t: --
      hide(lz__:=lz__+ w__ * $; w__:=w__ rotated 90)
      lz__
    endfor
  fi;
enddef;


% draw wire from z
vardef idraw@# (expr z) text t =
  pair lz__; lz__ := z;
  pickup wirepen;
  if str @# = "":
    draw z for $ = t: -- hide(lz__ := lz__ + $) lz__ endfor;
  else:
    boolean hor__;
    hor__ := (str @# = "h");
    draw z for $ = t: --
      hide(lz__:=lz__+ if hor__: ($,0) else: (0,$) fi; hor__:=not hor__)
      lz__
    endfor
  fi;
enddef;


% define equation from a to b
vardef conn@# (suffix a,b) text t =
  begingroup
    save draw, --; let draw=gobble; let --=gobble; % switch off drawing
    idraw@# (a) t;
  endgroup;
  if unknown (lz__ - b):
    lz__ = b;					% add equation
  elseif abs(lz__-b) > eps:
    message "Inconsistent connection between " & str a & " and " & str b;
  fi;
  expandafter def expandafter preparedwires expandafter = % append draw calls
    preparedwires idraw@# (a) t;
  enddef;
enddef;

% draw wire from a to b checking last direction
vardef iwire@# (expr a,b) text t =
  idraw@# (a) t;
  wire   if str @# <> "": if hor__: h else: v fi fi   (lz__,b);
enddef;

% disguised |draw| command
def awire (expr z)(text t) =
  pickup wirepen;
  draw z for $ = t: -- $ endfor;
enddef;


vardef oldbetw@# (suffix e,a_,b_) =
  if str @# = "":
    e = .5[a_,b_];
    e.t = identity rotated (angle (b_ - a_));
  else:
    e = if yxpart T.@# = 0:
      (xpart .5[a_,b_], ypart a_);
    else:
      (xpart a_, ypart .5[a_,b_]);
    fi;
    e.t = T.@#;
  fi;
  expandafter def expandafter preparedwires expandafter = % append draw calls
    preparedwires wire@# (a_,e.a); wire@# (e.b,b_);
  enddef;
enddef;


vardef addwire@# (expr a, b) =
  expandafter def expandafter preparedwires expandafter = % append draw calls
    preparedwires wire@# (a,b);
  enddef;
%showtoken preparedwires;
enddef;


vardef betw@# (suffix $) text t_ =
  save s;
  string s, pinnames_, pins_[];
  numeric i_;
  pair p_, a_, b_, c_;

  s := etype_(str $) & "._";
  if unknown stk(s).pic: require stk s; fi;

  i_ := 0;
  pinnames_ := stk (s).pinnames;
  if pinnames_ <> "":				% if elem has pins
    forsuffixes pint = stk (pinnames_):
      pins_[incr(i_)] := str pint;
    endfor;
  fi;
  pincnt_ := i_;
  i_ := 0;
  for ss = t_:
    exitif i_ >= pincnt_;
    p_ := if pair ss: ss else: z[ss] fi;
%elseif numeric ss: z[ss]
    if i_ = 0:
      c_ := a_ := p_;
    elseif i_ = 1:				% set pos after two iters
      b_ := p_;
    fi;
    c_ := .5[c_, p_];				% center of gravity

    addwire@# ($.stk (pins_[incr(i_)]), p_);
  endfor;

  if str @# = "":
    if pincnt_ = 2:
      $ = .5[a_,b_];
      condset ($.t, identity rotated (angle (b_ - a_)));
    else:
      $ = c_;
    fi;
  else:
    $ = if yxpart T.@# = 0: (xpart .5[a_,b_], ypart a_);
        else: (xpart a_, ypart .5[a_,b_]); fi;
    condset ($.t, T.@#);
  fi;

enddef;

vardef abetw@# (suffix $) text t_ =
  betw@# ($) t_;
  if yxpart T.@# = 0: halign else: valign fi t_;
enddef;


J_dia  := .3u;
def junction text t_ =
  pickup pencircle scaled J_dia;
  for $ = t_:
    drawdot if pair $: $ else: z[$] fi;
  endfor;
enddef;

def labeledjunction text t_ =
  pickup pencircle scaled J_dia;
  forsuffixes $ = t_:
    dotlabel.ulft (str $, if pair $: $ else: z[$] fi);
  endfor;
enddef;

def placenodes text t_ =
  forsuffixes $ = t_:
    condset (z$, (uniformdeviate 30u, uniformdeviate 30u));
  endfor;
enddef;


%%--------------------------------------------------
def equally_spaced (expr dx,dy) text t =
  (whatever,whatever) for u=t: -u = u endfor gobbled true - (dx,dy)
enddef;

def halign text t = for u=t: ypart (if pair u: u else: z[u] fi) = endfor
  whatever enddef;
def valign text t = for u=t: xpart (if pair u: u else: z[u] fi) = endfor
  whatever enddef;

% Draw grid with spacing |d| over the |currentpicture| region.
vardef egrid (expr d) =
  save a, b, i, ll, ur;
  pair ll, ur;
  numeric a, b, i;
  ll := llcorner currentpicture;
  ur := urcorner currentpicture;

  a := ceiling (xpart (ur - ll) / d) + 1;
  b := ceiling (ypart (ur - ll) / d) + 1;
  draw image (
  for i=0 upto a:
    draw (i*d, 0)--(i*d, b*d) withpen pensquare scaled 0.01bp withcolor .5white;
  endfor;
  for i=0 upto b:
    draw (0, i*d)--(a*d, i*d) withpen pensquare scaled 0.01bp withcolor .5white;
  endfor;
  ) shifted (d*(ceiling (xpart ll/d)-1), d*(ceiling (ypart ll/d)-1));
enddef;
%================================


fi;
endinput
%====================================================
% $Log: mpcirc.mp,v $
% Revision 1.28  1997/05/24 19:33:15  tjchol01
% Added abetw and node interpretation in halign/valign.
%
% Revision 1.27  1997/03/04 04:13:44  tjchol01
% Moved log to the end.  A bit of cleanup.
%
% Revision 1.26  1997/03/04 01:18:02  tjchol01
% Before changes.
%
% Revision 1.25  1996/12/08 23:27:25  tjchol01
% n-pin |betw|, |junction|, |placenodes|.
%
% Revision 1.24  1996/12/04 02:50:25  tjchol01
% Added |cand|, |cor|, |epos| (probably buggy), using transform directions.
%
% Revision 1.23  1996/12/02 01:07:44  tjchol01
% |prepare| with transform.
%
% Revision 1.22  1996/11/30 07:18:45  tjchol01
% |addlabel| working.
%
% Revision 1.21  1996/11/30 05:48:02  tjchol01
% Removed double definitions in |require|.
%
% Revision 1.20  1996/11/30 04:50:31  tjchol01
% Changed |preparedelems| to string.
%
% Revision 1.19  1996/11/30 04:33:37  tjchol01
% |image| inlined to reduce stack usage, using |$$| for element type.
%
% Revision 1.18  1996/11/28 22:26:16  tjchol01
% Modified |condset|, moved label fixing code to edraw.
%
% Revision 1.17  1996/11/28 20:51:24  tjchol01
% |picpos| used for label positioning.  Some cleanup.
%
% Revision 1.16  1996/11/28 18:43:09  tjchol01
% Added value handling, working on |picpos|.
%
% Revision 1.15  1996/11/28 08:31:20  tjchol01
% Modified wiring to use suffixes.
%
% Revision 1.14  1996/11/28 06:07:08  tjchol01
% Nesting working with |generic_clear|.
%
% Revision 1.13  1996/11/27 08:30:40  tjchol01
% Nesting not working.
%
% Revision 1.12  1996/11/26 06:10:12  tjchol01
% Incremental positioning, setlabel and elabel with labori, conn, egrid.
%
% Revision 1.11  1996/11/24 21:53:44  tjchol01
% Nested circuits with begincirc...endcirc.
%
% Revision 1.10  1996/11/24 05:56:55  tjchol01
% Generalized element naming using |generic_decl| from boxes.mp
%
% Revision 1.9  1996/11/23 07:57:17  tjchol01
% |defelem| with text argument.
%
% Revision 1.8  1996/11/23 07:27:40  tjchol01
% Simplified pin declarations.
%
% Revision 1.7  1996/11/23 04:41:10  tjchol01
% Variable clearing working.
%
% Revision 1.6  1996/11/22 21:00:22  tjchol01
% Before addpin.
%
% Revision 1.5  1996/11/22 20:41:11  tjchol01
% Extracted ttex, using single inclusion.
%
% Revision 1.4  1996/11/20 23:40:24  tjchol01
% Used for wisen.
%
% Revision 1.3  1996/11/18 16:18:44  tjchol01
% Renamed to mpcirc.
%
% Revision 1.2  1996/11/15 03:48:27  tjchol01
% R, L, C, J, U, and fixed traf working without labels.
%
% Revision 1.1  1996/11/15 02:44:49  tjchol01
% Initial revision

% Local Variables:
% compile-command: "mpost '\\nonstopmode; input lata'"
% End: