# Teach Maple (through depends and eval) about our new binding forms.
# lam binds from 1st arg to 3rd arg.
# Branch binds from 1st arg (a pattern) to 2nd arg.
# Bind and ary bind from 2nd arg to 3rd arg.

# note that v _can_ in principle occur in t.
`depends/lam` := proc(v::name, t, e, x, $)
  depends(t, x) or depends(e, x minus {v})
end proc:

`depends/Branch` := proc(p, e, x, $)
  depends(e, x minus {Hakaru:-pattern_binds(p)})
end proc:

# note that v _can_ occur in m1.
`depends/Bind` := proc(m1, v::name, m2, x, $)
  depends(m1, x) or depends(m2, x minus {v})
end proc:

# note that i _can_ occur in n.
`depends/ary` := proc(n, i::name, e, x, $)
  depends(n, x) or depends(e, x minus {i})
end proc:
`depends/Plate` := eval(`depends/ary`):

`eval/lam` := proc(e, eqs, $)
  local v, t, ee;
  v, t, ee := op(e);
  v, ee := BindingTools:-generic_evalat(v, ee, eqs);
  t := eval(t, eqs);
  eval(op(0,e), eqs)(v, t, ee)
end proc:

`eval/Branch` := proc(e, eqs, $)
  local p, ee, vBefore, vAfter;
  p, ee := op(e);
  vBefore := [Hakaru:-pattern_binds(p)];
  vAfter, ee := BindingTools:-generic_evalat(vBefore, ee, eqs);
  eval(op(0,e), eqs)(subs(op(zip(`=`, vBefore, vAfter)), p), ee)
end proc:

`eval/Bind` := proc(e, eqs, $)
  local m1, v, m2;
  m1, v, m2 := op(e);
  eval(op(0,e), eqs)(eval(m1, eqs), BindingTools:-generic_evalat(v, m2, eqs))
end proc:

`eval/ary` := proc(e, eqs, $)
  local n, i, ee;
  n, i, ee := op(e);
  eval(op(0,e), eqs)(eval(n, eqs), BindingTools:-generic_evalat(i, ee, eqs))
end proc:
`eval/Plate` := eval(`eval/ary`):

