unit TCG;
  { Test and Complement Gates }

interface

type
  Gate = record msk, val: integer end;

procedure toss(width: integer; nm, nv: integer; var g: Gate);

procedure clear(var g: Gate);

procedure mutate(width: integer; var g: Gate);

procedure merge(g1, g2: Gate; var z: Gate);

function eval(w: integer; var g: Gate): integer;

function eq(g1, g2: Gate): boolean;

function less(g1, g2: Gate): boolean;
  { Gate $g1$ precededs $g2$ in the canonical gate ordering.
    (Increasing domain size, increasing mask binval,
     then increasing test pattern binval, then increasing
     action binval.) }

function diff(g1, g2: Gate): integer;

procedure print(var f: text; width: integer; g: Gate);

procedure simp1(var g: Gate);
  { Simplifies $g$ if possible.  That is, if
    $g$ is a no-op gate, replaces it by the
    canonical one (all '.'s). }

procedure simp2(var g1, g2: Gate);
  { Simplifies the pair $g1 g2$ (assumed to be consecutive
    instructions of a program, executed in that order)
    to the lexicographically smallest pair of gates
    equivalent to the original ones.
    In particular, if $g1, g2$ can be replaced by a
    single gate, or is a no-op, on exit $g1$ will be the
    canonical no-op gate (all '.'). }

implementation

type sign = -1..+1;

procedure clear(var g: Gate);
  begin
    g.msk := 0;
    g.val := 0;
  end;

procedure print(var f: text; width: integer; g: Gate);
  var i: integer;
  begin
    for i := width-1 downto 0 do
      begin
        if odd(g.msk shr i) then
          if odd(g.val shr i) then
            write(f, '0')
          else
            write(f, '1')
        else
          if odd(g.val shr i) then
            write(f, 'x')
          else
            write(f, '.')
      end
  end;

function ranword: integer;
  var i, w: integer;
  begin
    w := 0;
    for i := 1 to 4 do w := (w shl 8) or random(256);
    ranword := w
  end;

function ones(w: integer): integer;
  var i, d: integer;
  begin
    d := 0;
    while w <> 0 do
      begin
        if odd(w) then inc(d);
        w := w shr 1
      end;
    ones := d
  end;

function diff(g1, g2: Gate): integer;
  begin
    diff := ones(g1.msk xor g2.msk) + ones(g1.val xor g2.val)
  end;

procedure toss(width: integer; nm, nv: integer; var g: Gate);
  var clip: integer;
      m, v: integer;
      i: integer;
  begin
    clip := (1 shl width) - 1;
    m := 0;
    for i := 0 to width-1 do
      if nm >= random * width then
        m := m or (1 shl i);
    v := ranword and m;
    for i  := 0 to width-1 do
      if ((m and (1 shl i)) = 0) then
        if nv >= random * (width - nm) then
          v := v or (1 shl i);
    g.msk := m and clip;
    g.val := v and clip;
  end;

function eq(g1, g2: Gate): boolean;
  begin
    eq := (g1.msk = g2.msk) and (g1.val = g2.val)
  end;

function cmp_unsigned(x, y: integer): sign;
  var bx, by: longint;
  begin
    bx := x; bx := bx and (256*256-1);
    by := y; by := by and (256*256-1);
    if bx < by then
      cmp_unsigned := -1
    else if bx > by then
      cmp_unsigned := +1
    else
      cmp_unsigned := 0
  end;

function cmp_mask(x, y: integer): sign;
  var ox, oy: integer;
  begin
    ox := ones(x);
    oy := ones(y);
    if ox < oy then
      cmp_mask := -1
    else if ox > oy then
      cmp_mask := +1
    else
      cmp_mask := cmp_unsigned(x, y);
  end;