#############################################################################
Hakaru := module ()
  option package;
  local p_true, p_false, make_piece, Mk_Plus, lift1_piecewise,
        ModuleLoad, ModuleUnload;
  export
     # These first few are smart constructors (for themselves):
         case, app, ary, idx, fst, snd, size, Datum,
     # while these are "proper functions"
         verify_measure, verify_hboolean, pattern_equiv,
         piecewise_And, map_piecewiselike, lift_piecewise, foldr_piecewise,
         flatten_piecewise,
         pattern_match, pattern_binds,
         closed_bounds, open_bounds,
         htype_patterns,
         bool_And, bool_Or, bool_Not,
         UpdateArchive;
  # These names are not assigned (and should not be).  But they are
  # used as global names, so document that here.
  global
     # Basic syntax for composing measures
         Bind, Weight, Ret, Msum, Plate, Context, Pair, _Unit, PARTITION,
     # Primitive (known) measures
         Lebesgue, Uniform, Gaussian, Cauchy, StudentT, BetaD,
         GammaD, ChiSquared,
         Counting, Categorical, NegativeBinomial, PoissonD,
     # Functions, annotated with argument type, applied using "app"
         lam,
     # Term constructors for Datum (algebraic data type)
         Inr, Inl, Et, Done, Konst, Ident,
     # The parts of "case" besides the scrutinee
         Branches, Branch,
     # Pattern constructors
         PWild, PVar, PDatum, PInr, PInl, PEt, PDone, PKonst, PIdent,
     # Verification of alpha-equivalence among measures
         measure,
     # Punctuation for matching free variables with measures for disintegration
         `&M`,
     # Structure types for Hakaru types and Hakaru "case" expressions
         known_continuous, known_discrete, t_Hakaru, t_type, t_case,
     # Structure types for piecewise-like expressions:
     # piecewise, case, and idx into literal array
         t_pw, t_piecewiselike,
     #other types
         `&implies`,
     # Type constructors for Hakaru
         AlmostEveryReal, HReal, HInt, HData, HMeasure, HArray, HFunction,
         Bound, DatumStruct;
  p_true  := 'PDatum(true,PInl(PDone))';
  p_false := 'PDatum(false,PInr(PInl(PDone)))';

  case := proc(e, bs :: specfunc(Branch(anything, anything), Branches), $)
    local ret, b, substs, eSubst, pSubst, p, binds, uncertain;
    if e :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      ret := Branches();
      for b in bs do
        substs := pattern_match(e, e, op(1,b));
        if substs <> NULL then
          eSubst, pSubst := substs;
          p := subs(pSubst, op(1,b));
          binds := {pattern_binds(p)};
          uncertain := remove((eq -> lhs(eq) in binds), eSubst);
          if nops(uncertain) = 0 then p := PWild end if;
          ret := Branches(op(ret),
                          Branch(p, eval(eval(op(2,b), pSubst), eSubst)));
          if nops(uncertain) = 0 then break end if;
        end if
      end do;
      if ret :: Branches(Branch(identical(PWild), anything)) then
        op([1,2], ret)
      elif ret :: Branches(Branch(identical(p_true), anything),
                           Branch({identical(p_false),
                                   identical(PWild),
                                   PVar(anything)}, anything)) then
        piecewise(make_piece(e), op([1,2], ret), op([2,2], ret))
      elif ret :: Branches(Branch(identical(p_false), anything),
                           Branch({identical(p_true),
                                   identical(PWild),
                                   PVar(anything)}, anything)) then
        piecewise(make_piece(e), op([2,2], ret), op([1,2], ret))
      else
        'case'(e, ret)
      end if
    end if
  end proc;

  pattern_match := proc(e0, e, p, $)
    local x, substs, eSubst, pSubst;
    if p = PWild then return {}, {}
    elif p :: PVar(anything) then
      x := op(1,p);
      pSubst := {`if`(depends(e0,x), x=gensym(x), NULL)};
      return {subs(pSubst,x)=e}, pSubst;
    elif p = p_true then
      if e = true then return {}, {}
      elif e = false then return NULL
      end if
    elif p = p_false then
      if e = false then return {}, {}
      elif e = true then return NULL
      end if
    elif p :: PDatum(anything, anything) then
      if e :: Datum(anything, anything) then
        if op(1,e) = op(1,p) then return pattern_match(e0, op(2,e), op(2,p))
        else return NULL
        end if
      end if
    elif p :: PInl(anything) then
      if e :: Inl(anything) then return pattern_match(e0, op(1,e), op(1,p))
      elif e :: Inr(anything) then return NULL
      end if
    elif p :: PInr(anything) then
      if e :: Inr(anything) then return pattern_match(e0, op(1,e), op(1,p))
      elif e :: Inl(anything) then return NULL
      end if
    elif p :: PEt(anything, anything) then
      if e :: Et(anything, anything) then
        substs := pattern_match(e0, op(1,e), op(1,p));
        if substs = NULL then return NULL end if;
        eSubst, pSubst := substs;
        substs := pattern_match(e0, eval(op(2,e),eSubst), op(2,p));
        if substs = NULL then return NULL end if;
        return eSubst union substs[1], pSubst union substs[2];
      elif e = Done then return NULL
      end if
    elif p = PDone then
      if e = Done then return {}, {}
      elif e :: Et(anything, anything) then return NULL
      end if
    elif p :: PKonst(anything) then
      if e :: Konst(anything) then return pattern_match(e0, op(1,e), op(1,p))
      end if
    elif p :: PIdent(anything) then
      if e :: Ident(anything) then return pattern_match(e0, op(1,e), op(1,p))
      end if
    else
      error "pattern_match: %1 is not a pattern", p
    end if;
    pSubst := map((x -> `if`(depends(e0,x), x=gensym(x), NULL)),
                  {pattern_binds(p)});
    eSubst := {e=subsindets(
                   subsindets[nocache](
                     subs(pSubst,
                          p_true=true,
                          p_false=false,
                          PDatum=Datum, PInr=Inr, PInl=Inl, PEt=Et, PDone=Done,
                          PKonst=Konst, PIdent=Ident,
                          p),
                     identical(PWild),
                     p -> gensym(_)),
                   PVar(anything),
                   p -> op(1,p))};
    eSubst, pSubst
  end proc;

  make_piece := proc(rel, $)
    # Try to prevent PiecewiseTools:-Is from complaining
    # "Wrong kind of parameters in piecewise"
    if rel :: {specfunc(anything, {And,Or,Not}), `and`, `or`, `not`} then
      map(make_piece, rel)
    elif rel :: {'`::`', 'boolean', '`in`'} then
      rel
    else
      rel = true
    end if
  end proc;

  pattern_binds := proc(p, $)
    if p = PWild or p = PDone then
      NULL
    elif p :: PVar(anything) then
      op(1,p)
    elif p :: PDatum(anything, anything) then
      pattern_binds(op(2,p))
    elif p :: {PInl(anything), PInr(anything),
               PKonst(anything), PIdent(anything)} then
      pattern_binds(op(1,p))
    elif p :: PEt(anything, anything) then
      pattern_binds(op(1,p)), pattern_binds(op(2,p))
    else
      error "pattern_binds: %1 is not a pattern", p
    end if
  end proc:

  verify_hboolean := proc(a, b, $)
    local x,y,conv_tbl,and_fn,or_fn,not_fn;
    and_fn := ((x->AND({op(x)}))@`bool_And`);
    or_fn  := ((x->OR({op(x)}))@`bool_Or`);
    not_fn := bool_Not;
    conv_tbl := table([`and`=and_fn,`And`=and_fn,`Or`=or_fn,`or`=or_fn,`Not`=not_fn,`not`=not_fn]);
    x,y := subsindets([a,b], Or(`and`,`or`,`not`, specfunc({`And`,`Or`,`Not`})), x->conv_tbl[op(0,x)](op(x)))[];
    evalb(x=y);
  end proc;

  verify_measure := proc(m, n, v:='hboolean', $)
    local mv, x, i, j, k;
    mv := measure(v);
    if m :: specfunc({Bind, Plate}) and n :: specfunc({Bind, Plate}) and
       (verify(m, n, 'Bind'(mv, true, true))
      or verify(m, n, 'Plate'(v, true, true))) then
      x := gensym(cat(op(2,m), "_", op(2,n), "_"));
      thisproc(subs(op(2,m)=x, op(3,m)),
               subs(op(2,n)=x, op(3,n)), v)
    elif m :: 'specfunc(Msum)' and n :: 'specfunc(Msum)'
         and nops(m) = nops(n) then
      k := nops(m);
      verify(k, GraphTheory[BipartiteMatching](GraphTheory[Graph]({
                seq(seq(`if`(thisproc(op(i,m), op(j,n), v), {i,-j}, NULL),
                        j=1..k), i=1..k)}))[1]);
    elif andmap(type, [m,n], 'specfunc(piecewise)') and nops(m) = nops(n) then
      k := nops(m);
      verify(m, n, 'piecewise'(seq(`if`(i::even or i=k, mv, hboolean), i=1..k)));

    elif andmap(type, [m,n], 'specfunc(PARTITION)') then
      Partition:-SamePartition(verify_hboolean, verify_measure, m, n);

    elif m :: specfunc('case') and
        verify(m, n, 'case'(v, specfunc(Branch(true, true), Branches))) then
      # This code unfortunately only handles alpha-equivalence for 'case' along
      # the control path -- not if 'case' occurs in the argument to 'Ret', say.
      k := nops(op(2,m));
      for i from 1 to k do
        j := pattern_equiv(op([2,i,1],m), op([2,i,1],n));
        if j = false then return j end if;
        j := map(proc(eq, $)
                   local x;
                   x := gensym(cat(lhs(eq), "_", rhs(eq), "_"));
                   [lhs(eq)=x, rhs(eq)=x]
                 end proc, j);
        j := thisproc(subs(map2(op,1,j), op([2,i,2],m)),
                      subs(map2(op,2,j), op([2,i,2],n)), v);
        if j = false then return j end if;
      end do;
      true
    elif m :: 'LO(name, anything)' and n :: 'LO(name, anything)' then
      x := gensym(cat(op(1,m), "_", op(1,n), "_"));
      verify(subs(op(1,m)=x, op(2,m)),
             subs(op(1,n)=x, op(2,n)), v)
    elif m :: specfunc('lam') and n :: specfunc('lam') and
        verify(m, n, 'lam'(true, v, true)) then
      # m and n are not even measures, but we verify them anyway...
      x := gensym(cat(op(1,m), "_", op(1,n), "_"));
      thisproc(subs(op(1,m)=x, op(2,m)),
               subs(op(1,n)=x, op(2,n)), v)
    else
      verify(m, n, {v, Ret(v), Weight(v, mv), Context(v, mv)})
    end if
  end proc;

  pattern_equiv := proc(p, q, $) :: {identical(false),set(`=`)};
    local r, s;
    if ormap((t->andmap(`=`, [p,q], t)), [PWild, PDone]) then
      {}
    elif andmap(type, [p,q], PVar(anything)) then
      {op(1,p)=op(1,q)}
    elif andmap(type, [p,q], PDatum(anything,anything)) and op(1,p)=op(1,q) then
      pattern_equiv(op(2,p),op(2,q))
    elif ormap((t->andmap(type, [p,q], t(anything))),
               [PInl, PInr, PKonst, PIdent]) then
      pattern_equiv(op(1,p),op(1,q))
    elif andmap(type, [p,q], PEt(anything, anything)) then
      r := pattern_equiv(op(1,p),op(1,q));
      s := pattern_equiv(op(2,p),op(2,q));
      if map(lhs,r) intersect map(lhs,s) = {} and
         map(rhs,r) intersect map(rhs,s) = {} then
        r union s
      else
        false
      end if
    else
      false
    end if
  end proc;

  piecewise_And := proc(cond::{list,set,specfunc(`And`),`and`}, th, el, $)
    if nops(cond) = 0 or th = el then
      th
    else
      piecewise(And(op(cond)), th, el)
    end if
  end proc;

  map_piecewiselike := proc(f, p::t_piecewiselike)
    local i, g, h;
    if p :: 'specfunc(piecewise)' then
      piecewise(seq(`if`(i::even or i=nops(p), f(op(i,p),_rest), op(i,p)),
                    i=1..nops(p)))
    elif p :: 't_case' then
      # Mind the hygiene
      subsindets(eval(subsop(2 = map[3](applyop, g, 2, op(2,p)), p),
                      g=h(f,_rest)),
                 'typefunc(specfunc(h))',
                 (e -> op([0,1],e)(op(1,e), op(2..-1,op(0,e)))))
    elif p :: 'idx(list, anything)' then
      idx(map(f,op(1,p),_rest), op(2,p))
    else
      error "map_piecewiselike: %1 is not t_piecewiselike", p
    end if
  end proc;

  lift_piecewise := proc(e, extra:={}, $)
    local e1, e2;
    e2 := e;
    while e1 <> e2 do
      e1 := e2;
      e2 := subsindets(e1,
              '{extra,
                And(`+`, Not(specop(Not(specfunc(piecewise)), `+`))),
                And(`*`, Not(specop(Not(specfunc(piecewise)), `*`))),
                And(`^`, Not(specop(Not(specfunc(piecewise)), `^`))),
                exp(specfunc(piecewise))}',
              lift1_piecewise)
    end do
  end proc;

  lift1_piecewise := proc(e, $)
    local i, p;
    if membertype(t_piecewiselike, [op(e)], i) then
      p := op(i,e);
      if nops(p) :: even and not (e :: `*`) and op(-1,p) <> 0 then
        p := piecewise(op(p), 0);
      end if;
      map_piecewiselike((arm->lift1_piecewise(subsop(i=arm,e))), p)
    else
      e
    end if
  end proc;

  foldr_piecewise := proc(cons, nil, pw, $) # pw may or may not be piecewise
    # View pw as a piecewise and foldr over its arms
    if pw :: 'specfunc(piecewise)' then
      foldr(proc(i,x) cons(op(i,pw), op(i+1,pw), x) end proc,
            `if`(nops(pw)::odd, cons(true, op(-1,pw), nil), nil),
            seq(1..nops(pw)-1, 2))
    else
      cons(true, pw, nil)
    end if
  end proc;

  #Take a piecewise: If some of the branches also contain piecewises, attempt
  #to re-express the whole as a single piecewise. In short: fewer piecewises, more
  #branches, more complex conditions.--Carl 2016Sep09
  flatten_piecewise:= proc(PW::specfunc(piecewise), $)::specfunc(piecewise);
  local
     pwL:= [op(PW)],
     nP:= nops(pwL),
     conds:= pwL[[seq(1..nP-1, 2)]],
     branches:= pwL[[seq(2..nP-1, 2), nP]],
     innerPW:= indets(branches, specfunc(piecewise)),
     outerPW, C_O, C_I, B_I, r
  ;
     if indets(conds, specfunc(piecewise)) <> {} then
          userinfo(2, procname, "Case of inner pw in a condition not yet handled.");
          return PW
     end if;
     if innerPW = {} then
          userinfo(3, procname, "No inner pw.");
          return PW
     end if;
     if nops~(innerPW) <> {3} then
          userinfo(2, procname, "Case of inner pw of other than 3 ops not yet handled.");
          return PW
     end if;
     if nops(PW) <> 3 then
          userinfo(2, procname, "Case of outer pw of other than 3 ops not yet handled.");
          return PW
     end if;
     outerPW:= applyop(lift_piecewise, {2,3}, PW);
     if membertype(
          And(
               satisfies(e-> indets(e, specfunc(piecewise)) <> {}),
               Not(specfunc(piecewise))
          ),
          {op(2..3, outerPW)}
     )
     then
          userinfo(1, procname, "Unliftable pw.");
          return PW
     end if;
     C_O:= op(1,outerPW);
     C_I:= map(e-> `if`(e::specfunc(piecewise), op(1,e), true), [op(2..3, outerPW)]);
     B_I:= map(e-> `if`(e::specfunc(piecewise), [op(2..3, e)], [e$2])[], [op(2..3, outerPW)]);
     #For debugging purposes, I want to show the proposed output before it's passed to
     #piecewise.
     r:= [
          And(C_O, C_I[1]), B_I[1],
          And(C_O, KB:-negate_rel(C_I[1])), B_I[2],
          And(KB:-negate_rel(C_O), C_I[2]), B_I[3],
          And(KB:-negate_rel(C_O), KB:-negate_rel(C_I[2])), B_I[4]
     ];
     userinfo(3, procname, "Proposed ouput: ", print(%piecewise(r[])));
     piecewise(r[])
  end proc;

  app := proc (func, argu, $)
    if func :: 'lam(name, anything, anything)' then
      eval(op(3,func), op(1,func)=argu)
    elif func :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      'procname(_passed)'
    end if
  end proc;

  ary := proc (n, i, e, $)
    local j;
    if e :: 'idx'('freeof'(i), 'identical'(i)) then
      # Array eta-reduction. Assume the size matches.  (We should keep array
      # size information in the KB and use it here, but we don't currently.)
      op(1,e)
    elif n :: nonnegint then
      [seq(eval(e,i=j), j=0..n-1)] # Unroll array with literal size
    else
      'procname(_passed)'
    end if
  end proc;

  idx := proc (a, i, $)
    if a :: 'ary(anything, name, anything)' then
      eval(op(3,a), op(2,a)=i)
    elif a :: 'list' and i::nonnegint then
      a[i+1]
    elif a :: 'list' and nops(convert(a,'set')) = 1 then
      a[1] # Indexing into a literal array whose elements are all the same
    elif a :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      'procname(_passed)'
    end if
  end proc;

  #Extract the first member of a Pair.
  fst:= proc(p, $)
    if p :: 'Pair'('anything'$2) then
      op(1,p)
    elif p :: t_piecewiselike then
      map_piecewiselike(fst, p)
    else
      'procname'(p)
    end if;
  end proc;

  #Extract the second member of a Pair.
  snd:= proc(p, $)
    if p :: 'Pair'('anything'$2) then
      op(2,p)
    elif p :: t_piecewiselike then
      map_piecewiselike(snd, p)
    else
      'procname'(p)
    end if;
  end proc;

  size := proc(a, $)
    local res;
    if a :: 'ary(anything, name, anything)' then
      op(1,a)
    elif a :: 'list' then
      nops(a)
    elif a :: 't_piecewiselike' then
      map_piecewiselike(procname, _passed)
    else
      'procname(_passed)'
    end if
  end proc;

  Datum := proc(hint, payload, $)
    # Further cheating to equate Maple booleans and Hakaru booleans
    if hint = true and payload = Inl(Done) or
       hint = false and payload = Inr(Inl(Done)) then
      hint
    else
      'procname(_passed)'
    end if
  end proc;

  closed_bounds := proc(r::range, $)
    Bound(`>=`, lhs(r)), Bound(`<=`, rhs(r))
  end proc;

  open_bounds := proc(r::range, $)
    Bound(`>`, lhs(r)), Bound(`<`, rhs(r))
  end proc;

  # Creates an N-ary operator `Plus` such:
  #  Plus(Plus(a,b),c)=Plus(a,Plus(a,b))
  #  Plus(a,Zero)=a
  #  Plus(a)=a
  #  Plus(x,x)=x
  Mk_Plus := proc(plus,zero,$) proc()
    local as := {args};
    as := map(a->if op(0,a)=plus then op(a) else a end if, as);
    if nops(as)=0 then zero
    elif nops(as)=1 then op(1,as)
    else plus(op(as))
    end if;
  end proc; end proc;

  # Replacements for `and` and `or` which do not
  # evaluate "x = y" to "false" when "x,y" are unbound vars.
  bool_And := Mk_Plus('And','true' );
  bool_Or  := Mk_Plus('Or' ,'false');

  bool_Not := proc(a,$)
    if a :: t_kb_atom then
      subsindets(KB:-negate_rel(a), `not`, Not@op);
    else
      Not(a)
    end if;
  end proc;

  # Enumerate patterns for a given Hakaru type
  htype_patterns := proc(t::t_type, $)
    :: specfunc(Branch(anything, list(t_type)), Branches);
    local struct;
    uses StringTools;
    if t :: specfunc(DatumStruct(anything, list(Konst(anything))), HData) then
      foldr(proc(struct,ps,$) Branches(
              op(map((p -> Branch(PDatum(op(1,struct), PInl(op(1,p))),
                                  op(2,p))),
                     foldr(proc(kt,qs,$)
                             local p, q;
                             Branches(seq(seq(Branch(PEt(PKonst(op(1,p)),
                                                         op(1,q)),
                                                     [op(op(2,p)),op(op(2,q))]),
                                              q in qs),
                                          p in htype_patterns(op(1,kt))))
                           end proc,
                           Branches(Branch(PDone, [])), op(op(2,struct))))),
              op(map[3](applyop, PInr, [1,2], ps)))
            end proc,
            Branches(), op(t))
    else
      Branches(Branch(PVar(gensym(convert(LowerCase(op(-1, ["x", op(
                                            `if`(t::function,
                                              select(IsUpper, Explode(op(0,t))),
                                              []))])),
                                          name))),
                      [t]))
    end if
  end proc;

  ModuleLoad := proc($)
    local g; #Iterator over thismodule's globals
    ModuleUnload();
    VerifyTools[AddVerification](measure = eval(verify_measure));
    VerifyTools[AddVerification](hboolean = eval(verify_hboolean));

    TypeTools:-AddType(
         `&implies`,
         proc(e, t1, t2, $) type(e, Or(Not(t1), t2)) end proc
    );
    TypeTools:-AddType(Name, And(name, Not({constant,undefined})));
    TypeTools:-AddType(known_continuous,
         '{
              Lebesgue(anything, anything), Uniform(anything, anything),
              Gaussian(anything, anything), Cauchy(anything, anything),
              StudentT(anything, anything, anything), ChiSquared(anything),
              BetaD(anything, anything), GammaD(anything, anything),
              InverseGammaD(anything, anything)
         }'
    );
    TypeTools:-AddType(known_discrete,
         '{
              Counting(anything, anything),
              Categorical(anything),
              Binomial(anything,anything),
              NegativeBinomial(anything,anything),
              PoissonD(anything)
          }'
    );
    #This type t_Hakaru is the basic syntax checker for that part of the
    #Maple/Hakaru language accessible by the external user.--Carl 2016Sep20
    TypeTools:-AddType(t_Hakaru,
         #Alternation/conjunction of types via {} or And follows the McCarthy
         #short-cut rule: Proceeding left to right, once satisfaction of the type
         #can be determined, the remaining elements aren't evaluated. Therefore,
         #recursive types are possible by placing the base cases at the beginning.
         #But use Or instead of {} because you can't control the order of
         #expressions with {}.
         Or(
           'known_continuous', 'known_discrete',
           t_pw, #Needs to be more specific!
           t_partition,
           t_case,
          'Ret(anything)',
          'Bind(t_Hakaru, name, t_Hakaru)',
          'specfunc(t_Hakaru, Msum)',
          'Weight(algebraic, t_Hakaru)',
          'Plate(algebraic, name, t_Hakaru)',
          t_lam
         )
    );
    TypeTools:-AddType(t_type,
      '{specfunc(Bound(identical(`<`,`<=`,`>`,`>=`), anything),
                 {AlmostEveryReal, HReal, HInt}),
        specfunc(DatumStruct(anything, list({Konst(t_type), Ident(t_type)})),
                 HData),
        HMeasure(t_type),
        HArray(t_type),
        HFunction(t_type, t_type)}');
    TypeTools:-AddType(t_case,
      'case(anything, specfunc(Branch(anything, anything), Branches))');
    TypeTools:-AddType(t_pw, 'specfunc(piecewise)');
    TypeTools:-AddType(t_partition, 'specfunc(PARTITION)'); #Appropriate to put this here?
    TypeTools:-AddType(t_piecewiselike,
      '{specfunc(piecewise), t_case, idx(list, anything)}');
    TypeTools:-AddType(t_lam, 'lam(name, t_type, t_Hakaru)');

    # A temporary type which should be removed when piecewise is gone
    TypeTools:-AddType(t_pw_or_part, Or(t_pw,t_partition));

    #Protect the keywords of the Hakaru language.
    #op([2,6], ...) of a module is its globals.
    for g in op([2,6], thismodule) do
         if g <> eval(g) then
           unassign(g);
           WARNING("Previous value of Hakaru keyword '%1' erased.", g);
         end if;
         protect(g)
    end do
  end proc;

  ModuleUnload := proc($)
    map(proc(x::uneval) try eval(x) catch: NULL; end try end proc,
        ['TypeTools:-RemoveType(`&implies`)'
        ,'TypeTools:-RemoveType(Name)'
        ,'TypeTools:-RemoveType(known_continuous)'
        ,'TypeTools:-RemoveType(known_discrete)'
        ,'TypeTools:-RemoveType(t_Hakaru)'
        ,'TypeTools:-RemoveType(t_pw)'
        ,'TypeTools:-RemoveType(t_partition)'
        ,'TypeTools:-RemoveType(t_pw_or_part)'
        ,'TypeTools:-RemoveType(t_piecewiselike)'
        ,'TypeTools:-RemoveType(t_case)'
        ,'TypeTools:-RemoveType(t_type)'
        ,'TypeTools:-RemoveType(t_lam)'
        ,'VerifyTools[RemoveVerification](measure)'
        ]);
    unprotect(op([2,6], thismodule)); #See comment in ModuleLoad.
    #Skip restoring the globals to any prior value they had.
  end proc;
  ModuleLoad();