function less(g1, g2: Gate): boolean;
  var cm, ct, cv: integer;
  begin
    { CAUTION: if you change the definition of $less()$,
      you must also change the definition of $simp2$. }
    cm := cmp_mask(g1.msk, g2.msk);
    if cm = -1 then
      less := true
    else if cm = +1 then
      less := false
    else
      begin
        if g1.msk <> g2.msk then runerror;
        ct := cmp_unsigned(g1.val and g1.msk, g2.val and g2.msk);
        if ct = -1 then
          less := true
        else if ct = +1 then
          less := false
        else
          begin
            cv := cmp_unsigned(
              g1.val and not g1.msk,
              g2.val and not g2.msk
            );
            less := (cv = -1)
          end
      end
  end;

procedure mutate_domain(width: integer; var g: Gate);
  var i: integer;
  begin
    if (g.val and not g.msk) = ((1 shl width) - 1) then runerror;
    repeat
      i := 1 shl random(width);
    until ((g.msk and i) <> 0) or ((g.val and i) = 0);
    if ((g.msk and i) = 0) then
      begin
        { Convert a '.' into '1' or '0' }
        g.msk := g.msk or i;
        if random(2) = 0 then g.val := g.val or i;
      end
    else
      begin
        { Convert a '1' or '0' to '.' }
        g.msk := g.msk and not i;
        g.val := g.val and not i
      end;
  end;

procedure mutate_action(width: integer; var g: Gate);
  var i: integer;
  begin
    if g.msk = ((1 shl width) - 1) then runerror;
    repeat
      i := 1 shl random(width);
    until (g.msk and i) = 0;
    g.val := g.val xor i
  end;

procedure mutate(width: integer; var g: Gate);
  var allones: integer;
  begin
    allones := ((1 shl width) - 1);
    if (g.msk = allones)
    or ((random(2) = 0) and ((g.val and not g.msk) <> allones)) then
      mutate_domain(width, g)
    else
      mutate_action(width, g)
  end;

procedure merge(g1, g2: Gate; var z: Gate);
  var d: integer;
  begin
    d := g1.msk xor g2.msk;
    z.msk := g1.msk xor (d and ranword);
    d := g1.val xor g2.val;
    z.val := g1.val xor (d and ranword);
  end;

function eval(w: integer; var g: Gate): integer;
  var t: integer;
  begin
    t := w xor g.val;
    if (t and g.msk) = 0 then
      eval := w xor ((not g.msk) and g.val)
    else
      eval := w
  end;

procedure simp1(var g: Gate);
  begin
    if ((g.val and not g.msk) = 0) then
      begin
        g.msk := 0; g.val := 0;
      end;
  end;

function nested_domains(g1, g2: Gate): boolean;
  begin
    nested_domains :=
      ((g1.msk and g2.msk) = g2.msk) and
      ((g1.val and g2.msk) = (g2.val and g2.msk))
  end;

procedure simp2_same_action(var g1, g2: Gate);
  { Same as simp2(g1, g2), but assumes they have the same action
    on different domains. }
  var dv, dm, dv0, dv1, dm0, dm1: integer;
      gt: Gate;
  begin
    if (g1.val and not g1.msk) <> (g2.val and not g2.msk) then runerror;
    dv := g1.val xor g2.val;
    dm := g1.msk xor g2.msk;
    if (g1.msk = g2.msk) and (ones(dv) = 1) then
      begin
        { Twin domains, merge into one gate: }
        g2.msk := g2.msk and not dv;
        g2.val := g2.val and not dv;
        g1.msk := 0; g2.msk := 0
      end
    else if (g1.msk = g2.msk) and (ones(dv) = 2) then
      begin
        { Disjoint k-faces adjacent by a (k-2)-face. }
        { Replace by two overlapping (k+1)-faces: }
        dv0 := (dv xor (dv-1)) and dv;
        dv1 := dv xor dv0;
        g1.msk := g1.msk and not dv1;
        g1.val := g1.val and not dv1;
        g2.msk := g2.msk and not dv0;
        g2.val := g2.val and not dv0;
        if not less(g1, g2) then runerror;
      end
    else if (ones(dm) = 1)
    and ((dv and (g1.msk and g2.msk)) = 0) then
      begin
        { A (k-1)-face contained in a k-face; }
        { Replace both by the complement of the former. }
        if ones(dv) > 1 then runerror;
        g2.val := (g1.val or g2.val) xor dm;
        g2.msk := g1.msk or g2.msk;
        g1.msk := 0; g1.val := 0;
      end
    else if (ones(dm) = 1)
    and (ones(dv and g1.msk and g2.msk) = 1) then
      begin
        { A k-face and a (k-1)-face adjacent by a (k-2)-face. }
        { Replace by a (k+1)-face and another (k-1)-face. }
        gt.msk := g1.msk and g2.msk and not dv;
        gt.val := (g1.val and g2.val);
        if (g1.msk or g2.msk) = g1.msk then
          g2.val := g1.val xor (dv and g2.msk)
        else
          g2.val := g2.val xor (dv and g1.msk);
        g2.msk := g1.msk or g2.msk;
        g1 := gt;
      end
    else if (ones(g1.msk) = ones(g2.msk))
    and (ones(dm) = 2)
    and ((dv and (g1.msk and g2.msk)) = 0) then
      begin
        { Two k-faces intersecting in a (k-1)-face: }
        { Rearrange, recut, and repaste so that g1 is minimum. }
        if cmp_mask(g2.msk, g1.msk) = -1 then
          begin gt := g1; g1 := g2; g2 := gt end;
        dm0 := (dm xor (dm-1)) and dm;
        dm1 := dm xor dm0;
        if (dm1 and g1.msk) <> 0 then runerror;
        if (g1.val and dm0) = 1 then
          begin
            g1.val := g1.val xor dm0;
            g2.val := g2.val xor dm1;
          end
      end
    else if less(g2, g1) then
      begin
        { Other cases; just swap the gates: }
        gt := g1; g1 := g2; g2 := gt
      end
    else
      begin
        { We can't do anything, can we? }
      end;
    if not less(g1, g2) then runerror;
  end;

procedure simp2(var g1, g2: Gate);
  var gt: Gate;
      t: integer;
  begin
    simp1(g1);
    simp1(g2);
    if (g1.msk = g2.msk)
    and (ones((g1.val xor g2.val) and g1.msk) = 1)
    and (((g1.val xor g2.val) and not g1.msk) = 0) then
      begin
        { Twin domains; merge two gates in one }
        t := g1.val xor g2.val;
        g2.msk := g2.msk and not t;
        g2.val := g2.val and not t;
        g1.msk := 0;
        g1.val := 0;
      end
    else if (g1.msk = g2.msk) and (g1.val = g2.val) then
      begin
        { Equal gates, replace by two no-ops: }
        g1.msk := 0; g1.val := 0;
        g2.msk := 0; g2.val := 0
      end
    else if (g1.msk = g2.msk)
    and (((g1.val xor g2.val) and g1.msk) = 0) then
      begin
        { Same domains, combine actions: }
        g2.val := g2.val xor (g1.val and not g1.msk);
        g1.msk := 0; g1.val := 0
      end
    else if ((g1.val and not g1.msk) = (g2.val and not g2.msk)) then
      begin
        { Same action, try to rearrange domains: }
        simp2_same_action(g1, g2)
      end
    else if ((g1.msk and g2.msk) and (g1.val xor g2.val)) <> 0 then
      begin
        { Disjoint domains; just sort them. }
        if less(g2, g1) then
          begin gt := g1; g1 := g2; g2 := gt end;
      end
    else if nested_domains(g1, g2) and less(g2, g1) then
      begin
        { g2 has smaller mask, commute the two gates: }
        g1.val := g1.val xor (g1.msk and (not g2.msk and g2.val));
        gt := g1; g1 := g2; g2 := gt
      end
    else if nested_domains(g2, g1) then
      begin
        { g1 has smaller mask, no use in commuting: }
      end
    else
      begin
        { Different actions on overlapping, non-nested domains: }
        { there is nothing we can do, is there? }
      end;
  end;

end.