end module; # Hakaru


var $const1 <[13] i8> = [ 104, 101, 108, 108, 111, 32, 119, 111, 114, 108, 100, 10, 0 ]
func $printf (var %p1 <* i8>)void
func $main ( ) i32 {
   call &printf (addrof a32 $const1)
   return (constval i32 0) }

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


NAME program var array of begin end if then else procedure return
call break
while do not or div and char integer boolean readln
writeln true false NUMBER STRING + - * = <>
< <= > >= ( ) [ ] := .
, : ;
1 2 3 4 5 6 7 8 9 0 -1 -2 -3 -4 -5 -6 -7 -8 -9
'string'  '''s''t''r''i''n''g''''''s'''  /* string */
read write const
a=b<=c:=-d;

 break


fileinfo{
  @magic 345,
  @filename "adir/thisisafile.dex",
  @dexoffset 560,
  @flags 0x01ef,
  @linksize 100
}
type $SS <class {
        @real f32,
        @imag f32}>
var $sconst1 <class {
        @classidx 22,
        @f11 i32,
        @f22 <$SS>,
        @f33 i32,
        @accessflag 0x45e,
        @classdataoffset 118,
        @f44 i32,
        @f55 f32,
        @f66 f32,
        @superclassid 3333
           }>
func $fact () i32 {
  funcinfo{
    @funcname "afunc",
    @registers 345,
    @ins 560,
    @outs 444
  }
  return (dread i32 $sconst1 1)
  funcinfo{
    @funcidx 345,
    @classidx 560
  }
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


func $foo ( var %i i32, var %j i32, var %k i32) i32 {
   return (
     intrinsicop i32 JSOP_STRICTEQ (
      dread i32 %i,
      intrinsicop i32 JS_NUMBER (dread i32 %k)))
}


# Postprocess Definition File for Code Generation
# Init
# Nachverarbeitung der Datei robot_env. Falls dort mit Maple-Programmcode Teile der DH-Parameter definiert werden, wird diese Datei ausgewertet und die Variablen neu gespeichert.
# Benötigt, da in robot_codegen_tmpvar_bash.sh ein definiertes Muster für die robot_env erwartet wird.
#
# Moritz Schappler, moritz.schappler@imes.uni-hannover.de, 2020-11
# (C) Institut fuer Mechatronische Systeme, Leibniz Universitaet Hannover
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
# Lese Umgebungsvariable für Codegenerierung.
read "../robot_codegen_definitions/robot_env":
printf("Nachverarbeitung der Eingabedatei für %s\n",robot_name):

# Postprocess
# Speichere die Variablen neu ab
NQJ := NQJ:
NJ := NJ:
robot_name := robot_name:
save NQJ, NJ, robot_name, "../robot_codegen_definitions/robot_env2":


gfun:=proc(x)
    uses Grid;
    global y,z,w,u,v;
    print(x,y,z,w,u,v);
    Barrier();
end proc:
Foo:=module()
    option package;
    local x:=1,z:=3;
    export fun;
    fun:=proc()
        local y:=2,w:=4,u:=5,v:=6;
        Grid:-Launch(gfun,x,imports=[':-y'=y,':-z'=z,'w'=w,'u',"v"]);
    end proc:
end module:
Foo:-fun();
y;z;


# Apply a domain to an expression.
# Apply will perform certain 'simplifications' to make sure the
# domain application is well-formed. e.g.,
#   DOMAIN( DBound( [x,y], [xt,yt] ), DConstrain(..) )
#      is the same as
#   DOMAIN(        ..               , DInto(x,xt,DInto(y,yt,DConstrain(..))) )
# basically, when we see an 'unbound' variable in the 'RHS' , we should bind
# it with the default 'DInto'.
export Apply := module ()
  uses Domain_Type, Hakaru, Utilities;
  # Make sure these refer to the global names, or Records don't work
  global context, weights, f_into, f_body, f_sum, f_constrain;

  # Validates input and calls `do_apply' which implements the main logic.  This
  # function returns a function which takes as input the program corresponding
  # to the 'body' (i.e. what is left after extracting the domain bounds and
  # shape) and produces a program equivalent to the original (i.e. what was
  # present before extracting domain bounds and shape), but simplified. In
  # equational language:
  #   let (b,e1) = Extract:-Bound(e0)
  #       (s,e2) = Extract:-Shape(e1)
  #       e3     = Apply(DOMAIN(s,b))(e2)
  #   in  e0 == e3
  # is an invariant of Domain.
  #
  # `Apply' also takes an additional argument, which is a record which should
  # contain handlers which determine how Domain constructors are applied to the
  # resulting expression, and a table of weights which appear outermost to each
  # domain bound variable. Some of these may have defaults (see *** below).
  #
  # The weights table is a mapping from variables appearing in the domain bounds
  # to weights which appear immediately outside the application of that domain
  # bound. It is passed to certain callbacks which can chose where to place said
  # weights.
  #
  # Each handler loosely corresponds to a Domain constructor, except for
  # `f_body'.
  # f_into : DomBoundKind -> LO x -> DomBoundVar -> DomBoundRange -> KB
  #        -> WeightsTable -> LO x
  #   The 1st, 3rd, and 4th arguments come directly from a DomInto;
  #   the 2nd argument is the recursive application of Apply;
  #   the 5th and 6th arguments come from the context
  # f_sum  : Sequence (LO x) -> LO x
  #   Sequence being a Maple sequence (i.e. `f_sum' is an n-ary function)
  # f_constrain : (forall x . LO x -> LO x) -> LO x -> LO x
  #   The 1st argument places a constraint on a LO, the 2nd arguement is the
  #   expression to be constrained.
  # f_body : LO x -> KB -> LO x
  #   This handler is called on the 'body', along with the context in which that
  #   'body' expression exists. This may be called multiple times, if for
  #   example the domain contains `DSum' or `DSplit'.
  export ModuleApply := proc(dom :: HDomain_mb, ctx0::record, $)
    local vs, sh, dbnd, ctx, defctx;
    if dom :: DomNoSol then
      error "cannot apply %1", dom;
    end if;
    dbnd, sh := op(dom);
    # *** Default handlers
    defctx :=
    Record('context'=Domain:-Bound:-contextOf(dbnd)
           ,'f_into'=do_mk
           ,'f_body'=do_body
           ,'f_sum'=`+`
           ,'f_constrain'=((f,x)->f(x)));
    ctx := merge_record_default(defctx,ctx0);
    if not(ctx::'apply_context') or
    {'context'} subset {exports(ctx0)} then
      error "invalid input: %1", ctx0;
    end if;
    vs := Domain:-Bound:-withVarsIxs(dbnd);
    (e->do_apply({}, e, vs, sh, ctx));
  end proc;

  local ModuleLoad := proc($)
    BindingTools:-load_types_from_table(
      # context := the context as a KB
      # weights := the weights outer to each integral
      # f_*     := handlers for subexpressions
      table([apply_context=
             '`record`(`context`,
                       `weights`,
                       `f_into`, `f_body`, `f_sum`, `f_constrain`)']));
  end proc;

  # Helpers for applying only a shape or a bounds.  Note that in the shape case,
  # it may not contain `DInto's as these are only valid in the presence of a
  # non-empty bounds. This is not checked.
  export Shape := proc(dsh :: DomShape, e, $) ModuleApply( DOMAIN( [], dsh ), e ) end proc;
  export Bound := proc(dbn :: DomBound, e, $) ModuleApply( DOMAIN( dbn, DConstrain() ), e ) end proc;

  # main loop of the apply function
  # done_  := variables already integrated
  # e      := expr
  # vs     := domain bounds
  # sh     := domain shape
  # ctx    := context (see apply_context)
  local do_apply := proc(done__, e, vs, sh_, ctx::apply_context, $)
    local i, s, sh := sh_, done_ := done__
        , r, cond, cond_outer, vn, vt, shv, vars, deps, ctx1, rn;
    # If the solution is a constraint, and the constraint is true,
    # then just produce the expression. If it isn't necessarily true
    # (i.e. trivial) then produce a Partition with the constraint as a
    # guard.
    if sh :: DomConstrain then
      vars := Domain:-Bound:-varsOf(vs,"set") minus done_;
      cond, cond_outer := select_cond_outer(sh, vars);
      # if there are still integrals which have not been applied, apply
      # them now
          ctx:-f_constrain
           (do_constrain(cond_outer),
             do_mks(e, (r,kb1) ->
               ctx:-f_constrain(do_constrain(cond),
                 ctx:-f_body(r, kb1)), vars, vs, ctx));
    # if the solution is a sum of solutions, produce the algebraic sum
    # of each summand of the solution applied to the expression.
    elif sh :: DomSum then
        ctx:-f_sum(seq(do_apply(done_, e, vs, s, ctx), s=sh))
    # if the solution is a split solution, just make `do_apply' over
    # the values of the Partition (the subsolutions)
    elif sh :: DomSplit then
        Partition:-Amap(
          [ (c,_)->c
          , (p,c)->do_apply(done_, e, vs, p,
                     upd_field(ctx, 'context', curry(KB:-assert,c)))
          , c->c ], op(1, sh) );
    # performs the 'make' on the expression after recursively
    # applying the solution
    elif sh :: DomInto then
      # deconstruction
      vn, vt, shv := op(sh);
      # extract bounds which have not been applied upon which this
      # bound depends. Those are applied after this one, so are not
      # in 'scope' in the recursive call
      vars := Domain:-Bound:-varsOf(vs,"set");
      deps := (indets(vt, DomBoundVar) intersect vars) minus done_ ;
      deps := `union`(deps, {vn});
      done_ := `union`(done_, deps) ;

      shv, cond_outer :=
        select_cond_outer(shv, done_ union (indets(shv,DomBoundVar) intersect vars));

      # build this integral, and the other this one depended on, then
      # recursively apply
      ctx:-f_constrain(do_constrain(cond_outer),
        do_mks(e, (r,kb1) ->
          do_apply(done_, r, vs, shv,
                   upd_field(ctx, 'context',_->kb1)),
                   deps, Domain:-Bound:-upd(vs, vn, vt), ctx));
    else
      error "don't know how to apply %1", sh
    end if;
  end proc;

  # A default implementation for `f_into'
  export do_mk := proc(mk, e, vn, ty_, _kb)
    Domain:-ExtBound[mk]:-DoMk(e, vn, ty_);
  end proc;

  # A default implementation for `f_body'
  export do_body := proc(e, _kb) e end proc;

  # Like an `Indicator' but performs some early simplification which covers the
  # common case of `DConstrain()' (and is expressed in terms of Partition).
  local do_constrain := proc(cond0::{list,set,DomConstrain},$)
    local mk_cond, cond := cond0;
    if nops(cond)=0 then
      mk_cond := x->x;
    else
      cond := bool_And(op(cond));
      mk_cond := x->PARTITION([Piece(cond,x), Piece(Not(cond),0)]);
    end if;
    mk_cond;
  end proc;

  # A very cute way of pulling constraints out over other constructors
  # which relies on the fact that constraints are required to be innermost;
  # i.e. DomShape is a sum of products; i.e. this could also be called
  # 'factoring'. e.g.:
  # DSum( DConstrain(A, C), DConstrain(A, B) )
  # -> DSum( DConstrain(C), DConstrain(B) ), {A}
  # DSum( DConstrain(A), DConstrain(B) )
  # -> DSum( DConstrain(A), DConstrain(B) ), { }
  # DSum( DInto(x, .., DConstrain(A, B)), DInto(x, .., DConstrain(A, C))),
  # and `x' is not in `vars'
  # -> DSum( DInto(x, .., DConstrain(B)), DInto(x, .., DConstrain(C) ) ), {A}
  local select_cond_outer := proc(sh::DomShape, vars0::set({name,list(name)}), $)
    local csd, cs0, cs, ots, sh1, ins, vars := vars0;
    if sh=DConstrain() then return sh, {}; end if;
    vars := map(v->`if`(v::list,v,[v])[],vars); # handles(?) array variables

    # the constraints which appear in the shape and don't mention dependant variables
    csd := [op(indets(sh, And(DomConstrain,Not(satisfies(x->has(x,vars))))))];
    cs0 := map(x->{op(x)},csd);
    if cs0=[] then return sh, {}; end if; # if there are no such constraints

    # Split each constraint into a pair whose first component are
    # constraints common to all constraints in the shape
    cs := map(x->[selectremove(z->andmap(c->z in c,cs0),x)], cs0);

    # outers (common constraints) and inners (rest)
    ots := op([1,1],cs); ins := map(curry(op,2), cs);

    # substitute back into the shape the reduced constraints
    sh1 := subs(zip(`=`, csd, map(DConstrain@op,ins)), sh);
    userinfo(3, Domain, printf("select_cond_outer(%a, %a) = %a, %a\n", sh, vars, sh1, ots));
    sh1, ots;
  end proc;

  # Move into an integral by augmenting the KB with the variables bound by
  # that integral.
  local into_mk := proc(dbnd::DomBound, vn, vt, ctx, $)
    local kb, v_i, v_k, vn_, kb1, rn;
    kb := ctx:-context;
    if kb :: t_not_a_kb then return KB:-NotAKB() end if;

    v_i := Domain:-Bound:-varIx(dbnd, vn);
    v_k := op([1,v_i,3], dbnd);
    vn_, kb1 := Domain:-ExtBound[v_k]:-MakeKB(vn, Domain:-ExtBound[v_k]:-SplitRange(vt), kb);

    rn := `if`(evalb(vn=vn_), [], [vn=vn_]);
    upd_field(ctx, 'context', _->kb1), rn;
  end proc;

  # Performs multiple integrals, corresponding to those variables given in
  # `todo'. If `todo' is a set, then the order of integrals is one which matches
  # the order in the original expression. If `todo' is a list, this function
  # assumes that integrating in that order is valid (i.e. doesn't cause scope
  # extrusion). `kont' takes an expression and a KB corresponding to the
  # innermost context in which the input `e' will be used.
  #   do_mks(e, kont, [v0,v1..vn], dbnd, ctx{context=outerKB}) =
  #     Int(v0, RangeOf(v0,dbnd),
  #     Int(v1, RangeOf(v1,dnbd),
  #     ...
  #     Int(vn, RangeOf(vn,dnbd),
  #       kont(e, innerKB)) ... ))
  #   where innerKB is outerKB additionally augmented with
  #          the knowledge that
  #            `{v0 in RangeOf(v0,dbnd), v1 in RangeOf(v1,dbnd), .., vn in ..}'
  local do_mks := proc(e, kont, todo::({list,set})(DomBoundVar), dbnd :: DomBound, ctx, $)
    local vs, v_td, i, vt, kb0, v_mk, _, ctx1, rn, r := e;

    if todo :: set then
      vs := select(v->v in todo,Domain:-Bound:-varsOf(dbnd));
      vs := ListTools[Reverse](vs);
    else
      vs := todo;
    end if;

    if nops(vs)=0 then
      return kont(r,ctx:-context);
    end if;

    v_td := op(1,vs);
    vs   := subsop(1=NULL,vs);
    i    := Domain:-Bound:-varIx(dbnd, v_td);
    _,vt,v_mk := op(op([1,i], dbnd));

    ctx1, rn := into_mk(dbnd, v_td, vt, ctx);
    if rn <> [] then
      r := subs(rn,r);
    end if;

    r := do_mks(r, kont, vs, dbnd, ctx1);
    ctx:-f_into(v_mk, r, v_td, vt, ctx:-context, ctx:-weights[v_td]);
  end proc;
end module;


# MarSystemComposite
# Type = Series
# Name = extractNet

# MarControls = 8
# /Series/extractNet/mrs_bool/debug = 0
# /Series/extractNet/mrs_bool/mute = 0
# /Series/extractNet/mrs_natural/inObservations = 1
# /Series/extractNet/mrs_natural/inSamples = 512
# /Series/extractNet/mrs_natural/onObservations = 1
# /Series/extractNet/mrs_natural/onSamples = 1
# /Series/extractNet/mrs_real/israte = 22050
# /Series/extractNet/mrs_real/osrate = 43.0664

# Number of links = 1
# Synonyms of /Series/extractNet/mrs_bool/hasData =
# Number of synonyms = 1
# /Series/extractNet/NetworkTCPSource/src/mrs_bool/hasData

# nComponents = 6

# MarSystem
# Type = NetworkTCPSource
# Name = src

# MarControls = 12
# /NetworkTCPSource/src/mrs_bool/debug = 0
# /NetworkTCPSource/src/mrs_bool/mute = 0
# /NetworkTCPSource/src/mrs_bool/hasData = 1
# /NetworkTCPSource/src/mrs_natural/controlsPort = 5010
# /NetworkTCPSource/src/mrs_natural/dataPort = 5009
# /NetworkTCPSource/src/mrs_natural/inObservations = 1
# /NetworkTCPSource/src/mrs_natural/inSamples = 512
# /NetworkTCPSource/src/mrs_natural/onObservations = 1
# /NetworkTCPSource/src/mrs_natural/onSamples = 512
# /NetworkTCPSource/src/mrs_real/gain = 1
# /NetworkTCPSource/src/mrs_real/israte = 22050
# /NetworkTCPSource/src/mrs_real/osrate = 22050

# Number of links = 0

# MarSystem
# Type = Hamming
# Name = ham

# MarControls = 8
# /Hamming/ham/mrs_bool/debug = 0
# /Hamming/ham/mrs_bool/mute = 0
# /Hamming/ham/mrs_natural/inObservations = 1
# /Hamming/ham/mrs_natural/inSamples = 512
# /Hamming/ham/mrs_natural/onObservations = 1
# /Hamming/ham/mrs_natural/onSamples = 512
# /Hamming/ham/mrs_real/israte = 22050
# /Hamming/ham/mrs_real/osrate = 22050

# Number of links = 0

# MarSystem
# Type = Spectrum
# Name = spectrum

# MarControls = 8
# /Spectrum/spectrum/mrs_bool/debug = 0
# /Spectrum/spectrum/mrs_bool/mute = 0
# /Spectrum/spectrum/mrs_natural/inObservations = 1
# /Spectrum/spectrum/mrs_natural/inSamples = 512
# /Spectrum/spectrum/mrs_natural/onObservations = 512
# /Spectrum/spectrum/mrs_natural/onSamples = 1
# /Spectrum/spectrum/mrs_real/israte = 22050
# /Spectrum/spectrum/mrs_real/osrate = 43.0664

# Number of links = 0

# MarSystem
# Type = PowerSpectrum
# Name = psk

# MarControls = 9
# /PowerSpectrum/psk/mrs_bool/debug = 0
# /PowerSpectrum/psk/mrs_bool/mute = 0
# /PowerSpectrum/psk/mrs_natural/inObservations = 512
# /PowerSpectrum/psk/mrs_natural/inSamples = 1
# /PowerSpectrum/psk/mrs_natural/onObservations = 256
# /PowerSpectrum/psk/mrs_natural/onSamples = 1
# /PowerSpectrum/psk/mrs_real/israte = 43.0664
# /PowerSpectrum/psk/mrs_real/osrate = 43.0664
# /PowerSpectrum/psk/mrs_string/spectrumType = power

# Number of links = 0

# MarSystem
# Type = Centroid
# Name = cntrd

# MarControls = 8
# /Centroid/cntrd/mrs_bool/debug = 0
# /Centroid/cntrd/mrs_bool/mute = 0
# /Centroid/cntrd/mrs_natural/inObservations = 256
# /Centroid/cntrd/mrs_natural/inSamples = 1
# /Centroid/cntrd/mrs_natural/onObservations = 1
# /Centroid/cntrd/mrs_natural/onSamples = 1
# /Centroid/cntrd/mrs_real/israte = 43.0664
# /Centroid/cntrd/mrs_real/osrate = 43.0664

# Number of links = 0

# MarSystem
# Type = NetworkTCPSink
# Name = dest

# MarControls = 12
# /NetworkTCPSink/dest/mrs_bool/debug = 0
# /NetworkTCPSink/dest/mrs_bool/mute = 0
# /NetworkTCPSink/dest/mrs_natural/controlsPort = 5010
# /NetworkTCPSink/dest/mrs_natural/dataPort = 5009
# /NetworkTCPSink/dest/mrs_natural/inObservations = 1
# /NetworkTCPSink/dest/mrs_natural/inSamples = 1
# /NetworkTCPSink/dest/mrs_natural/onObservations = 1
# /NetworkTCPSink/dest/mrs_natural/onSamples = 1
# /NetworkTCPSink/dest/mrs_real/gain = 1
# /NetworkTCPSink/dest/mrs_real/israte = 43.0664
# /NetworkTCPSink/dest/mrs_real/osrate = 43.0664
# /NetworkTCPSink/dest/mrs_string/host = cyprus.cs.uvic.ca

# Number of links = 0


f(){
	[x, y] = stack(), stack(); // get input values from stack
	CreateSpore(CurrentCoords(), x, y, 1, 10);
	// x; y; // just live something on stack to return value from function
}


with(Threads:-Task):
printf("root exec\n");
Start(print,1,2,3);
printf("single task\n");
Start(null,Task=[print,1,2,3]);
printf("multi tasks\n");
Start(null,Task=[print,1],Task=[print,2],Task=[print,3]);
print("multi tasks with same function\n");
Start(null,Tasks=[print,[1],[2],[3]]);
print("complex parameters\n");
Start(passed,1,Task=[`+`,1,2,3],Tasks=[`*`,[2,3,3],[4,5,6]],x,y,z);
printf("执行完毕\n");


### Domain abstraction

# A domain is abstractly a pair of a "square" domain (a product of square
# domains, or an interval), the domain "bounds", and a domain "shape". The
# domain "bounds" are essentially the variables, each with the type of domain
# (Int,Sum, etc) ; the domains "shape" is sums of products of constraints
# (relations) on the domain, interspersed with 'makes' (DInto) which parametrize
# a subdomain by one of the domain variables ('picking' a particular
# parametrization of the domain, in which one variable is fixed in subsequent
# "shape" constructors).

# the seperation between the two 'stages' of domain exists mainly because
# certain simplifications need to happen after extracting the domain
# bounds but before extracting the domain shape, as the shape ends up
# becoming part of the bounds of an inner simplification.

# Note that large parts of this are not very nice. It is a very literal
# translation of the code which it replaced, which a very thin amount
# of abstraction on top. But it does the hard work of factoring
# out all of the domain-related code into a single module.
# At some point, the interface should be improved, and the implementation
# should get rid of all sorts of unnecessary conversions.

# Broad TODOs:
#
# Mechanism for 'checking if' and 'making' constraints about variables should
#   be abstracted out into its own module (it is needed in multiple places, and
#   done sort of ad-hoc) (this could be fixed by a broader design - see "merging
#   KB with Domain")
#
# Shape extraction needs to be reworked; we "flatten" constraints multiple
#   times; This should be done once after shape extraction, not at every step
#
# DInto should also optionally omit the bounds if they are identical to the
#   bounds in the a-priori domain bounds (i.e. just `DInto(x)`); DInto sort of
#   means 'we've solved this bound in this subcontext' but the `DInto`s where
#   the bound is identically the a-priori bound are erased (as they should be)
#   - we want a slightly seperate form to mean "we are done improving this", but
#   we still want to be able to omit bounds which would be identical. It should
#   also allow specifying only a subset of the bounds.
#
# A more granular interface for composing/re-composing simplifiers, including
#   call simplifier A {before/after} B
#
# Domain bounds should store a representation of 'dependancy' of variables
#   (a more refined representation; the current one is a linear order of variables)
#   Basically we want a list of graphs, nodes are variables and edges are
#   variable dependencies. If each graph is acyclic, the variable dependency
#   in the bounds is valid. e.g.
#     [x=0..1, y=0..1, z=0..1]  =>  [ {[x, {}]}, {[y, {}]}, {[z, {}]} ]
#     [x=0..1, y=x..1, z=0..y]  =>  [ {[z, {y}], [y, {x}], [x, {}]} ]
#   This generalizes the previous notion of variable order, although in certain
#     cases it is ambiguous what the 'original' order was. This is only when
#     there are variable dependencies, so perhaps this isn't a big deal - we may
#     want to rearrange the dependant bounds even when there is no 'interesting'
#     constraint to solve in the shape, because we know a particular order will
#     be better in some way.
#   The graph is probably not a convenient place to store the variable bounds.
#    (this is one of the big reasons we want to view the variables as a table -
#    we have lots of different information for which the convenient formats are
#    all different)
#
# A better interface for `simpl_relation` - something that allows it to treat
#   arbitrary constructor forms as And, Or, Not. Typically, we do a `subs` right
#   before the call to `simpl_relation` to put things in the right form, then
#   another `subs` immediately inside `simpl_relation` to turn `And,Or` into `&and,&or`.
#
# Long term, KB and Domain should be merged, as their functionality overlaps
#   quite a bit; basically
#     - Introduce becomes a variable in DBound
#     - Constrain becomes DConstrain
#     - DBound becomes DInto
#     - Let becomes (probably?) a one piece partition,
#           or maybe a new variable type
#          (it doesn't seem to appear in present code?)
#  Logically, this is at most an ephemeral change - Domain already generalizes
#   KB. But mechanically it is no small undertaking.
#  assert_deny becomes a "DConstrain" smart constructor (note that in the
#   current AST for Domain, DConstrain appears only at leaves, i.e. products
#   are pushed all the way down; whereas KB is 'flat') but the shape of domains
#   means it is probably much simpler to 'normalize' the constraints all at
#   once, as opposed to when every constrain is inserted, as KB currently does.
#  kb_subtract becomes a similar `domain_combine` function (kb_subtract is really
#   an 'combine' as well as a 'deconstruct into a way to rebuild the KB' together in
#   one - we don't really need the 'deconstruct' part anymore, but 'add' is
#   still useful) - basically this function takes two domains, checks if the
#   variables of the first are a subset of the second (non commutative!) and if
#   so, combines the shapes according to the passed 'shape constructor'; all of
#   the constructors (aside from DInto)
#  gen{whatever} becomes a part of `Domain:-Extract` - basically we will not
#   have `gen` as part of the "interface" to KB+Domain, but rather an entry in
#   the `Ext` function tables.
#  most of the other functions in KB can be basically literally translated to
#    the subset of Domain which corresponds to KB

Domain := module()
    uses Hakaru, Partition, SolveTools[Inequality] ;
    global DSplit; global DInto; global DNoSol;

    local ModuleLoad := proc($)
      local ty_nm, g;
      for ty_nm in [ indices(DomainTypes, nolist) ] do
        TypeTools[AddType]( ty_nm, DomainTypes[ty_nm] );
      end do;

      #op([2,6], ...) of a module is its globals.
      for g in op([2,6], thismodule) do
        if g <> eval(g) then
          unassign(g);
          WARNING("Previous value of global name '%1' erased.", g)
        end if;
        protect(g);
      end do;
    end proc;

    local ModuleUnload := proc($)
      local ty_nm;
      for ty_nm in [ indices(DomainTypes, nolist) ] do
        if TypeTools[Exists](ty_nm) then TypeTools[RemoveType](ty_nm) end if;
      end do;
    end proc;

    # Extending domain extraction and replacement.
    export ExtBound := table();
    export ExtShape := table();

    export Set_ExtBound := proc(nm,val,$)
      unprotect(Domain:-ExtBound);
      Domain:-ExtBound[nm] := val;
      protect(Domain:-ExtBound);
    end proc;

    export Set_ExtShape := proc(nm,val,$)
      unprotect(Domain:-ExtShape);
      Domain:-ExtShape[nm] := val;
      protect(Domain:-ExtShape);
    end proc;

$include "Domain/Has.mpl"
$include "Domain/Bound.mpl"
$include "Domain/Shape.mpl"
$include "Domain/Types.mpl"
$include "Domain/Extract.mpl"
$include "Domain/Apply.mpl"
$include "Domain/Improve.mpl"

    export simpl_relation :=
    proc( expr_ :: {relation, boolean, specfunc({`And`,`Not`,`Or`}), `and`, `not`, `or`}
        , { norty := 'DNF' }
        , $) :: { specfunc(specfunc({relation, specfunc(relation, Not)}, `Or`), `And`)
                , specfunc(specfunc({relation, specfunc(relation, Not)}, `And`), `Or`)
                };
        local expr := expr_, outty, outmk, inty, inmk, ty_ord ;

        expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                     , expr
                     , [ { specfunc(relation, `Not`), `not`(relation) }
                       , x-> KB:-negate_rel(op(1,x)) ]
                     , [ { specfunc(`Not`), `not` }
                       , x->Logic:-`&not`(op(1,x)) ]
                     , [ { specfunc(`Or`), `or` }
                       , x->Logic:-`&or`(op(x)) ]
                     , [ { specfunc(`And`), `and` }
                       , x->Logic:-`&and`(op(x)) ] );
        expr := Logic:-Normalize(expr, form=norty);
        expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                     , expr
                     , [ specfunc(Logic:-`&and`), x->`And`(op(x)) ]
                     , [ specfunc(Logic:-`&or`) , x->`Or`(op(x)) ]
                     , [ specfunc(Logic:-`&not`), x->KB:-negate_rel(op(1,x))  ] );

        if expr :: identical(false) then
            return `if`(norty='DNF', `Or`(), `And`(`Or`()));
        elif expr :: identical(true) then
            return `if`(norty='DNF', `Or`(`And`()), `And`());
        end if;

        ty_ord := `if`(norty='DNF', [1,2], [2,1]);
        outty, inty := [ 'specfunc(Or)', 'specfunc(And)' ][ty_ord][];
        outmk, inmk := [ `Or`, `And` ][ty_ord][];

        if not expr :: outty then expr := outmk(expr) end if;
        map(x -> if not x :: inty then inmk(x) else x end if, expr);
    end proc;

    # The main interface to Domain
    export Reduce := proc(e0,kb::t_kb,f_into,f_body,f_nosimp:=(_->FAIL),$)
      local e := e0, dom_specb, dom_specw, dom_ctx, dom_spec;
      # Build the domain
      dom_specb, e := op(Domain:-Extract:-Bound(e));
      if Domain:-Bound:-isEmpty(dom_specb) then return f_nosimp(e0) end if;
      dom_specw, e := op(Domain:-Extract:-Shape(e));
      dom_ctx := {op(KB:-kb_to_assumptions(kb))};
      dom_specb := DBound(op(1,dom_specb), dom_ctx);
      dom_spec := DOMAIN(dom_specb, dom_specw);

      # Improve, if necessary, then apply back to the expression
      if dom_specw <> DConstrain() then dom_spec := Domain:-Improve(dom_spec) end if;
      Domain:-Apply(dom_spec, kb, f_into, f_body)(e);
    end proc;

end module;


if not(type(lib_dir,string)) then
 lib_dir := currentdir();
fi;

currentdir(lib_dir);
currentdir("../lib_checks");
lib_checks_dir := currentdir();
currentdir(lib_dir);
currentdir("../data");
data_dir := currentdir();
currentdir(lib_dir);

lib_read := proc(f)
 global lib_dir;

 if read_quietly <> true then
  printf("Reading %s\n",f);
 fi;
 read(cat(lib_dir,"/",f)):
end:

with(LinearAlgebra):
with(plots):
with(plottools):

lib_read("cartesian_product.mpl"):
lib_read("realisation.mpl"):
lib_read("apply.mpl"):
lib_read("op_props.mpl"):

lib_read("util.mpl"):
lib_read("colours.mpl"):

lib_read("BW1.mpl"):
lib_read("C.mpl"):
lib_read("CP.mpl"):
lib_read("R.mpl"):
lib_read("sphere.mpl"):
lib_read("RZ.mpl"):
lib_read("RZ_set.mpl"):
lib_read("SW.mpl"):
lib_read("SWW.mpl"):
lib_read("W.mpl"):
lib_read("W1.mpl"):
lib_read("Zpl.mpl"):
lib_read("a_infinity.mpl"):
lib_read("abelian_group_homology.mpl"):
lib_read("autorel.mpl"):
lib_read("big_subsets.mpl"):
lib_read("binary_standard_stasheff_trees.mpl"):
lib_read("binary_trees.mpl"):
lib_read("binops.mpl"):
lib_read("chromatic/Lambda2.mpl"):
lib_read("cubes.mpl"):
lib_read("cycord.mpl"):
lib_read("elliptic/edwards.mpl"):
lib_read("epi.mpl"):
lib_read("equiv.mpl"):
lib_read("euler_quartic.mpl"):
lib_read("extended_stasheff_trees.mpl"):
lib_read("free_algebra.mpl"):
lib_read("full_flags.mpl"):
lib_read("full_trees.mpl"):
lib_read("geometry/geometry.mpl"):
lib_read("geometry/boys.mpl"):
lib_read("geometry/boys_data.mpl"):
lib_read("graphs/digraphs.mpl"):
lib_read("graphs/graphs.mpl"):
lib_read("groebner.mpl"):
lib_read("group_homology.mpl"):
lib_read("groups/alternating_five.mpl"):
lib_read("groups/Out_SL2.mpl"):
lib_read("groups/SL2_11.mpl"):
lib_read("groups/holder_graph.mpl"):
lib_read("hasse_diagrams.mpl"):
lib_read("height_functions.mpl"):
lib_read("homology.mpl"):
lib_read("hurewicz.mpl"):
lib_read("interval_partitions.mpl"):
#lib_read("itloc.mpl"):
lib_read("koszul.mpl"):
lib_read("lie_algebra.mpl"):
lib_read("linord.mpl"):
lib_read("maps.mpl"):
lib_read("morava/fgl.mpl"):
lib_read("morse.mpl"):
lib_read("narayana.mpl"):
lib_read("nat_partitions.mpl"):
lib_read("nonempty_subsets.mpl"):
lib_read("numerical_poly.mpl"):
lib_read("one_cubes_prime.mpl"):
lib_read("operads/general.mpl"):
lib_read("operads/BW.mpl"):
lib_read("operads/F.mpl"):
lib_read("operads/F3.mpl"):
lib_read("operads/Phi.mpl"):
lib_read("operads/WK.mpl"):
lib_read("operads/Xi.mpl"):
lib_read("operads/ass.mpl"):
lib_read("operads/cacti/cactus_lobes.mpl"):
lib_read("operads/cacti/cactus_trees.mpl"):
lib_read("operads/cacti/cactus_planar_trees.mpl"):
lib_read("operads/cacti/cacti.mpl"):
lib_read("operads/chains/ACP.mpl"):
lib_read("operads/chains/E.mpl"):
lib_read("operads/chains/FFbar.mpl"):
lib_read("operads/chains/ICP.mpl"):
lib_read("operads/chains/ICP_alt.mpl"):
lib_read("operads/chains/P.mpl"):
lib_read("operads/chains/PQQ.mpl"):
lib_read("operads/chains/PQ_alt.mpl"):
lib_read("operads/chains/SCP.mpl"):
lib_read("operads/chains/SCP2.mpl"):
lib_read("operads/chains/SEM.mpl"):
lib_read("operads/chains/tree_FFbar.mpl"):
lib_read("operads/comm.mpl"):
lib_read("operads/cubes.mpl"):
lib_read("operads/full_trees.mpl"):
lib_read("operads/fulton/D.mpl"):
lib_read("operads/fulton/E.mpl"):
lib_read("operads/fulton/F1bar.mpl"):
lib_read("operads/fulton/Fbar.mpl"):
lib_read("operads/fulton/P2.mpl"):
lib_read("operads/fulton/Q.mpl"):
lib_read("operads/fulton/WFbar.mpl"):
lib_read("operads/fulton/tree_Fbar.mpl"):
lib_read("operads/fulton/tree_Fbar_alt.mpl"):
lib_read("operads/height_functions.mpl"):
lib_read("operads/lie.mpl"):
lib_read("operads/nonempty_subsets.mpl"):
lib_read("operads/one_cubes_prime.mpl"):
lib_read("operads/ord.mpl"):
lib_read("operads/ord_simplex_interior.mpl"):
lib_read("operads/parallel/PP.mpl"):
lib_read("operads/parallel/YC.mpl"):
lib_read("operads/partitions.mpl"):
lib_read("operads/prime_simplex.mpl"):
lib_read("operads/simplex.mpl"):
lib_read("operads/simplex_interior.mpl"):
lib_read("operads/stasheff_star.mpl"):
lib_read("operads/stasheff_trees.mpl"):
lib_read("operads/trees.mpl"):
lib_read("ord.mpl"):  # Duplicates linord.mpl
lib_read("ord_simplex_interior.mpl"):
lib_read("pair_subsets.mpl"):
lib_read("pairs.mpl"):
lib_read("partitions.mpl"):
lib_read("partord.mpl"):
lib_read("permutations.mpl"):
lib_read("plane_cad.mpl"):
lib_read("plots.mpl"):
lib_read("poisson.mpl"):
lib_read("posint_intervals.mpl"):
lib_read("preord.mpl"):
lib_read("prime_W.mpl"):
lib_read("prime_simplex.mpl"):
lib_read("prime_simplex_boundary.mpl"):
lib_read("proper_nonempty_subsets.mpl"):
lib_read("quaternions.mpl"):
lib_read("real_functions.mpl"):
lib_read("rel.mpl"):
lib_read("semioperads/general.mpl"):
lib_read("semioperads/circ.mpl"):
lib_read("semioperads/coloured.mpl"):
lib_read("semioperads/permutations.mpl"):
lib_read("shelling.mpl"):
lib_read("shuffles.mpl"):
lib_read("simplex.mpl"):
lib_read("simplex_interior.mpl"):
lib_read("simplices.mpl"):
lib_read("simplicial.mpl"):
lib_read("simplicial_alt.mpl"):
lib_read("simplicial_complexes/simplicial_complex.mpl"):
lib_read("simplicial_complexes/CP2_complex.mpl"):
lib_read("simplicial_complexes/RP2_complex.mpl"):
lib_read("simplicial_complexes/icosahedron_complex.mpl"):
lib_read("simplicial_complexes/octahedron_complex.mpl"):
lib_read("simplicial_complexes/mobius_complex.mpl"):
lib_read("simplicial_complexes/moore_complex.mpl"):
lib_read("single_cubes.mpl"):
lib_read("space_curves.mpl"):
lib_read("spaces/spaces.mpl"):
lib_read("spaces/complex_projective_space.mpl"):
lib_read("standard_stasheff_star.mpl"):
lib_read("standard_stasheff_trees.mpl"):
lib_read("stasheff_star.mpl"):
lib_read("stasheff_trees.mpl"):
lib_read("steiner_systems.mpl"):
lib_read("striped_preord.mpl"):
lib_read("subsets.mpl"):
lib_read("subspaces.mpl"):
lib_read("symfun.mpl"):
lib_read("tanabe/tanabe.mpl"):
lib_read("tanabe/twisted_product.mpl"):
lib_read("total_preord.mpl"):
lib_read("tree_height_functions.mpl"):
lib_read("trees.mpl"):
lib_read("triples.mpl"):
lib_read("vector_functions.mpl"):
lib_read("witt.mpl"):
lib_read("young.mpl"):


program assignboolean;
var x, y : boolean;
begin
    x := true;
    y := false;
end.


type $ss1 <struct {@b <!T>,
                       @x <* f32>}>
type $ss2 <struct {@b1 <struct {@b <!SS>,
                                    @x <* f32>}>,
                       @pa <* <struct {@b f64,
                                       @x <* f32>}>>,
                       @x1 <[10] f64>,
                       @dx <!U>}>
type $ss3 <[] <!AAA>>
func &foo (var %x <!W>) i32 {
  var %y <!W>
  dassign %y (dread agg %x)
  return (dread i32 %y 1)
}
var $g <$ss1{!T=i32}>
var $h <$ss2{!U=i32,!SS=<$ss1{!T=f32}>}>
func &bar () i32 {
  var %i i32
  callinstant &foo<{!W=<$ss2{!U=f32,!SS=i32}>}>( dread agg $g )
  callinstantassigned &foo<{!W=<$ss1{!T=i32}>}>( dread agg $g ) { dassign %i 0 }
  virtualcallinstant &foo<{!W=<$ss2{!U=f32,!SS=i32}>}>( dread agg $g )
  virtualcallinstantassigned &foo<{!W=<$ss1{!T=i32}>}>( dread agg $g ) { dassign %i 0 }
  superclasscallinstant &foo<{!W=<$ss2{!U=f32,!SS=i32}>}>( dread agg $g )
  superclasscallinstantassigned &foo<{!W=<$ss1{!T=i32}>}>( dread agg $g ) { dassign %i 0 }
  interfacecallinstant &foo<{!W=<$ss2{!U=f32,!SS=i32}>}>( dread agg $g )
  interfacecallinstantassigned &foo<{!W=<$ss1{!T=i32}>}>( dread agg $g ) { dassign %i 0 }
  return ( dread i32 %i )
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


program brainfuck;
var
    size: integer;
    cells: array[30000] of char;
    ptr: integer;
    src: array[30000] of char;
    cursol: integer;

procedure load;
var
    i, jump: integer;
begin
    read(size);
    i := 0;
    jump := 0;
    while i < size do
    begin
        read(src[i]);
        if src[i] = '[' then
            jump := jump + 1
        else if (src[i] = ']') and (jump > 0) then
            jump := jump - 1
        else
        begin
            writeln('mismatching square parenthesis');
            return
        end;
        i := i + 1
    end;
    if jump > 0 then
    begin
        writeln('unclosed square parenthesis');
        return
    end;
end;

begin
    call load;
    cursol := 0;
    ptr := 0;
    while cursol < size do
    begin
        if src[cursol] = '>' then
            ptr := ptr + 1
        else if src[cursol] = '<' then
            ptr := ptr - 1
        else if src[cursol] = '+' then
            cells[ptr] := char(integer(cells[ptr]) + 1)
        else if src[cursol] = '-' then
            cells[ptr] := char(integer(cells[ptr]) - 1)
        else if src[cursol] = '.' then
            write(cells[ptr])
        else if src[cursol] = ',' then
            read(cells[ptr])
        else if (src[cursol] = '[') and (integer(cells[ptr]) = 0) then
            while src[cursol] <> ']' do
                cursol := cursol + 1
        else if (src[cursol] = ']') and (integer(cells[ptr]) <> 0) then
            while src[cursol] <> '[' do
                cursol := cursol - 1;
        cursol := cursol + 1;
    end
end.


var $g <*ptr>
var $h <*ptr> = addrof ptr $g
var $g <*ptr> = addrof ptr $h
var $h <*ptr>
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


var $extern_var extern i32 public

func $test_extern_var ( var %i i32 ) i32 {
  return (dread i32 $extern_var) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


print 5;
print 6;
print 5 foo;
print 7;
print 8;


export Improve := module ()
    export Simplifiers := table();
    export ModuleApply := proc(dom :: HDomain, $)::HDomain_mb;
        local es := map(si->Simplifiers[si]
                       , sort( [indices(Domain:-Improve:-Simplifiers,nolist) ]
                             , key=(si->Simplifiers[si]:-SimplOrder)))
             , bnd, sh;
        bnd, sh := op([1..2], dom);
        sh := foldr(((f,q)->proc() cmp_simp_sh(f,q,args) end proc)
                   ,(proc(_,b,$) b end proc), op(es))(bnd, sh);
        DOMAIN(bnd, sh);
    end proc;

    local ModuleLoad := proc($)
      LoadSimplifiers();
      LoadSimplifiers := (proc() end proc);
    end proc;#ModuleLoad

    local LoadSimplifiers := proc($)
      local lib_path, drs, improve_path, simpls_paths, simpl_path, names0, names1, new_names, nm;
      unprotect(Simplifiers);
      lib_path := LibraryTools:-FindLibrary(Hakaru);
      ASSERT(lib_path<>NULL);
      lib_path := FileTools:-ParentDirectory(lib_path);
      drs := kernelopts(dirsep);
      improve_path := `cat`(lib_path,drs,"Domain",drs,"Improve");

      simpls_paths := FileTools:-ListDirectory(improve_path);
      for simpl_path in simpls_paths do
        names0 := {anames(user)};
        read(`cat`(improve_path,drs,simpl_path));
        names1 := {anames(user)};
        new_names := names1 minus names0;
        for nm in new_names minus {entries(Simplifiers,nolist)} do
          if nm :: `module`(SimplName,SimplOrder) then
            if assigned(Simplifiers[nm:-SimplName])
            and not Simplifiers[nm:-SimplName] = nm then
              WARNING("overwriting old simplifier! (%1)", Simplifiers[nm:-SimplName]):
            end if;
            Simplifiers[nm:-SimplName] := eval(nm);
          else
            WARNING("not recognized as a simplifier: %1", nm);
          end if;
        end do;
      end do;
      protect(Simplifiers);
    end proc;#LoadSimplifiers

    local combine_errs := proc(err::DomNoSol, mb, $)
        if mb :: DomNoSol then
            DNoSol(op(err),op(mb));
        else
            mb
        end if;
    end proc;

    # compose two simplifiers, combining errors if both fail
    local cmp_simp_sh := proc(simp0, simp1, bnd, sh :: {DomShape,DomNoSol}, $)::{DomShape,DomNoSol};
      local res, sh1; sh1 := simp0(bnd, sh); simp0:-SimplName;
      if not sh1 :: DomNoSol then
          simp1(bnd, sh1);
      else
          combine_errs( sh1, simp1(bnd, sh) );
      end if;
    end proc;

    export classify_relation := proc(r0::relation, vars0, $)
      ::{identical(FAIL), [identical(B_LO,B_HI,B_EQ,B_NEQ), satisfies(q->q in {indices(flip_relation,nolist)}), name, algebraic]};
      local r_k, r_s, in_vars, vars := vars0, r := r0;
      if vars :: ({set,list})({name,list(name)}) then
        vars := map(x->`if`(x::list,op(1,x),x),vars);
        vars := {op(vars)}; in_vars := x->x in vars;
      elif vars :: DomBound then
        vars := DomBound:-Bound:-varsOf(vars,"set"); in_vars := x->x in vars;
      elif vars :: procedure then
        in_vars := vars;
      elif vars :: type then
        in_vars := x->type(x,vars);
      else error "unknown argument: %1 (expecting variables, variable membership check, "
                 "or domain bounds)", vars;
      end if;

      if r :: {`<=`,`<`, `=`, `<>`} then
        if in_vars(rhs(r)) then
          r_k := flip_relation[op(0,r)]; r_s := rhs(r), lhs(r);
        elif in_vars(lhs(r)) then
          r_k := op(0,r); r_s := op(r);
        else return FAIL end if;
        [ classify_relop[r_k], r_k, r_s ];
      else FAIL
      end if;
    end proc;
    local flip_relation := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);
    local classify_relop := table([`=`=B_EQ,`<>`=B_NEQ,`<=`=B_HI,`<`=B_HI,`>=`=B_LO,`>`=B_LO]);
end module;


type $RR <class {@e1 i32, @e2 f32, @e3 f64}>
type $SS <class <$RR> { &method1(agg)agg,
                        &method2(void)void}>
func $foo (
  var %x <$SS>) i32 {
  var %r1 i32
  var  %r2 i32
  var  %r3 i32
  dassign %x 2 ( constval i32 32 )
  # Not correct, but for parse and dump test.
  virtualcallassigned &method2(addrof ptr %x) {
    dassign %r1 1
    dassign %r2 2
    dassign %r3 3
  }
  superclasscallassigned &method2(addrof ptr %x) {
    dassign %r1 1
    dassign %r2 2
    dassign %r3 3
  }
  interfacecallassigned &method2(addrof ptr %x) {
    dassign %r1 1
    dassign %r2 2
    dassign %r3 3
  }
  return ( dread i32 %x 2 ) }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# Various utilities used by Hakaru which don't fit logically elsewhere
Utilities := module ()
  option package;

  # Returns true for a sequence for which all the elements are equal up to the
  # specified equality, or false otherwise. A 0-length sequence produces an
  # error.
  export the := proc(as, eq:=`=`, $)
    if nops(as)=0 then error "sequence %1 must have at least one operand", as; end if;
    andmap(x -> eq(x,op(1,as)), [op(2..-1,as)]);
  end proc;

  # zip together an arbitrary number of lists;
  # - if any lists are shorter, the function recieves all available arguments
  #    e.g. zip_k(F, [a,b], [c]) -> [F(a, c), F(b)]
  # - if any lists contain subslists, those are also zipped together, so
  #   zip_k(F, as) and zip_k(F, [as]) are equivalent. To avoid this, use a 0-th
  #   operand other than `[]`.
  #    e.g. zip_k(F, [a,b], [ [c,d], [e,f] ]) -> [F(a, c, d), F(b, e, f)]
  export zip_k := proc(f)
    map(f@op@ListTools[Flatten], foldl((a,b)->zip(`[]`,a,b,[]), _rest));
  end proc;

  # Merges two records, `rspec' and `rdef'. If `rspec' contains any fields of
  # `rdef', the fields of `rspec' are taken.
  export merge_record_default := proc(rdef::record, rspec::record, $)
    local s;
    s   := {exports(rdef)} intersect {exports(rspec)};
    Record[ Record[rdef](op(map(`-`,s))) , rspec ]();
  end proc;

  # Creates a new record with `field' updated to the given function applied to
  # `field' of the given record.
  export upd_field := proc(r::record, field::name, k, $)
    Record[r](-field,field=k(r[field]))
  end proc;

  # Simplistic negation of relations. Used by Hakaru:-flatten_piecewise, KB, and
  # Domain.
  export negated_relation:= table([`<`, `<=`, `=`, `<>`] =~ [`>=`, `>`, `<>`, `=`]);

  # Takes the bool type (true/false) to mean universal and empty relations
  # respectively.  i.e. negate R, where R is an 'atomic' relation of a KB.
  # This is used by KB and Partition
  export negate_rel:= proc(R::Relation, $)::Relation;
    if R :: truefalse then
      not R
    elif R :: relation then
      negated_relation[op(0,R)](op(R));
    else
      # This is to appease 'piecewise', which won't be happy with Not
      # However, KB doesn't really care - it's already expecting {Not,not}
      # 'Technically' this is a KB 'constructor'!
      not(R);
    end if;
  end proc;

  # Differs from negate_rel in that
  #  [ negate_rel (x) ] = "Not x"  but
  #  [ negate_rels(x) ] = "x"
  export negate_rels := proc(e, $)
    subsindets(e, { specfunc(relation, `Not`), `not`(relation) }, negate_rel@op );
  end proc;

  # Creates an N-ary operator `Plus` such:
  #  Plus(Plus(a,b),c)=Plus(a,Plus(a,b))
  #  Plus(a,Iden)=a
  #  Plus(a,Zero)=Zero
  #  Plus(a)=a
  #  Plus(x,x)=x
  export Mk_Plus := proc(plus,iden,zero,$) proc()
    local as := {args};
    as := map(a->if op(0,a)=plus then op(a) else a end if, as);
    if zero in as then return zero end if;
    as := remove(`=`,as,iden);
    if nops(as)=0 then iden
    elif nops(as)=1 then op(1,as)
    else plus(op(as))
    end if;
  end proc; end proc;

  # Replacements for `and`, `or`, `not` which do not
  # evaluate "x = y" to "false" when "x,y" are unbound vars.
  export bool_And := Mk_Plus(And,true ,false);
  export bool_Or  := Mk_Plus(Or ,false,true);
  export bool_Not := proc(a,$)
    if a :: Relation and not (a :: `::`) then
      subsindets(negate_rel(a), `not`, Not@op);
    else
      Not(a)
    end if;
  end proc;

  # boolean_if should be equivalent to `if`, but it assumes
  # all its arguments are boolean conditions, so it basically
  # simplifies "cond and th or not cond and el"
  export boolean_if := proc(cond, th, el, $)
    use
      a = ((x,y)-> `if`(x=true,y, `if`(x=false,x,
                   `if`(y=true,x, `if`(y=false,y, And(x,y)))))),
      o = ((x,y)-> `if`(x=false,y, `if`(x=true,x,
                   `if`(y=false,x, `if`(y=true,y, Or (x,y)))))),
      n = (x    -> `if`(x=false,true,
                   `if`(x=true,false,             Not(x))))
    in
      o(a(cond,th), a(n(cond),el))
    end use
  end proc;

  # In order to hopefully produce a simplification,
  #   assert_deny will on some occasions repeatedly apply
  #   `simplify@ln` in the hopes of producing an 'improved'
  #   constraint. This metric gives the stopping condition
  # - when the simplification ceases to improve the constraint
  # - which is when the metric is made no less by the `simplify@ln`.
  # Since this is a `length`, this is strictly decreasing,
  #  so such a loop will 'provably' always terminate
  export log_metric := proc(e, x, $)
    local m, L;
    m := select(depends, indets(e, 'exp(anything)'), indets(x,name));
    length(subsindets(map2(op, 1, m), name, _->L));
  end proc;

  # Used by both KB and Domain
  export try_improve_exp := proc(b0, x, ctx, $)
    local b := b0, log_b;
    do
      try log_b := map(simplify@ln, b) assuming op(ctx); catch: break; end try;

      if log_metric(log_b, x) < log_metric(b, x)
         and (andmap(e->is(e,real)=true, log_b) assuming op(ctx)) then
        b := log_b;
      else
        break;
      end if;
    end do;
    b;
  end proc;

  # Given an expression containing products and sums, i.e. polynomials
  # and a function , applies this expression to each factor and summand
  export for_poly := proc(e, f, $)
    if e :: '{`+`,`*`}' then map(for_poly, e, f)
    elif e :: 'specfunc({product,Product,sum,Sum})' then
      applyop(for_poly, 1, e, f)
    else f(e)
    end if
  end proc;

  # Apply a function to each summand at the top level of the expression
  export distrib_over_sum := proc(f,e,$) `+`(op(map(f,convert(e, 'list',`+`)))) end proc;

  # Like convert(e, 'list', `*`) but tries to keep the elements positive
  export list_of_mul := proc(e, $)
    local rest, should_negate, can_negate, fsn;
    rest := convert(e, 'list', `*`);
    rest := map((f -> [f, signum(f),
                       `if`(f::'{specfunc({Sum,sum}),anything^odd}',
                            applyop(`-`,1,f),
                       `if`(f::'specfunc(ln)',
                            applyop(`/`,1,f),
                            -f))]),
                rest);
    should_negate, rest := selectremove(type, rest,
      '[anything, -1, Not(`*`)]');
    if nops(should_negate) :: even then
      [seq(op(3,fsn), fsn=should_negate),
       seq(op(1,fsn), fsn=rest)]
    else
      can_negate, rest := selectremove(type, rest,
        '[{`+`, specfunc({Sum,sum,ln}), `^`}, Not(1), Not(`*`)]');
      if nops(can_negate) > 0 then
        [seq(op(3,fsn), fsn=should_negate),
         op([1,3], can_negate),
         seq(op(1,fsn), fsn=subsop(1=NULL, can_negate)),
         seq(op(1,fsn), fsn=rest)]
      else
        [seq(op(3,fsn), fsn=subsop(-1=NULL, should_negate)),
         op([-1,1], should_negate),
         seq(op(1,fsn), fsn=rest)]
      end if
    end if
  end proc;

  export mysolve := proc(constraints)
    # This wrapper around "solve" works around the problem that Maple sometimes
    # thinks there is no solution to a set of constraints because it doesn't
    # recognize the solution to each constraint is the same.  For example--
    # This fails     : solve({c*2^(-1/2-alpha) = sqrt(2)/2, c*4^(-alpha) = 2^(-alpha)}, {c}) assuming alpha>0;
    # This also fails: solve(simplify({c*2^(-1/2-alpha) = sqrt(2)/2, c*4^(-alpha) = 2^(-alpha)}), {c}) assuming alpha>0;
    # But this works : map(solve, {c*2^(-1/2-alpha) = sqrt(2)/2, c*4^(-alpha) = 2^(-alpha)}, {c}) assuming alpha>0;
    # And the difference of the two solutions returned simplifies to zero.

    local result;
    if nops(constraints) = 0 then return NULL end if;
    result := solve(constraints, _rest);
    if result <> NULL or not (constraints :: {set,list}) then
      return result
    end if;
    result := mysolve(subsop(1=NULL,constraints), _rest);
    if result <> NULL
       and op(1,constraints) :: 'anything=anything'
       and simplify(eval(op([1,1],constraints) - op([1,2],constraints),
                         result)) <> 0 then
      return NULL
    end if;
    result
  end proc;

  # A debugging utility that's like `and` except it calls `userinfo` if there is
  # disagreement
  export and_info := proc(e :: {list,set})
    local s, r;
    s, r := selectremove(evalb, e);
    if nops(r) = 0 then return true end if;
    if nops(s) > 0 then userinfo(op([_rest, s, r])) end if;
    return false;
  end proc;

  # Simplifies relations using `Logic:-Normalize' and places the result in a
  # canonical form. The input can be {and,not,or} but the output is always
  # {And,Or,Not}.
  #  - false, true are expressed as And and Or
  #  - When `norty' is DNF/CNF then the outer constructor is always Or/And
  #
  # TODO:
  # A better interface for `simpl_relation` - something that allows it to treat
  #   arbitrary constructor forms as And, Or, Not. Typically, we do a `subs` right
  #   before the call to `simpl_relation` to put things in the right form, then
  #   another `subs` immediately inside `simpl_relation` to turn `And,Or` into `&and,&or`.
  export simpl_relation :=
  proc( expr_ :: {relation, boolean, specfunc({`And`,`Not`,`Or`}), `and`, `not`, `or`}
      , { norty := 'DNF' }
      , $) :: { specfunc(specfunc({Relation, specfunc(relation, Not)}, `Or`), `And`)
              , specfunc(specfunc({Relation, specfunc(relation, Not)}, `And`), `Or`)
              };
      local expr := expr_, outty, outmk, inty, inmk, ty_ord ;

      # Necessary because we convert `And' (etc.) to `Logic:-&and' (etc.), and
      # e.g. `Logic:-&and(a<b,c<d)' is not a valid piecewise condition.
      expr := chillFns('piecewise', expr);

      expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                   , expr
                   , [ { specfunc(relation, `Not`), `not`(relation) }
                     , x-> negate_rel(op(1,x)) ]
                   , [ { specfunc(`Not`), `not` }
                     , x->Logic:-`&not`(op(1,x)) ]
                   , [ { specfunc(`Or`), `or` }
                     , x->Logic:-`&or`(op(x)) ]
                   , [ { specfunc(`And`), `and` }
                     , x->Logic:-`&and`(op(x)) ] );
      expr := Logic:-Normalize(expr, form=norty);
      expr := foldr( proc(v,e) subsindets(e, op(v)) end proc
                   , expr
                   , [ specfunc(Logic:-`&and`), x->`And`(op(x)) ]
                   , [ specfunc(Logic:-`&or`) , x->`Or`(op(x)) ]
                   , [ specfunc(Logic:-`&not`), x->negate_rel(op(1,x))  ] );

      if expr :: identical(false) then
        return `if`(norty='DNF', `Or`(), `And`(`Or`()));
      elif expr :: identical(true) then
        return `if`(norty='DNF', `Or`(`And`()), `And`());
      end if;

      ty_ord := `if`(norty='DNF', [1,2], [2,1]);
      outty, inty := [ 'specfunc(Or)', 'specfunc(And)' ][ty_ord][];
      outmk, inmk := [ `Or`, `And` ][ty_ord][];

      if not expr :: outty then expr := outmk(expr) end if;
      expr := map(x -> if not x :: inty then inmk(x) else x end if, expr);
      expr := warmFns('piecewise', expr);
  end proc;

  # Classify a relation by matching either the LHS or RHS against
  # a given predicate, and placing the relation in a canonical form
  # where the LHS (3rd component of the result) is the side matching
  # the predicate, or FAIL of neither side matches.
  export classify_relation := proc(r0::relation, vars0, $)
    ::{identical(FAIL), [identical(B_LO,B_HI,B_EQ,B_NEQ),
                         satisfies(q->q in {indices(flip_relation,nolist)}),
                         anything, anything]};
    local r_k, r_s, in_vars, vars := vars0, r := r0;
    if vars :: ({set,list})({name,list(name)}) then
      vars := map(x->`if`(x::list,op(1,x),x),vars);
      vars := {op(vars)}; in_vars := x->x in vars;
    elif vars :: procedure then
      in_vars := vars;
    elif vars :: type then
      in_vars := x->type(x,vars);
    else error "unknown argument: %1 "
               "(expecting variables, variable membership check)"
               , vars;
    end if;
    if r :: {`<=`,`<`, `=`, `<>`} then
      if in_vars(rhs(r)) then
        r_k := flip_relation[op(0,r)]; r_s := rhs(r), lhs(r);
      elif in_vars(lhs(r)) then
        r_k := op(0,r); r_s := op(r);
      else return FAIL end if;
      [ classify_relop[r_k], r_k, r_s ];
    else FAIL
    end if;
  end proc;
  local flip_relation := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,
                                `<`=`>`,`>=`=`<=`,`>`=`<`]);
  local classify_relop := table([`=`=B_EQ,`<>`=B_NEQ,`<=`=B_HI,
                                 `<`=B_HI,`>=`=B_LO,`>`=B_LO]);

  # Functionalized, curried `if' statement
  export Case :=
  proc(ty,f,g)
    proc(x)
      if x::ty then f(x) else g(x) end if
    end proc
  end proc;

  # A replacement for `coulditbe .. assuming ..' which uses `is' internally
  # (since `is' is actually stronger than `coulditbe'); tries to handle `Or`s
  # correctly (which don't do well with `assuming'); and catches some exceptions
  # which we are reasonably sure have a valid interpretation.
  local do_rel_coulditbe := proc(a,as_::{set,list,Relation},$)
    option remember, system;
    local os, rs, as := as_;
    if as::{set,list} then
      as := And(op(as));
    end if;
    as := simpl_relation(as,norty='DNF');

    if nops(as)=1 then
      try
        not(is(bool_Not(a)) assuming op(1,as));
      catch "when calling '%1'. Received: 'contradictory assumptions'" :
        # technically this means the KB was already contradictory, we
        # just didn't know?
        return false;
      catch "when calling '%1'. Received: "
            "'side relations must be polynomials in"
            " (name or function) variables'":
        # This is seemingly a Maple bug - the condition could still be, but we
        # don't know, so conservatively return true.
        WARNING( sprintf( "siderels bug:\n\t'%s'\n"
                          "when calling coulditbe(%%1) assuming (%%2)"
                          , StringTools[FormatMessage](lastexception[2..-1])),
                 a, as_ );
        return true;
      catch "when calling '%3'. Received: "
            "'when calling '%2'. Received: "
            "'expression independent of, %0''":
        error expr_indp_errMsg(), a, as_;
      catch "when calling '%2'. Received: 'expression independent of, %0'":
        error expr_indp_errMsg(), a, as_;
      end try;
    else
      ormap(o1->rel_coulditbe(a,o1)=true, as);
    end if;
  end proc;

  local expr_indp_errMsg := proc($)
    sprintf("Something strange happened(%s)\n"
            "\tin coulditbe(%%1) assuming %%2"
            ,StringTools[FormatMessage](lastexception[2..-1]))
  end proc;

  # Given a symmetric relation `x0', applies `test' the operands of the relation
  # in a symmetric manner. If it succeeds, returns `x0' with the side satisifying
  # `test' on the left-hand. If neither side satisfies `test', returns FAIL.
  #  e.g.:
  #   is_lhs(x=3, (a,_)->type(a,integer))  =  3=x
  #   is_lhs(x=3, (a,_)->type(a,name))     =  x=3
  #   is_lhs(x=3, (a,_)->type(a,complex))  =  FAIL
  export is_lhs := proc(test,x)
    if test(lhs(x), rhs(x),_rest) then return x end if;
    if test(rhs(x), lhs(x),_rest) then return op(0,x)(rhs(x),lhs(x)) end if;
    FAIL;
  end proc;

  # `curry(chillFns,foo)' is the function which converts all occurences of
  # `foo(as)' to `f[as]' in the given expression. `warmFns' is the inverse.
  #
  # For some reason making these curried also requires `KB:-chill' and
  # `KB:-warm' to be eta-expanded (i.e. `chill := x->chillFns(chilled)(x)')
  export chillFns := (fns, e) -> subsindets(e, 'specfunc'(fns), c->op(0,c)[op(c)]);
  export warmFns  := (fns, e) -> subsindets(e, 'specindex'(fns), c->map(curry(warmFns,fns), op(0,c)(op(c))));

  # Print profiling information for a function when `infolevel' for that
  # function is set to at least 3, and assertlevel>0; e.g.
  #  > do_func := proc() .. func .. end: func := ProfileFn(do_func):
  #  > infolevel[func] := 3:
  #  > kernelopts(assertlevel) := 1:
  #  > func(a,b,c);
  #
  #  - profiling information is only printed for runs of the function
  #    which use a minimum amount of time, bytesalloc, or bytesused
  #  - setting infolevel >= 5 prints profiling information for all runs of the
  #    function.
  #  - less than a minimum amount of a resource consumed omits the actual usage
  #    with both infolevel >= 3 < 5 and infolevel >= 5 (just "less than <min>"
  #    is printed instead)
  #  - profiling information is not printed for recursives calls of a function
  #    (in other words, if a recursive function is profiled, only non-recursive
  #     instances will have profiling attached)
  export ProfileFn := module()
    local get_prof := proc()
      [ time[real](), kernelopts(bytesalloc)/2^20, kernelopts(bytesused)/2^20 ];
    end proc;
    local ppr_prof1 := proc(m,a,nm,fmt0,$)
      local v,p,fmt;
      v,p,fmt := `if`(a>=m, ["",a,fmt0], ["less than ",m,"%a"])[];
      cat(v,sprintf(fmt,p)," ",nm);
    end proc;
    local ppr_prof := proc(min_t, t, nms, $)
      local prefix, prefixl, strs;
      prefix := "took "; prefixl := length(prefix);
      strs :=
      zip_k(ppr_prof1, min_t, t, nms);
      cat(op(
        ListTools:-Interleave(
          ["\n\t"$nops(strs)],
          [prefix,cat(" "$prefixl)$(nops(strs)-1)],
          strs)));
    end proc;
    export ModuleApply :=
    proc(fn,min_t:=0.1,min_ba:=100,min_bu:=100)
      proc()
        local t, min_prof, profs, res, ctx, fncall;
        if kernelopts(assertlevel) > 0 and
           not (assigned(_Env_ProfileFn_inside[fn])) and
           assigned(infolevel['procname']) and
           infolevel['procname'] >= 3
        then
          _Env_ProfileFn_inside[fn] := true;
          t[0] := get_prof();
          res  := fn(args);
          t[1] := get_prof();
          t[2] := zip(`-`,t[1],t[0]);
          ctx  := map(op@getassumptions,indets([fn,args],Name));
          fncall := sprintf("%a(%q)",'procname',args);
          ctx    := sprintf("assuming (%q)", op(ctx));
          min_prof := [min_t,min_ba,min_bu];
          profs  := ppr_prof(min_prof, t[2],
                             [["seconds","%.3f"],
                              ["MiB alloc", "%.3f"],
                              ["MiB total used", "%.3f"]]);
          userinfo(`if`(`or`(zip(`>`,t[2], min_prof)[]),3,5),
                   'procname',
                   printf("Evaluating\n\t%s\n\t%s%s\n",fncall,ctx,profs));
          res;
        else
          fn(args)
        end if;
      end proc;
    end proc;
  end module;

  export rel_coulditbe := ProfileFn(do_rel_coulditbe, 1);

  # The closure of `f:set->set' with respect to `x:set'. That is, all values
  # which are outputs of `f' applied to `x' or an output of `f'.
  export cl := proc(f,x,$)
    local rs := f(x) minus x;
    if rs={} then x else cl(f,rs) union x end if;
  end proc;

  # The first `n' elements of a list, or the entire list if it has fewer than
  # `n' elements.
  export take := proc(xs,n,$)
    op(1,[ListTools[LengthSplit](xs,n)]);
  end proc;

  # A copy of `:-profile' with
  #  - better pretty printing of the result
  #  - bug fix for the fact that multiple names of sub-modules with the same
  #    'root' name cannot be profiled (e.g. M1:-x and M2:-x, commonly an issue
  #    with ModuleApply)
  #  - automatic collection of the names present in the Hakaru library
  # To profile `f(as)', call `Profile(f,_args=[as])'. Profiling information
  #  if printed to stdout
  # Extra arguments to `Profile' are passed to `GetProf' and `PPrProf', which
  #  determine which stats to profile and how to pretty print profiling
  #  information.
  # Environment variables affecting this function:
  #  _Env_Profile_count_ppr  = number of profiled names to print
  #  _Env_Profile_remove_ppr = selector function (: name->bool) to omit
  #    certain names from the profiling output
  export Profile := module()
    option package;
    export ModuleApply, GetProf, PPrProf, modules_to_profile, names_to_profile;
    local ModuleLoad, profile_flag_to_ord, name_to_string;

    modules_to_profile := proc()
      kernelopts(opaquemodules=false):
      { 'BindingTools'
      # , 'Hakaru'
      , 'KB'
      , 'Partition'
      , 'Partition:-Simpl'
      , 'Loop'
      , 'Domain'
      # , 'NewSLO'
      , 'NewSLO:-fromLO'
      , 'NewSLO:-toLO'
      , 'NewSLO:-reduce'
      , 'NewSLO:-reduce_Integrals'
      , 'NewSLO:-reduce_Partition'
      , 'NewSLO:-simplify_factor_assuming'
      , 'Summary'
      , entries(Domain:-Improve:-Simplifiers, nolist)
      };
    end proc;

    names_to_profile := proc()
      option remember, system;
      local ns;
      kernelopts(opaquemodules=false):
      ns := cl(curry(map,x->CodeTools:-Profiling:-getMemberFuncs(x,true)),
               modules_to_profile());
      map(proc(n)
            if n::`module`('ModuleApply') then 'n[ModuleApply]' elif n::procedure then n else NULL end if
          end proc, ns);
    end proc;

    name_to_string := (x->convert(x,'string'));

    profile_flag_to_ord := table(
       ['alpha' = (proc (a, b) lexorder(a[1],b[1]) end proc)
       ,'ralpha' = (proc (a, b) not lexorder(a[1],b[1]) end proc)
       ,'time' = (proc (a, b) evalb(a[4] < b[4]) end proc)
       ,'rtime' = (proc (a, b) evalb(b[4] < a[4]) end proc)
       ,'bytes' = (proc (a, b) evalb(a[6] < b[6]) end proc)
       ,'rbytes' = (proc (a, b) evalb(b[6] < a[6]) end proc)
       ,'load' = (proc (a, b) evalb(a[6]*a[6]*a[4] < b[6]*b[6]*b[4]) end proc)
       ,'rload' = (proc (a, b) evalb(b[6]*b[6]*b[4] < a[6]*a[6]*a[4]) end proc)
       ]);

    GetProf := proc(fns::({list,set})(satisfies(x->member(x,:-profile_profiled)))
                   ,{_flag:='rload'}
                   )
      local i, totaltime, totalbytes, totaldepth, totalcalls, timepc, bytespc, numargs, displist, totaltimepc, totalbytespc
           , ix, get_timepc, get_bytespc, get_nm, nm, flag ;
      global profile_time, profile_bytes, profile_maxdepth, profile_calls, profile_profiled;

      flag := _flag;
      totaltime, totalbytes, totalcalls, totaldepth := 0$4;
      numargs := nops(fns);

      for i to nops(profile_profiled) do
        ix := name_to_string(profile_profiled[i]);
        totaltime := totaltime+profile_time[ix];
        totalbytes := totalbytes+profile_bytes[ix];
        totalcalls := totalcalls+profile_calls[ix];
        totaldepth := totaldepth+profile_maxdepth[ix];
      end do;

      if totaltime = 0 then
        get_timepc := i->0;
        totaltimepc := 0;
      else
        get_timepc := i->100*profile_time[name_to_string(profile_profiled[i])]/totaltime;
        totaltimepc := 100;
      end if;
      for i to nops(profile_profiled) do
        timepc[name_to_string(profile_profiled[i])] := get_timepc(i);
      end do;

      if totalbytes = 0 then
        get_bytespc := i->0;
        totalbytespc := 0;
      else
        get_bytespc := i->100*profile_bytes[name_to_string(profile_profiled[i])]/totalbytes;
        totalbytespc := 100;
      end if;
      for i to nops(profile_profiled) do
        bytespc[name_to_string(profile_profiled[i])] := get_bytespc(i);
      end do;

      displist := [];
      if 0 < numargs then
        get_nm := i->op(i,fns);
      else
        numargs := nops(profile_profiled);
        get_nm := i->profile_profiled[i];
      end if;
      for i to numargs do
        nm := get_nm(i); ix := name_to_string(nm);
        displist := [op(displist),
                     [nm, map(q->q[ix],[profile_maxdepth, profile_calls,
                                        profile_time, timepc, profile_bytes, bytespc])[]  ]];
      end do;

      displist := sort(displist, profile_flag_to_ord[flag]);
      displist, [totaldepth,totalcalls,totaltime,totaltimepc,totalbytes,totalbytespc];
    end proc;

    PPrProf := proc(dat,tot,{_max_name_len:=55,_prof_name:=`function`})
      local i, k, pr_nm;
      k := _max_name_len; pr_nm := _prof_name;

      printf(cat(pr_nm,(" "$k-StringTools[Length](convert(pr_nm,string))),
                 `depth    calls     time    time%%     `));
      printf(`    bytes   bytes%%\n`);
      printf(cat("--"$k+1,`\n`));
      for i from 1 to nops(dat) do
        printf(cat(`%-`,convert(k,string),`a%7d%9d%9.3f%9.2f%14d%9.2f\n`),
               op(1..7,dat[i]));
      end do;
      printf(cat("--"$k+1,`\n`));
      printf(cat(`%-`,convert(k,string),`a%7d%9d%9.3f%9.2f%14d%9.2f\n\n`),
             `total:`,op(1..6,tot));
        return NULL
    end proc;

    ModuleApply := proc(f,{_args:=[]})
      local names_prof, res, nppr, rm_ppr, prf, tot, as; as := _args;
      if assigned(_Env_Profile_count_ppr) then
        nppr := _Env_Profile_count_ppr;
      else nppr := 25; end if;
      if assigned(_Env_Profile_remove_ppr) then
        rm_ppr := _Env_Profile_remove_ppr;
      else rm_ppr := (x->andmap(q->op(q,x)<0.001,[3,4,6])); end if;

      unprofile();
      names_prof := names_to_profile();
      profile(op(names_prof));
      if   f::string then res := NULL; read(f);
      else                res := f(op(as)); end if;
      prf, tot := GetProf(names_prof,_rest);
      unprofile();
      prf := remove(rm_ppr, prf);
      PPrProf(take(prf,nppr),tot,_rest);
      res;
    end proc;

    ModuleLoad := proc($)
      unprotect(:-convert);
      :-convert := overload([proc(x::name,_::identical(string),$) option overload(callseq_only); sprintf("%a",x) end proc
                            ,:-convert]);
      protect(:-convert);
      NULL;
    end proc;
    ModuleLoad();
  end module;

  local ModuleLoad := proc($)
    BindingTools:-load_types_from_table(
      table(
        [(Relation=
          ''{`::`, boolean, `in`, specfunc(anything,{Or,Not,And})}'')
        ,(Name = 'And(name, Not({constant,undefined}))')
        ]));
  end proc;
  ModuleLoad();
end module;


#     1  public class sync {
#     2      private Object go = new Object();
#     3      private int waiters = 0;
#     4
#     5      public void foo() {
#     6          synchronized (go) {
#     7              waiters++;
#     8          }
#     9      }
#    10  }

# some unrelated functions are removed
type $Ljava/lang/Object; <class  {}>
type $Lsync; <class <$Ljava/lang/Object;> {
  @go <* <$Ljava/lang/Object;>> private,
  @waiters i32 private,
  &Lsync;|foo|__V|(<* <$Lsync;>>) void}>
func &Lsync;|foo|__V| (var %_this <* <$Lsync;>>) void {
  var %Reg1_R33 <* <$Ljava/lang/Object;>>
  var %Reg0_I i32
  var %Reg0_R38 <* void>
  #LINE sync.java:6
  dassign %Reg1_R33 0 (iread ptr <* <$Lsync;>> 1 (dread ptr %_this 0))
  syncenter (dread ptr %Reg1_R33 0)
  #LINE sync.java:7
  dassign %Reg0_I 0 (iread i32 <* <$Lsync;>> 2 (dread ptr %_this 0))
  dassign %Reg0_I 0 (add i32 (
      dread i32 %Reg0_I 0,
      cvt i32 i8 (constval i8 1)))
  iassign <* <$Lsync;>> 2 (dread ptr %_this 0, dread i32 %Reg0_I 0)
  #LINE sync.java:8
  syncexit (dread ptr %Reg1_R33 0)
  #LINE sync.java:9
  return ()
  #LINE sync.java:8
  dassign %Reg0_R38 0 (regread ptr %%thrownval)
  syncexit (dread ptr %Reg1_R33 0)
  throw (dread ptr %Reg0_R38 0)
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


process ACV_setupScoreboards {
/scoreboard objectives add ACV_COLOR dummy
/scoreboard objectives add ACV_DIRECTION dummy
/scoreboard objectives add ACV_CONSTANT dummy
/scoreboard players set 2 ACV_CONSTANT 2
/scoreboard players set 5 ACV_CONSTANT 5
/scoreboard players set 4 ACV_CONSTANT 4
/scoreboard objectives add ACV_TP_FROM dummy
/scoreboard objectives add ACV_TP_UNEVEN dummy
/scoreboard objectives add ACV_TP_TO dummy
// Rotation of the Portal the entity goes in
/scoreboard objectives add ACV_TP_IR dummy
// Rotation of the Portal the entity comes out
/scoreboard objectives add ACV_TP_OR dummy
// Rotation Difference of IR and OR
/scoreboard objectives add ACV_TP_RD dummy
/scoreboard objectives add ACV_CUBE_ID dummy
/scoreboard objectives add OnGround dummy
}


type $__field_meta__ <struct {
  @fieldname i32,
  @offset i32,
  @declaringclass <* void>,
  @type <* void>}>
var $v1 <* void> public
var $v2 <* void> public
var $vs <[1] <$__field_meta__>> public = [[1= 0x35ad1b, 2= 0xabcd, 3= addrof ptr $v2, 4= addrof ptr $v1]]
var $vvs <[2][1] <$__field_meta__>> public = [[[1= 11, 2= 22, 3= addrof ptr $v1, 4= addrof ptr $v1]],
                                              [[1= 33, 2= 44, 3= addrof ptr $v2, 4= addrof ptr $v2]]]
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


program assigninteger;	{sample21}
var n:integer;begin n:=1 end.


importpath "."
importpath ".."
importpath "../ff"
var $x i32
importpath "/a/bb/ccc/"
func $foo (var %y i32) void {
  dassign $x (dread i32 %y)
}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


foo:bar;
|G G G G|G G G G|
[
	|F G G G|G|
	[
		|F G G F|
		|G G G F|
		|G G G F|
		|G D D D|
		|D E|
	]
	|F G F G|
	|F E F F|G|
	[ D ]
	|D E|
]
|F F C|F E E E|
|C G G G|G G G G|
|C C G G|G C F F|
|C D E C|D C G G|
|G C E E|E E E E|
|C E E E|E E E E|
|E C F F|G C F G|
|G C|

//+ = G
//- = E
//< = F
//> = D
//. = C
//


type $I1 <interface {@g0 i32}>
type $I2 <interfaceincomplete {@g1 i32}>
type $RR <interface <$I1> <$I2> {@e1 i32, &method1(agg)agg, &method2(void)void}>
javainterface $UU <$RR> public static
type $CC <interface {@h0 i32}>
type $TT <class <$CC> {@f1 i32, @f2 i8, @f3 i8, $I1, $I2, $RR}>
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


NewSLO:-Profile(
  proc()
    writeto(`if`(StringTools[Has](kernelopts(system), "Windows"), "NUL", "/dev/null"));
    read("NewSLOTests.mpl");
    writeto(terminal);
  end proc,
  {_prof_name="NewSLO"});


func $fact (
 var %n i32, var %p1 a64, var %p2 a64) i32 {
  var %r1 i32
  var  %r2 i32
  var  %r3 i32
 if (ne i32 i32 (dread i32 %n, constval i32 1)) {
    # Not correct, but for parse and dump test.
    intrinsiccallassigned JSOP_ADD (
      dread a64 %p1, dread a64 %p2, dread i32 %n) {
      dassign %r1 1
      dassign %r2 2
      dassign %r3 3
    }
    return (constval i32 0)
  }
}


program arraytest2;
var a : array[1] of integer;
var b : array[0] of char;

begin
end.