add code for EQUATION and Or.  Use lesseq.  Output factor when possible.

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, comma, ufunc, bfunc, lbrack, rbrack, seqp,
      lparen, rparen,
      fix_binds;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(e)
      local rts, pows, expr, binds, unsafes;

      b:-clear();

      unsafes := indets(e, specfunc(anything, 'unsafeProb'));
      expr := subs(map((x -> x = unsafeProb(freeze(op(1,x)))), unsafes), e);
      # expr := eval(e, unsafeProb = (x -> unsafeProb(freeze(x))));

      # some last-minute patching; this will need hardened, 'anything' is
      # wrong.
      pows := indets(expr, anything ^ identical(-1));
      if pows <> {} then
        expr := subs(map((x -> x = recip(op(1,x))), pows), expr);
      end if;

      # catch sqrt(2) and other sqrt calls
      rts := indets(expr, anything ^ identical(1/2));
      pows, rts := selectremove(x -> evalb(signum(op(1,x))=1), rts);
      if pows <> {} then
        expr := subs(map((x -> x = sqrt_ (op(1,x))), pows), expr);
      end if;
      expr := subs(map((x -> x = Sqrt(op(1,x))), rts), expr);

      # catch 1/sqrt(Pi)
      pows := select(x -> evalb(signum(op(1,x))=1),
               indets(expr, realcons ^ identical(-1/2)));
      if pows <> {} then
        expr := subs(map((x -> x = recip (sqrt_ (op(1,x)))), pows), expr);
      end if;

      pows := indets(expr, anything ^ integer);
      if pows <> {} then
        expr := subs(map((x -> x = IntPow(op(x))), pows), expr);
      end if;
      expr := thaw(expr);

      # deal with Domain hack in Bind
      binds := indets(expr, 'Bind'(anything, name = `..`, anything));
      expr := subs(map(fix_binds, binds), expr);

      # insert factor instead of weight when possible
      expr := subsindets(expr, 'WeightedM'(anything, identical(Return(Unit))),
          proc(x) 'Factor'(op(1, x)) end proc);

      # and now actually translate
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("(%d)",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() b:-append("fromRational ");
                lparen(); p(n); b:-append(" / "); p(d); rparen(); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_LOCALNAME] := proc(s,n)
  b:-append(cat(s,n))
end proc;
# SUM is n-ary
d[_Inert_SUM] := proc()
  lparen(); seqp(" + ", [_passed]); rparen();
end;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  # should be Int "^" Int
  #        or Real "^^" Int
  #        or Prob "^^" Int
  #        or Real "**" Real
  #        or Prob "`pow_`" Real
  #
  # Note that the two cases for ^^, when the rhs is a literal, is now ok
  parens(proc() p(a1); b:-append(" ** "); p(a2) end);
end;
d[_Inert_LESSTHAN] := proc(a1, a2)
  lparen(); b:-append("less"); sp(); p(a1); sp(); p(a2); rparen();
end proc;
d[_Inert_LESSEQ] := proc(a1, a2)
  lparen(); b:-append("lesseq"); sp(); p(a1); sp(); p(a2); rparen();
end proc;
d[_Inert_EQUATION] := proc(a1, a2)
  lparen(); b:-append("equal"); sp(); p(a1); sp(); p(a2); rparen();
end proc;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Factor"] := ufunc("factor");
bi["unsafeProb"] := ufunc("unsafeProb");
bi["fromProb"] := ufunc("fromProb");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;
bi["Fst"] := ufunc("fst_");
bi["Snd"] := ufunc("snd_");

# be careful what you ask for!
bi["undefined"] := proc() b:-append("42") end;

bi["Bind"] := proc(meas, var, rest)
  local rng;
  p(meas);
  b:-append(" `bind` \\");
  if type(var, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,var));
    b:-append(" -> ");
  elif type(var, specfunc(anything,'_Inert_LOCALNAME')) then
    b:-append(cat(op(1,var),op(2,var)));
    b:-append(" -> ");
  else
    ASSERT(type(var, specfunc(anything, '_Inert_EQUATION')));
    rng := FromInert(op(2,var));
    if rng = -infinity .. infinity then
      b:-append(op([1,1],var));
      b:-append(" -> ");
    else
      error "variable range in `bind` not yet handled";
    end if;
  end if;
  p(rest);
end;

bi["And"] := proc() b:-append("and_"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;
bi["Or"] := proc() b:-append("or_"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

bi["SUPERPOSE"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

# will always be called in the context of a superpose
bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# this is a stand-alone superpose
bi["WeightedM"] := proc(w, m)
  b:-append("superpose"); sp(); lbrack();
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
  rbrack();
end;

bi["Pair"] := bfunc("pair");
bi["NormalD"] := bfunc("normal");
bi["BetaD"] := bfunc("beta");
bi["GammaD"] := bfunc("gamma");

bi["IntPow"] := proc(l, r)
  b:-append("("); p(l); b:-append(" ^^ "); p(r); b:-append(")");
end;

# nm should be a name!
bi["Lambda"] := proc(nm, expr)
  b:-append("lam (\\");
  b:-append(op(1,nm));
  b:-append(" -> ");
  p(expr);
  b:-append(")");
end proc;

bi["exp"] := ufunc("exp");
bi["exp_"] := ufunc("exp_");
bi["sqrt_"] := ufunc("sqrt_");
bi["Sqrt"] := ufunc("sqrt");
bi["recip"] := ufunc("recip");
bi["ln"] := ufunc("log");
bi["ln_"] := ufunc("log_");
bi["cos"] := ufunc("cos");
bi["sin"] := ufunc("sin");
bi["erf"] := ufunc("erf");
bi["GAMMA"] := ufunc("gammaFunc");

bi["If"] := proc()
  ASSERT(_npassed>0);
  if _npassed = 1 then p(_passed[1])
  elif _npassed = 2 then
    b:-append("if_ ");
    lparen(); p(_passed[1]); rparen();
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    b:-append("0");
  else
    b:-append("if_ ");
    lparen(); p(_passed[1]); rparen();
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    lparen(); thisproc(_passed[3..-1]); rparen();
  end if;
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  comma := proc() b:-append(",") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then NULL
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;

# patching routines.  ToDo: better design.
  fix_binds := proc(bind)
    local var, rng, meas, rest, lower, upper;
    (var, rng) := op(op(2,bind));
    meas := op(1,bind);
    rest := op(3,bind);
    if rng = -infinity..infinity then
      bind = 'Bind'(meas, var, rest)
    elif typematch(rng, identical(-infinity) .. (upper::Non(infinity))) then
      bind = 'Bind'(meas, var, If(upper <= var, rest, SUPERPOSE()))
    elif typematch(rng, (lower::Non(infinity)) .. identical(infinity)) then
      bind = 'Bind'(meas, var, If(var >= lower, rest, SUPERPOSE()))
    else # both finite
      (lower, upper) := op(rng);
      bind = 'Bind'(meas, var, If(var < lower, SUPERPOSE(),
                                 If(upper <= var, rest, Superpose())))
    end if;
  end
end module:

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, comma, ufunc, bfunc, lbrack, rbrack, seqp,
      lparen, rparen,
      fix_binds;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(e)
      local rts, pows, expr, binds, unsafes;

      b:-clear();

      unsafes := indets(e, specfunc(anything, 'unsafeProb'));
      expr := subs(map((x -> x = unsafeProb(freeze(op(1,x)))), unsafes), e);
      # expr := eval(e, unsafeProb = (x -> unsafeProb(freeze(x))));

      # some last-minute patching; this will need hardened, 'anything' is
      # wrong.
      pows := indets(expr, anything ^ identical(-1));
      if pows <> {} then
        expr := subs(map((x -> x = recip(op(1,x))), pows), expr);
      end if;

      # catch sqrt(2) and other sqrt calls
      rts := indets(expr, anything ^ identical(1/2));
      pows, rts := selectremove(x -> evalb(signum(op(1,x))=1), rts);
      if pows <> {} then
        expr := subs(map((x -> x = sqrt_ (op(1,x))), pows), expr);
      end if;
      expr := subs(map((x -> x = Sqrt(op(1,x))), rts), expr);

      # catch 1/sqrt(Pi)
      pows := select(x -> evalb(signum(op(1,x))=1),
               indets(expr, realcons ^ identical(-1/2)));
      if pows <> {} then
        expr := subs(map((x -> x = recip (sqrt_ (op(1,x)))), pows), expr);
      end if;

      pows := indets(expr, anything ^ integer);
      if pows <> {} then
        expr := subs(map((x -> x = IntPow(op(x))), pows), expr);
      end if;
      expr := thaw(expr);

      # deal with Domain hack in Bind
      binds := indets(expr, 'Bind'(anything, name = `..`, anything));
      expr := subs(map(fix_binds, binds), expr);

      # and now actually translate
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("(%d)",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() b:-append("fromRational ");
                lparen(); p(n); b:-append(" / "); p(d); rparen(); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_LOCALNAME] := proc(s,n)
  b:-append(cat(s,n))
end proc;
# SUM is n-ary
d[_Inert_SUM] := proc()
  lparen(); seqp(" + ", [_passed]); rparen();
end;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  # should be Int "^" Int
  #        or Real "^^" Int
  #        or Prob "^^" Int
  #        or Real "**" Real
  #        or Prob "`pow_`" Real
  #
  # Note that the two cases for ^^, when the rhs is a literal, is now ok
  parens(proc() p(a1); b:-append(" ** "); p(a2) end);
end;
d[_Inert_LESSTHAN] := proc(a1, a2)
  lparen(); b:-append("less"); sp(); p(a1); sp(); p(a2); rparen();
end proc;
d[_Inert_LESSEQ] := proc(a1, a2)
  lparen(); b:-append("or_"); sp(); lbrack();
     b:-append("less_"); sp(); p(a1); sp(); p(a2);
     comma();
     b:-append("equal_"); sp(); p(a1); sp(); p(a2);
     rbrack();
  rparen();
end proc;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Factor"] := ufunc("factor");
bi["unsafeProb"] := ufunc("unsafeProb");
bi["fromProb"] := ufunc("fromProb");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;
bi["Fst"] := ufunc("fst_");
bi["Snd"] := ufunc("snd_");

# be careful what you ask for!
bi["undefined"] := proc() b:-append("42") end;

bi["Bind"] := proc(meas, var, rest)
  local rng;
  p(meas);
  b:-append(" `bind` \\");
  if type(var, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,var));
    b:-append(" -> ");
  elif type(var, specfunc(anything,'_Inert_LOCALNAME')) then
    b:-append(cat(op(1,var),op(2,var)));
    b:-append(" -> ");
  else
    ASSERT(type(var, specfunc(anything, '_Inert_EQUATION')));
    rng := FromInert(op(2,var));
    if rng = -infinity .. infinity then
      b:-append(op([1,1],var));
      b:-append(" -> ");
    else
      error "variable range in `bind` not yet handled";
    end if;
  end if;
  p(rest);
end;

bi["And"] := proc() b:-append("and_"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

bi["SUPERPOSE"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

# will always be called in the context of a superpose
bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# this is a stand-alone superpose
bi["WeightedM"] := proc(w, m)
  b:-append("superpose"); sp(); lbrack();
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
  rbrack();
end;

bi["Pair"] := bfunc("pair");
bi["NormalD"] := bfunc("normal");
bi["BetaD"] := bfunc("beta");
bi["GammaD"] := bfunc("gamma");

bi["IntPow"] := proc(l, r)
  b:-append("("); p(l); b:-append(" ^^ "); p(r); b:-append(")");
end;

# nm should be a name!
bi["Lambda"] := proc(nm, expr)
  b:-append("lam (\\");
  b:-append(op(1,nm));
  b:-append(" -> ");
  p(expr);
  b:-append(")");
end proc;

bi["exp"] := ufunc("exp");
bi["exp_"] := ufunc("exp_");
bi["sqrt_"] := ufunc("sqrt_");
bi["Sqrt"] := ufunc("sqrt");
bi["recip"] := ufunc("recip");
bi["ln"] := ufunc("log");
bi["ln_"] := ufunc("log_");
bi["cos"] := ufunc("cos");
bi["sin"] := ufunc("sin");
bi["erf"] := ufunc("erf");
bi["GAMMA"] := ufunc("gammaFunc");

bi["If"] := proc()
  ASSERT(_npassed>0);
  if _npassed = 1 then p(_passed[1])
  elif _npassed = 2 then
    b:-append("if_ ");
    lparen(); p(_passed[1]); rparen();
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    b:-append("0");
  else
    b:-append("if_ ");
    lparen(); p(_passed[1]); rparen();
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    lparen(); thisproc(_passed[3..-1]); rparen();
  end if;
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  comma := proc() b:-append(",") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then NULL
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;

# patching routines.  ToDo: better design.
  fix_binds := proc(bind)
    local var, rng, meas, rest, lower, upper;
    (var, rng) := op(op(2,bind));
    meas := op(1,bind);
    rest := op(3,bind);
    if rng = -infinity..infinity then
      bind = 'Bind'(meas, var, rest)
    elif typematch(rng, identical(-infinity) .. (upper::Non(infinity))) then
      bind = 'Bind'(meas, var, If(upper <= var, rest, SUPERPOSE()))
    elif typematch(rng, (lower::Non(infinity)) .. identical(infinity)) then
      bind = 'Bind'(meas, var, If(var >= lower, rest, SUPERPOSE()))
    else # both finite
      (lower, upper) := op(rng);
      bind = 'Bind'(meas, var, If(var < lower, SUPERPOSE(),
                                 If(upper <= var, rest, Superpose())))
    end if;
  end
end module:


Rename GammaD parameters to be more standard

NewSLO := module ()
  option package;
  local t_pw, gensym, density, get_de, recognize_density, Diffop, WeightedM;
  export Integrand, applyintegrand,
         LO, Ret, Bind, Msum, Weight, Lebesgue, Gaussian, Uniform,
         HakaruToLO, integrate, LOToHakaru, unintegrate;

# FIXME Need eval/LO and eval/Integrand and eval/Bind to teach eval about our
# binders.  Both LO and Integrand bind from 1st arg to 2nd arg, whereas Bind
# binds from 2nd arg to 3rd arg.

  t_pw := 'specfunc(piecewise)';

# An integrand h is either an Integrand (our own binding construct for a
# measurable function to be integrated) or something that can be applied
# (probably proc, which should be applied immediately, or a generated symbol).

# TODO evalapply/Integrand instead of applyintegrand?
# TODO evalapply/{Ret,Bind,...} instead of integrate?!

  applyintegrand := proc(h, x)
    if h :: 'Integrand(name, anything)' then
      eval(op(2,h), op(1,h) = x)
    elif h :: procedure then
      h(x)
    else
      'applyintegrand'(h, x)
    end if
  end proc;

# Step 1 of 3: from Hakaru to Maple LO (linear operator)

  HakaruToLO := proc(m)
    local h;
    h := gensym('h');
    LO(h, integrate(m, h))
  end proc;

  integrate := proc(m, h)
    local x, n, i;
    if m :: 'Ret(anything)' then
      applyintegrand(h, op(1,m))
    elif m :: 'Bind(anything, name, anything)' then
      integrate(op(1,m), z -> integrate(eval(op(3,m), op(2,m) = z), h))
    elif m :: 'specfunc(Msum)' then
      `+`(op(map(integrate, [op(m)], h)))
    elif m :: 'Weight(anything, anything)' then
      op(1,m) * integrate(op(2,m), h)
    elif m :: 'Lebesgue()' then
      x := gensym('xl');
      Int(applyintegrand(h, x),
          x=-infinity..infinity)
    elif m :: 'Gaussian(anything, anything)' then
      x := gensym('xg');
      Int(density[NormalD](op(1,m),op(2,m))(x) * applyintegrand(h, x),
          x=-infinity..infinity)
    elif m :: 'Uniform(anything, anything)' then
      x := gensym('xu');
      Int(applyintegrand(h, x),
          x=op(1,m)..op(2,m)) / (op(2,m)-op(1,m))
    elif m :: 'LO(name, anything)' then
      eval(op(2,m), op(1,m) = h)
    elif m :: t_pw then
      n := nops(m);
      piecewise(seq(`if`(i::even or i=n, integrate(op(i,m), h), op(i,m)),
                    i=1..n))
    elif h :: procedure then
      x := gensym('xa');
      'integrate'(m, Integrand(x, h(x)))
    else
      'integrate'(m, h)
    end if
  end proc;

# Step 2 of 3: algebra (currently nothing)

# Step 3 of 3: from Maple LO (linear operator) back to Hakaru

  Bind := proc(m, x, n)
    if n = 'Ret'(x) then
      m # monad law: right identity
    elif m :: 'Ret(anything)' then
      eval(n, x = op(1,m)) # monad law: left identity
    else
      'Bind'(m, x, n)
    end if;
  end proc;

  Weight := proc(p, m)
    if p = 1 or m = Msum() then
      m
    elif m :: 'Weight(anything, anything)' then
      'Weight'(p * op(1,m), op(2,m))
    else
      'Weight'(p, m)
    end if;
  end proc;

  LOToHakaru := proc(lo :: LO(name, anything))
    local h;
    h := gensym(op(1,lo));
    unintegrate(h, eval(op(2,lo), op(1,lo) = h), [])
  end proc;

  unintegrate := proc(h :: name, integral, context :: list)
    local x, m,
          recognition, de, Dx, f, diffop, init,
          subintegral, weight,
          n, i, else_context, update_context;
    if integral = 0 then
      Msum()
    elif integral :: `+` then
      Msum(op(map2(unintegrate, h, convert(integral, 'list'), context)))
    elif integral :: 'applyintegrand(anything, anything)'
         and op(1,integral) = h then
      Ret(op(2,integral))
    elif integral :: 'integrate(anything, anything)' then
      x := gensym('x');
      # TODO is there any way to enrich context in this case?
      Bind(op(1,integral), x,
           unintegrate(h, applyintegrand(op(2,integral), x), context))
    elif integral :: 'Or(Int(anything, name=-infinity..infinity),
                         int(anything, name=-infinity..infinity))' then
      x := gensym(op([2,1],integral));
      # TODO: enrich context with x (measure class lebesgue)
      m := unintegrate(h, eval(op(1,integral), op([2,1],integral) = x),
                       [op(context), x::real]);
      recognition := NULL;
      if m :: 'Weight(anything, anything)' then
        de := get_de(op(1,m), x, Dx, f);
        if de :: 'Diffop(anything, anything)' then
          (diffop, init) := op(de);
          recognition := recognize_density(diffop, init, Dx, x)
            assuming op(context), x::real
        end if
      end if;
      if recognition :: 'WeightedM(anything, NormalD(anything, anything))' then
        Weight(op(1,recognition),
               Bind(Gaussian(op(op(2,recognition))), x, op(2,m)))
      else
        Bind(Lebesgue(), x, m)
      end if
    elif integral :: `*` then
      (subintegral, weight) := selectremove(has, integral, h);
      if subintegral :: `*` then
        error "Nonlinear integral %1", integral
      end if;
      Weight(weight, unintegrate(h, subintegral, context))
    elif integral :: t_pw then
      n := nops(integral);
      else_context := context;
      update_context := proc(c)
        local then_context;
        then_context := [op(else_context), c];
        else_context := [op(else_context), not c]; # Mutation!
        then_context
      end proc;
      piecewise(seq(piecewise(i::even,
                              unintegrate(h, op(i,integral),
                                          update_context(op(i-1,integral))),
                              i=n,
                              unintegrate(h, op(i,integral), else_context),
                              op(i,integral)),
                    i=1..n))
    else
      # Failure: return residual LO
      LO(h, integral)
    end if
  end proc;

  get_de := proc(dens, var, Dx, f)
    local de, init, diffop;
    try
      de := gfun[holexprtodiffeq](dens, f(var));
      if not (de = NULL) and not (de :: set) then
        de := gfun[diffeqtohomdiffeq](de, f(var));
      end if;
      if de::set then
        init, de := selectremove(type, de, `=`);
        if nops(de)=1 then
          de := de[1];
          diffop := DEtools[de2diffop](de, f(var), [Dx, var]);
          return Diffop(diffop, init)
        end if;
      elif not (de = NULL) then # no initial condition returned
        diffop := DEtools[de2diffop](de, f(var), [Dx, var]);
        return Diffop(diffop, {}); # should be {f(0)=0} ?
      end if;
    catch: # do nothing
    end try;
    Nothing
  end proc;

  # density recognizer for reals
  recognize_density := proc(diffop, init, Dx, var)
    local a0, a1, scale, at0, mu, sigma, ii;
    if degree(diffop, Dx) = 1 then
      a0 := coeff(diffop, Dx, 0);
      a1 := coeff(diffop, Dx, 1);
      if degree(a0, var) = 1 and degree(a1, var) = 0 and nops(init) = 1 then
        ii := rhs(init[1]);
        scale := coeff(a0, var, 1);
        mu := -coeff(a0, var, 0)/scale;
        sigma := sqrt(coeff(a1, var, 0)/scale);
        at0 := simplify(eval(ii/density[NormalD](mu, sigma)(0)));
        return WeightedM(at0, NormalD(mu,sigma));
      end if;
    end if;
    NULL;
  end proc;

  density[NormalD] := proc(mu, sigma) proc(x)
    1/sigma/sqrt(2)/sqrt(Pi)*exp(-(x-mu)^2/2/sigma^2)
  end proc end proc;
  density[BetaD] := proc(a, b) proc(x)
    x^(a-1)*(1-x)^(b-1)/Beta(a,b)
  end proc end proc;
  # Hakaru uses the alternate definition of gamma, so the args are backwards
  density[GammaD] := proc(shape,scale) proc(x)
    x^(shape-1)/scale^shape*exp(-x/scale)/GAMMA(shape);
  end proc end proc;

  gensym := module()
    export ModuleApply;
    local gs_counter;
    gs_counter := 0;
    ModuleApply := proc(x::name)
      gs_counter := gs_counter + 1;
      x || gs_counter;
    end proc;
  end module; # gensym

end module; # NewSLO

NewSLO := module ()
  option package;
  local t_pw, gensym, density, get_de, recognize_density, Diffop, WeightedM;
  export Integrand, applyintegrand,
         LO, Ret, Bind, Msum, Weight, Lebesgue, Gaussian, Uniform,
         HakaruToLO, integrate, LOToHakaru, unintegrate;

# FIXME Need eval/LO and eval/Integrand and eval/Bind to teach eval about our
# binders.  Both LO and Integrand bind from 1st arg to 2nd arg, whereas Bind
# binds from 2nd arg to 3rd arg.

  t_pw := 'specfunc(piecewise)';

# An integrand h is either an Integrand (our own binding construct for a
# measurable function to be integrated) or something that can be applied
# (probably proc, which should be applied immediately, or a generated symbol).

# TODO evalapply/Integrand instead of applyintegrand?
# TODO evalapply/{Ret,Bind,...} instead of integrate?!

  applyintegrand := proc(h, x)
    if h :: 'Integrand(name, anything)' then
      eval(op(2,h), op(1,h) = x)
    elif h :: procedure then
      h(x)
    else
      'applyintegrand'(h, x)
    end if
  end proc;

# Step 1 of 3: from Hakaru to Maple LO (linear operator)

  HakaruToLO := proc(m)
    local h;
    h := gensym('h');
    LO(h, integrate(m, h))
  end proc;

  integrate := proc(m, h)
    local x, n, i;
    if m :: 'Ret(anything)' then
      applyintegrand(h, op(1,m))
    elif m :: 'Bind(anything, name, anything)' then
      integrate(op(1,m), z -> integrate(eval(op(3,m), op(2,m) = z), h))
    elif m :: 'specfunc(Msum)' then
      `+`(op(map(integrate, [op(m)], h)))
    elif m :: 'Weight(anything, anything)' then
      op(1,m) * integrate(op(2,m), h)
    elif m :: 'Lebesgue()' then
      x := gensym('xl');
      Int(applyintegrand(h, x),
          x=-infinity..infinity)
    elif m :: 'Gaussian(anything, anything)' then
      x := gensym('xg');
      Int(density[NormalD](op(1,m),op(2,m))(x) * applyintegrand(h, x),
          x=-infinity..infinity)
    elif m :: 'Uniform(anything, anything)' then
      x := gensym('xu');
      Int(applyintegrand(h, x),
          x=op(1,m)..op(2,m)) / (op(2,m)-op(1,m))
    elif m :: 'LO(name, anything)' then
      eval(op(2,m), op(1,m) = h)
    elif m :: t_pw then
      n := nops(m);
      piecewise(seq(`if`(i::even or i=n, integrate(op(i,m), h), op(i,m)),
                    i=1..n))
    elif h :: procedure then
      x := gensym('xa');
      'integrate'(m, Integrand(x, h(x)))
    else
      'integrate'(m, h)
    end if
  end proc;

# Step 2 of 3: algebra (currently nothing)

# Step 3 of 3: from Maple LO (linear operator) back to Hakaru

  Bind := proc(m, x, n)
    if n = 'Ret'(x) then
      m # monad law: right identity
    elif m :: 'Ret(anything)' then
      eval(n, x = op(1,m)) # monad law: left identity
    else
      'Bind'(m, x, n)
    end if;
  end proc;

  Weight := proc(p, m)
    if p = 1 or m = Msum() then
      m
    elif m :: 'Weight(anything, anything)' then
      'Weight'(p * op(1,m), op(2,m))
    else
      'Weight'(p, m)
    end if;
  end proc;

  LOToHakaru := proc(lo :: LO(name, anything))
    local h;
    h := gensym(op(1,lo));
    unintegrate(h, eval(op(2,lo), op(1,lo) = h), [])
  end proc;

  unintegrate := proc(h :: name, integral, context :: list)
    local x, m,
          recognition, de, Dx, f, diffop, init,
          subintegral, weight,
          n, i, else_context, update_context;
    if integral = 0 then
      Msum()
    elif integral :: `+` then
      Msum(op(map2(unintegrate, h, convert(integral, 'list'), context)))
    elif integral :: 'applyintegrand(anything, anything)'
         and op(1,integral) = h then
      Ret(op(2,integral))
    elif integral :: 'integrate(anything, anything)' then
      x := gensym('x');
      # TODO is there any way to enrich context in this case?
      Bind(op(1,integral), x,
           unintegrate(h, applyintegrand(op(2,integral), x), context))
    elif integral :: 'Or(Int(anything, name=-infinity..infinity),
                         int(anything, name=-infinity..infinity))' then
      x := gensym(op([2,1],integral));
      # TODO: enrich context with x (measure class lebesgue)
      m := unintegrate(h, eval(op(1,integral), op([2,1],integral) = x),
                       [op(context), x::real]);
      recognition := NULL;
      if m :: 'Weight(anything, anything)' then
        de := get_de(op(1,m), x, Dx, f);
        if de :: 'Diffop(anything, anything)' then
          (diffop, init) := op(de);
          recognition := recognize_density(diffop, init, Dx, x)
            assuming op(context), x::real
        end if
      end if;
      if recognition :: 'WeightedM(anything, NormalD(anything, anything))' then
        Weight(op(1,recognition),
               Bind(Gaussian(op(op(2,recognition))), x, op(2,m)))
      else
        Bind(Lebesgue(), x, m)
      end if
    elif integral :: `*` then
      (subintegral, weight) := selectremove(has, integral, h);
      if subintegral :: `*` then
        error "Nonlinear integral %1", integral
      end if;
      Weight(weight, unintegrate(h, subintegral, context))
    elif integral :: t_pw then
      n := nops(integral);
      else_context := context;
      update_context := proc(c)
        local then_context;
        then_context := [op(else_context), c];
        else_context := [op(else_context), not c]; # Mutation!
        then_context
      end proc;
      piecewise(seq(piecewise(i::even,
                              unintegrate(h, op(i,integral),
                                          update_context(op(i-1,integral))),
                              i=n,
                              unintegrate(h, op(i,integral), else_context),
                              op(i,integral)),
                    i=1..n))
    else
      # Failure: return residual LO
      LO(h, integral)
    end if
  end proc;

  get_de := proc(dens, var, Dx, f)
    local de, init, diffop;
    try
      de := gfun[holexprtodiffeq](dens, f(var));
      if not (de = NULL) and not (de :: set) then
        de := gfun[diffeqtohomdiffeq](de, f(var));
      end if;
      if de::set then
        init, de := selectremove(type, de, `=`);
        if nops(de)=1 then
          de := de[1];
          diffop := DEtools[de2diffop](de, f(var), [Dx, var]);
          return Diffop(diffop, init)
        end if;
      elif not (de = NULL) then # no initial condition returned
        diffop := DEtools[de2diffop](de, f(var), [Dx, var]);
        return Diffop(diffop, {}); # should be {f(0)=0} ?
      end if;
    catch: # do nothing
    end try;
    Nothing
  end proc;

  # density recognizer for reals
  recognize_density := proc(diffop, init, Dx, var)
    local a0, a1, scale, at0, mu, sigma, ii;
    if degree(diffop, Dx) = 1 then
      a0 := coeff(diffop, Dx, 0);
      a1 := coeff(diffop, Dx, 1);
      if degree(a0, var) = 1 and degree(a1, var) = 0 and nops(init) = 1 then
        ii := rhs(init[1]);
        scale := coeff(a0, var, 1);
        mu := -coeff(a0, var, 0)/scale;
        sigma := sqrt(coeff(a1, var, 0)/scale);
        at0 := simplify(eval(ii/density[NormalD](mu, sigma)(0)));
        return WeightedM(at0, NormalD(mu,sigma));
      end if;
    end if;
    NULL;
  end proc;

  density[NormalD] := proc(mu, sigma) proc(x)
    1/sigma/sqrt(2)/sqrt(Pi)*exp(-(x-mu)^2/2/sigma^2)
  end proc end proc;
  density[BetaD] := proc(a, b) proc(x)
    x^(a-1)*(1-x)^(b-1)/Beta(a,b)
  end proc end proc;
  # Hakaru uses the alternate definition of gamma, so the args are backwards
  density[GammaD] := proc(theta,k) proc(x)
    x^(theta-1)/k^(theta-1)*exp(-x/k)/k/GAMMA(theta);
  end proc end proc;

  gensym := module()
    export ModuleApply;
    local gs_counter;
    gs_counter := 0;
    ModuleApply := proc(x::name)
      gs_counter := gs_counter + 1;
      x || gs_counter;
    end proc;
  end module; # gensym

end module; # NewSLO


make local tests more representative of what would actually be passed in


offline test suite, easier to maintain.  Run with (maple -q < NewSLOTests.mpl).

kernelopts(assertlevel=2): # be strict on all assertions while testing
kernelopts(opaquemodules=false): # allow testing of internal routines
read "NewSLO.mpl":

with(NewSLO):

# covers primitive constructs
model1 :=
  Bind(Gaussian(0,1), x,
  Bind(Msum(Ret(0),Weight(1,Lebesgue())), y,
  Ret(1/exp(x^2+y^2)))):

# simplifies to
model1s :=
  Bind(Gaussian(0,1), x,
  Msum(Ret(1/exp(x^2)),
       Bind(Lebesgue(), y,
       Ret(1/exp(x^2+y^2))))):

CodeTools[Test](value(integrate(model1,z->z)), (sqrt(Pi)+1)/sqrt(3), equal,
  label="primitive constructs + integrate + value");

TestHakaru(model1, model1s, label = "primitive constructs simplification");

# Unknown measures -- no changes
u1 := Bind(m, x, Ret(x^2)):
u2 := Bind(Gaussian(0,1), x, m(x)):

TestHakaru(u1, u1, label = "binding unknown m");
TestHakaru(u2, u2, label = "sending to unknown m");

# example with an elaborate simplifier to do reordering of
# integration, which in turn integrates out a variable
model3 := Bind(Gaussian(0,1),x,Gaussian(x,1)):

TestHakaru(model3, Gaussian(0,sqrt(2)),
 simp = (lo -> evalindets(lo, 'specfunc(Int)',
  i -> evalindets(IntegrationTools[CollapseNested](
                  IntegrationTools[Combine](i)), 'Int(anything,list)',
  i -> subsop(0=int, applyop(ListTools[Reverse], 2, i))))),
  label = "use simplifier to integrate out variable");

# Kalman filter; note the parameter + assumption
kalman :=
  Bind(Gaussian(0,1),x,Weight(NewSLO:-density[Gaussian](x,1)(y),Ret(x))):

TestHakaru( kalman,
  Weight(exp(-y^2/4)/2/sqrt(Pi),Gaussian(y/2,1/sqrt(2))),
  label = "Kalman filter") assuming y::real;

# piecewise
model4 :=
  Bind(Gaussian(0,1),x,
  Bind(piecewise(x<0,Ret(0),x>4,Ret(4),Ret(x)),y,
  Ret(y^2))):
model4s := Bind(Gaussian(0,1),x,piecewise(x<0,Ret(0),4<x,Ret(16),Ret(x^2))):

TestHakaru(model4, model4s, label = "piecewise test");

# test with uniform.  No change without simplifier, eliminates it with
# call to value.
introLO :=
  Bind(Uniform(0,1),x,
  Bind(Uniform(0,1),y,
  piecewise(x<y,Ret(true),x>=y,Ret(false)))):
introLOs := Msum(Weight(1/2, Ret(false)), Weight(1/2, Ret(true))):

TestHakaru(introLO, introLO, label = "2 uniform - no change");
TestHakaru(introLO, introLOs, simp = value, label = "2 uniform + value = elimination");

# a variety of other tests
TestHakaru(LO(h,(x*applyintegrand(h,5)+applyintegrand(h,3))/x), Weight(1/x, Msum(Weight(x, Ret(5)), Ret(3))));
TestHakaru(Bind(Gaussian(0,1),x,Weight(x,Msum())), Msum());
TestHakaru(Bind(Uniform(0,1),x,Weight(x^alpha,Ret(x))), Weight(1/(1+alpha),BetaD(1+alpha,1)));
TestHakaru(Bind(Uniform(0,1),x,Weight(x^alpha*(1-x)^beta,Ret(x))), Weight(Beta(1+alpha,1+beta),BetaD(1+alpha,1+beta)));
TestHakaru(Bind(Uniform(0,1),x,Weight((1-x)^beta,Ret(x))), Weight(1/(1+beta),BetaD(1,1+beta)));

# tests that basic densities are properly recognized
TestHakaru(Bind(Uniform(0,1),x,Weight(x*2,Ret(x))), BetaD(2,1));
TestHakaru(BetaD(alpha,beta));
TestHakaru(GammaD(a,b));
TestHakaru(LO(h, int(exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(2,GammaD(1,2)));
TestHakaru(LO(h, int(x*exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(4,GammaD(2,2)));
TestHakaru(Bind(Lebesgue(), x, Weight(1/x^2, Ret(x))));
TestHakaru(Cauchy(loc,scale)) assuming scale>0;

# how far does value get us?
TestHakaru(Bind(Uniform(0,1),x,Weight(x,Ret(Unit))), Weight(1/2,Ret(Unit)), simp = value);
TestHakaru(Bind(Weight(1/2,Ret(Unit)),x,Ret(Unit)), Weight(1/2, Ret(Unit)), simp = value);

# and more various
TestHakaru(Bind(Uniform(-1,1),x,Ret(exp(x))));
TestHakaru(IntegrationTools[Expand](LO(h, Int((1+y)*applyintegrand(h,y),y=0..1))), Msum(Uniform(0,1), Weight(1/2,BetaD(2,1))));
TestHakaru(Bind(Uniform(0,1),x,Bind(IntegrationTools[Expand](LO(h, Int((1+y)*applyintegrand(h,y),y=0..1))),y,Ret([x,y]))), Weight(3/2,Bind(Uniform(0,1),x,Msum(Weight(2/3,Bind(Uniform(0,1),y,Ret([x,y]))),Weight(1/3,Bind(BetaD(2,1),y,Ret([x,y])))))));

# and now models (then tests) taken from Tests.RoundTrip
t1 := Bind(Uniform(0, 1), a0, Msum(Weight(a0, Ret(Unit)))):
t2 := BetaD(1,1):
t2s := Bind(Uniform(0, 1), a0, Ret(a0)):
t3 := Gaussian(0,10):
t4 := Bind(BetaD(1, 1), a0,
      Bind(Msum(Weight(a0, Ret(true)),
                Weight((1-a0), Ret(false))), a1,
      Ret(Pair(a0, a1)))):
t4s := Bind(Uniform(0, 1), a0,
       Msum(Weight(a0, Ret(Pair(a0, true))),
            Weight((1+(a0*(-1))), Ret(Pair(a0, false))))):
t5 := Bind(Msum(Weight((1/2), Ret(Unit))), a0, Ret(Unit)):
t5s := Weight((1/2), Ret(Unit)):

TestHakaru(t1, t5s, label = "t1");
TestHakaru(t2, t2s, label = "t2");
TestHakaru(t3, t3, label = "t3");
TestHakaru(t4, t4s, label = "t4");
TestHakaru(t5, t5s, label = "t5");

error: pathspec 'maple/NewSLOTests.mpl' did not match any file(s) known to git


mixed 2 spots for the proper translation of 0

# SLO = Simplify Linear Operator.
#
#  This assumes that the input is the output of Language.Hakaru.Syntax.tester
# No checking is done that this is actually the case.
#
# SLO : simplifier
# AST : takes simplified form and transform to AST
#

SLO := module ()
  export ModuleApply, AST, simp, c; # very important: this c is "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw;

  t_binds := 'specfunc(anything, {int, Int, sum, Sum})';
  t_pw := 'specfunc(anything, piecewise)';

  ModuleApply := proc(inp::anything)
    local e;
    try
      simp(value(eval(inp(c), 'if_'=piecewise)));
    catch "Wrong kind of parameters in piecewise":
      error "Bug in Hakaru -> Maple translation, piecewise used incorrectly.";
    end try;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  AST := proc(inp::anything)
    local cs;
    cs := indets(inp, 'specfunc'(anything,c));
    # deal with trivial input first
    if inp=0 then
        Superpose()
    # then deal with 'bad' input
    elif nops(cs) = 0 then
      error "the constant", inp, " is not a measure."
    else
      ToAST(inp, []);
    end if;
  end proc;

  # recursive function which does the main translation
  ToAST := proc(e, ctx)
    local a0, a1, var, vars, rng, ee, cof, d, ld, weight, binders,
      v, subst, ivars, ff, newvar, rest;
    if type(e, specfunc(name, c)) then
        return Return(op(e))
    # we might have recursively encountered a hidden 0
    elif (e = 0) then
       return Superpose()
    # we might have done something odd, and there is no x anymore (and not 0)
    elif type(e, 'numeric') then
      error "the constant", e, "is not a measure"
    # invariant: we depend on c
    else
      binders := indets(e, t_binds);
      vars := indets(e, specfunc(anything, c));
      subst := map(x-> x = op(0,x)[op(x)], vars);
      ivars := map2(op, 2, subst);
      if binders = {} then
        # this is a 'raw' measure, with no integrals
        ee := subs(subst, e);
        if type(ee, 'polynom'(anything,ivars)) then
          ee := collect(ee, ivars, simplify);
          d := degree(ee, ivars);
          ld := ldegree(ee, ivars);
          cof := [coeffs(ee, ivars, 'v')]; # cof is a list, v expseq
          if (d = 1) and (ld = 1) then
            # WM = Weight-Measure pair
            ff := (x,y) -> WM(simplify(x), Return(op(y)));
            Superpose(op(zip(ff, cof, [v])));
            # `if`(cof=1, rest, Bind_(Factor(simplify(cof)), rest))
          else
            if (ld = 0) then
              error "non-zero constant encountered as a measure", ee
            else
              error "polynomial in c:", ee
            end if;
          end if;
        elif type(ee, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
          error "no binders, but still not a polynomial?", ee
        end if;
      else
        if type(e, 'specfunc'(anything, {'int','Int'})) then
          var, rng := op(op(2,e));
          ee := op(1,e);
          weight := simplify(op(2,rng)-op(1,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, [op(2,e), op(ctx)]);
            # should recognize densities here
            Bind(Lebesgue, var = rng, rest)
          else
            rest := ToAST(weight*ee, [op(2,e), op(ctx)]);
            # process the rest, and then recognize
            # recognize 'raw' uniform
            if type(rest, specfunc(identical(var), 'Return')) then
              Uniform(op(rng));
            elif type(rest, 'Superpose'('WM'(anything, anything))) then
              # finite range.
              weight := simplify(op([1,1], rest));
              ee := op([1,2], rest);
              if ctx=[] and type(ee, Return(anything)) then
                Bind(Uniform(op(1, rng), op(2, rng)), var,
                    Superpose(WM(weight, simplify(ee))))
              else
                error "almost uniform but not quite?", ee
              end if;
            else
              Bind(Lebesgue, var = rng, rest)
            end if;
          end if;
        elif type(e, 'specfunc'(anything, {'sum','Sum'})) then
            error "sums not handled yet"
        elif type(e, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
            error "constants should have been pushed inside already", e
        end if;
      end if;
    end if;
  end proc;

  # simp mostly pushes things in.
  simp := proc(e)
    local a, b, d;
    if type(e, `+`) then
      map(simp, e)
    elif type(e, `*`) then
      a, b := selectremove(type, e, t_binds);
      # now casesplit on what a is
      if a=1 then  # no binders
        a, b := selectremove(type, e, t_pw);
        if a=1 then # and no piecewise either
          d := expand(b); # probably need to write something less brutal
          if b=d then # nothing happened
            simplify(b)
          else # this might be better
            simp(d)
          end if
        elif type(a, `*`) then
          error "do not know how to multiply 2 pw:", a
        elif type(a, t_pw) then
          into_pw(b, a)
        else
          error "something weird happened:", a, " was supposed to be pw"
        end if
      elif type(a, `*`) then
        error "product of 2 binders?!?", a
      else
        subsop(1=myprod(simp(b),simp(op(1,a))), a)
      end if
    elif type(e, t_binds) then
      subsop(1=simp(op(1,e)), e)
    # need to go into pw even if there is no factor to push in
    elif type(e, t_pw) then
      into_pw(1, e)
    else
      simplify(e)
    end if;
  end;

  into_pw := proc(fact, pw)
    local n, f;

    n := nops(pw);
    f := proc(j)
      if j=n then # last one is special, always a value
        simp(myprod(fact, simp(op(j, pw))))
      elif type(j,'odd') then # a condition
        op(j, pw)
      else # j even
        simp(myprod(fact , simp(op(j, pw))))
      end if;
    end proc;
    piecewise(seq(f(i),i=1..n))
  end proc;

  # myprod takes care of pushing a product inside a `+`
  myprod := proc(a, b)
    if type(b,`+`) then
      map2(myprod, a, b)
    else
      a*b
    end if;
  end proc;

  gs_counter := 0;
  gensym := proc(x::name) gs_counter := gs_counter + 1; x || gs_counter; end proc;

  # this assumes we are doing pw of measures.
  do_pw := proc(l, ctx)
    local len;
    len := nops(l);
    if len = 0 then Superpose()
    elif len = 1 then ToAST(l[1], ctx)
    else # l>=2. Note how conditions go through straight
      If(l[1], ToAST(l[2], ctx), thisproc(l[3..-1], ctx))
    end if;
  end;
end;

# this has to be global!
unsafeProb := proc(v)
  if type(v,'realcons') and signum(0, v, 1) = 1 then v else 'unsafeProb'(v) end if;
end proc;

# will get called on expressions containing 'unsafeProb'
`simplify/unsafeProb` := proc(x) local sub, f;
  sub := indets(x, 'specfunc'(anything, unsafeProb));
  f := proc(a) local b;
    b := op(1,a);
    if type(b, 'exp'(anything)) then exp_(op(1, b)) else a end if;
  end proc;
  subs(map(y -> y = f(y), sub), x)
end proc;

# works, but could be made more robust
`evalapply/if_` := proc(f, t) if_(op(1,f), op(2,f)(t[1]), op(3,f)(t[1])) end;

# SLO = Simplify Linear Operator.
#
#  This assumes that the input is the output of Language.Hakaru.Syntax.tester
# No checking is done that this is actually the case.
#
# SLO : simplifier
# AST : takes simplified form and transform to AST
#

SLO := module ()
  export ModuleApply, AST, simp, c; # very important: this c is "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw;

  t_binds := 'specfunc(anything, {int, Int, sum, Sum})';
  t_pw := 'specfunc(anything, piecewise)';

  ModuleApply := proc(inp::anything)
    local e;
    try
      simp(value(eval(inp(c), 'if_'=piecewise)));
    catch "Wrong kind of parameters in piecewise":
      error "Bug in Hakaru -> Maple translation, piecewise used incorrectly.";
    end try;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  AST := proc(inp::anything)
    local cs;
    cs := indets(inp, 'specfunc'(anything,c));
    # deal with trivial input first
    if inp=0 then
        Superpose()
    # then deal with 'bad' input
    elif nops(cs) = 0 then
      error "the constant", inp, " is not a measure."
    else
      ToAST(inp, []);
    end if;
  end proc;

  # recursive function which does the main translation
  ToAST := proc(e, ctx)
    local a0, a1, var, vars, rng, ee, cof, d, ld, weight, binders,
      v, subst, ivars, ff, newvar, rest;
    if type(e, specfunc(name, c)) then
        return Return(op(e))
    # we might have recursively encountered a hidden 0
    elif (e = 0) then
       return 0
    # we might have done something odd, and there is no x anymore (and not 0)
    elif type(e, 'numeric') then
      error "the constant", e, "is not a measure"
    # invariant: we depend on c
    else
      binders := indets(e, t_binds);
      vars := indets(e, specfunc(anything, c));
      subst := map(x-> x = op(0,x)[op(x)], vars);
      ivars := map2(op, 2, subst);
      if binders = {} then
        # this is a 'raw' measure, with no integrals
        ee := subs(subst, e);
        if type(ee, 'polynom'(anything,ivars)) then
          ee := collect(ee, ivars, simplify);
          d := degree(ee, ivars);
          ld := ldegree(ee, ivars);
          cof := [coeffs(ee, ivars, 'v')]; # cof is a list, v expseq
          if (d = 1) and (ld = 1) then
            # WM = Weight-Measure pair
            ff := (x,y) -> WM(simplify(x), Return(op(y)));
            Superpose(op(zip(ff, cof, [v])));
            # `if`(cof=1, rest, Bind_(Factor(simplify(cof)), rest))
          else
            if (ld = 0) then
              error "non-zero constant encountered as a measure", ee
            else
              error "polynomial in c:", ee
            end if;
          end if;
        elif type(ee, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
          error "no binders, but still not a polynomial?", ee
        end if;
      else
        if type(e, 'specfunc'(anything, {'int','Int'})) then
          var, rng := op(op(2,e));
          ee := op(1,e);
          weight := simplify(op(2,rng)-op(1,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, [op(2,e), op(ctx)]);
            # should recognize densities here
            Bind(Lebesgue, var = rng, rest)
          else
            rest := ToAST(weight*ee, [op(2,e), op(ctx)]);
            # process the rest, and then recognize
            # recognize 'raw' uniform
            if type(rest, specfunc(identical(var), 'Return')) then
              Uniform(op(rng));
            elif type(rest, 'Superpose'('WM'(anything, anything))) then
              # finite range.
              weight := simplify(op([1,1], rest));
              ee := op([1,2], rest);
              if ctx=[] and type(ee, Return(anything)) then
                Bind(Uniform(op(1, rng), op(2, rng)), var,
                    Superpose(WM(weight, simplify(ee))))
              else
                error "almost uniform but not quite?", e
              end if;
            else
              Bind(Lebesgue, var = rng, rest)
            end if;
          end if;
        elif type(e, 'specfunc'(anything, {'sum','Sum'})) then
            error "sums not handled yet"
        elif type(e, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
            error "constants should have been pushed inside already", e
        end if;
      end if;
    end if;
  end proc;

  # simp mostly pushes things in.
  simp := proc(e)
    local a, b, d;
    if type(e, `+`) then
      map(simp, e)
    elif type(e, `*`) then
      a, b := selectremove(type, e, t_binds);
      # now casesplit on what a is
      if a=1 then  # no binders
        a, b := selectremove(type, e, t_pw);
        if a=1 then # and no piecewise either
          d := expand(b); # probably need to write something less brutal
          if b=d then # nothing happened
            simplify(b)
          else # this might be better
            simp(d)
          end if
        elif type(a, `*`) then
          error "do not know how to multiply 2 pw:", a
        elif type(a, t_pw) then
          into_pw(b, a)
        else
          error "something weird happened:", a, " was supposed to be pw"
        end if
      elif type(a, `*`) then
        error "product of 2 binders?!?", a
      else
        subsop(1=myprod(simp(b),simp(op(1,a))), a)
      end if
    elif type(e, t_binds) then
      subsop(1=simp(op(1,e)), e)
    # need to go into pw even if there is no factor to push in
    elif type(e, t_pw) then
      into_pw(1, e)
    else
      simplify(e)
    end if;
  end;

  into_pw := proc(fact, pw)
    local n, f;

    n := nops(pw);
    f := proc(j)
      if j=n then # last one is special, always a value
        simp(myprod(fact, simp(op(j, pw))))
      elif type(j,'odd') then # a condition
        op(j, pw)
      else # j even
        simp(myprod(fact , simp(op(j, pw))))
      end if;
    end proc;
    piecewise(seq(f(i),i=1..n))
  end proc;

  # myprod takes care of pushing a product inside a `+`
  myprod := proc(a, b)
    if type(b,`+`) then
      map2(myprod, a, b)
    else
      a*b
    end if;
  end proc;

  gs_counter := 0;
  gensym := proc(x::name) gs_counter := gs_counter + 1; x || gs_counter; end proc;

  do_pw := proc(l, ctx)
    local len;
    len := nops(l);
    if len = 0 then 0
    elif len = 1 then ToAST(l[1], ctx)
    else # l>=2. Note how conditions go through straight
      If(l[1], ToAST(l[2], ctx), thisproc(l[3..-1], ctx))
    end if;
  end;
end;

# this has to be global!
unsafeProb := proc(v)
  if type(v,'realcons') and signum(0, v, 1) = 1 then v else 'unsafeProb'(v) end if;
end proc;

# will get called on expressions containing 'unsafeProb'
`simplify/unsafeProb` := proc(x) local sub, f;
  sub := indets(x, 'specfunc'(anything, unsafeProb));
  f := proc(a) local b;
    b := op(1,a);
    if type(b, 'exp'(anything)) then exp_(op(1, b)) else a end if;
  end proc;
  subs(map(y -> y = f(y), sub), x)
end proc;

# works, but could be made more robust
`evalapply/if_` := proc(f, t) if_(op(1,f), op(2,f)(t[1]), op(3,f)(t[1])) end;


testKernel output

testKernel output


fix straight bugs in resolve and product handling

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, ufunc, bfunc, lbrack, rbrack, seqp;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(expr)
      b:-clear();
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("%d",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() p(n); b:-append(" / "); p(d); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  parens(proc() p(a1); b:-append(" ^ "); p(a2) end);
end;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;

bi["Bind"] := proc(meas, rng, rest)
  p(meas);
  b:-append(" `bind` \\");
  if type(rng, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,rng));
    b:-append(" -> ");
  else
    error "variable range in `bind` not yet handled";
  end if;
  p(rest);
end;

bi["Superpose"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then error "empty sequence passed where non-empty expected";
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;
end module:

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, ufunc, bfunc;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(expr)
      b:-clear();
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("%d",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() p(n); b:-append(" / "); p(d); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_PROD] := proc(a1,a2)
  parens(proc() p(a1); b:-append(" * "); p(a2) end);
end;
d[_Inert_POWER] := proc(a1,a2)
  parens(proc() p(a1); b:-append(" ^ "); p(a2) end);
end;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;

bi["Bind"] := proc(meas, rng, rest)
  p(meas);
  b:-append(" `bind` \\");
  if type(rng, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,rng));
    b:-append(" -> ");
  else
    error "variable range in `bind` not yet handled";
  end if;
  p(rest);
end;

bi["Superpose"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp([_passed]); rbrack();
end;

bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(l)
    if nops(l)=0 then error "empty sequence passed where non-empty expected";
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      p(", ");
      seqp(l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::string, '_Inert_NAME')) then
      s
    elif typematch(nm, specfunc('s'::string, string, '_Inert_ASSIGNEDNAME')) then
      s
    else
      error "cannot resolve an %1", op(0,inrt);
    end if;
  end proc;
end module:


do not prematurely map over +

do not prematurely map over +

# SLO = Simplify Linear Operator.
#
#  This assumes that the input is the output of Language.Hakaru.Syntax.tester
# No checking is done that this is actually the case.
#
# SLO : simplifier
# AST : takes simplified form and transform to AST
#

SLO := module ()
  export ModuleApply, AST, simp, c; # very important: this c is "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw;

  t_binds := 'specfunc(anything, {int, Int, sum, Sum})';
  t_pw := 'specfunc(anything, piecewise)';

  ModuleApply := proc(inp::anything)
    local e;
    try
      simp(value(eval(inp(c), 'if_'=piecewise)));
    catch "Wrong kind of parameters in piecewise":
      error "Bug in Hakaru -> Maple translation, piecewise used incorrectly.";
    end try;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  AST := proc(inp::anything)
    local cs;
    cs := indets(inp, 'specfunc'(anything,c));
    # deal with trivial input first
    if inp=0 then
        0
    # then deal with 'bad' input
    elif nops(cs) = 0 then
      error "the constant", inp, " is not a measure."
    else
      ToAST(inp, []);
    end if;
  end proc;

  # recursive function which does the main translation
  ToAST := proc(e, ctx)
    local a0, a1, var, vars, rng, ee, cof, d, ld, weight, binders,
      v, subst, ivars, ff, newvar, rest;
    if type(e, specfunc(name, c)) then
        return Return(op(e))
    # we might have recursively encountered a hidden 0
    elif (e = 0) then
       return 0
    # we might have done something odd, and there is no x anymore (and not 0)
    elif type(e, 'numeric') then
      error "the constant", e, "is not a measure"
    # invariant: we depend on c
    else
      binders := indets(e, t_binds);
      vars := indets(e, specfunc(anything, c));
      subst := map(x-> x = op(0,x)[op(x)], vars);
      ivars := map2(op, 2, subst);
      if binders = {} then
        # this is a 'raw' measure, with no integrals
        ee := subs(subst, e);
        if type(ee, 'polynom'(anything,ivars)) then
          ee := collect(ee, ivars, simplify);
          d := degree(ee, ivars);
          ld := ldegree(ee, ivars);
          cof := [coeffs(ee, ivars, 'v')]; # cof is a list, v expseq
          if (d = 1) and (ld = 1) then
            # WM = Weight-Measure pair
            ff := (x,y) -> WM(simplify(x), Return(op(y)));
            Superpose(op(zip(ff, cof, [v])));
            # `if`(cof=1, rest, Bind_(Factor(simplify(cof)), rest))
          else
            if (ld = 0) then
              error "non-zero constant encountered as a measure", ee
            else
              error "polynomial in c:", ee
            end if;
          end if;
        elif type(ee, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
          error "no binders, but still not a polynomial?", ee
        end if;
      else
        if type(e, 'specfunc'(anything, {'int','Int'})) then
          var, rng := op(op(2,e));
          ee := op(1,e);
          weight := simplify(op(2,rng)-op(1,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, [op(2,e), op(ctx)]);
            # should recognize densities here
            Bind(Lebesgue, var = rng, rest)
          else
            rest := ToAST(weight*ee, [op(2,e), op(ctx)]);
            # process the rest, and then recognize
            # recognize 'raw' uniform
            if type(rest, specfunc(identical(var), 'Return')) then
              Uniform(op(rng));
            elif type(rest, 'Superpose'('WM'(anything, anything))) then
              # finite range.
              weight := simplify(op([1,1], rest));
              ee := op([1,2], rest);
              if ctx=[] and type(ee, Return(anything)) then
                Bind(Uniform(op(1, rng), op(2, rng)), var,
                    Superpose(WM(weight, simplify(ee))))
              else
                error "almost uniform but not quite?", e
              end if;
            else
              Bind(Lebesgue, var = rng, rest)
            end if;
          end if;
        elif type(e, 'specfunc'(anything, {'sum','Sum'})) then
            error "sums not handled yet"
        elif type(e, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
            error "constants should have been pushed inside already", e
        end if;
      end if;
    end if;
  end proc;

  # simp mostly pushes things in.
  simp := proc(e)
    local a, b, d;
    if type(e, `+`) then
      map(simp, e)
    elif type(e, `*`) then
      a, b := selectremove(type, e, t_binds);
      # now casesplit on what a is
      if a=1 then  # no binders
        a, b := selectremove(type, e, t_pw);
        if a=1 then # and no piecewise either
          d := expand(b); # probably need to write something less brutal
          if b=d then # nothing happened
            simplify(b)
          else # this might be better
            simp(d)
          end if
        elif type(a, `*`) then
          error "do not know how to multiply 2 pw:", a
        elif type(a, t_pw) then
          into_pw(b, a)
        else
          error "something weird happened:", a, " was supposed to be pw"
        end if
      elif type(a, `*`) then
        error "product of 2 binders?!?", a
      else
        subsop(1=myprod(simp(b),simp(op(1,a))), a)
      end if
    elif type(e, t_binds) then
      subsop(1=simp(op(1,e)), e)
    # need to go into pw even if there is no factor to push in
    elif type(e, t_pw) then
      into_pw(1, e)
    else
      simplify(e)
    end if;
  end;

  into_pw := proc(fact, pw)
    local n, f;

    n := nops(pw);
    f := proc(j)
      if j=n then # last one is special, always a value
        simp(myprod(fact, simp(op(j, pw))))
      elif type(j,'odd') then # a condition
        op(j, pw)
      else # j even
        simp(myprod(fact , simp(op(j, pw))))
      end if;
    end proc;
    piecewise(seq(f(i),i=1..n))
  end proc;

  # myprod takes care of pushing a product inside a `+`
  myprod := proc(a, b)
    if type(b,`+`) then
      map2(myprod, a, b)
    else
      a*b
    end if;
  end proc;

  gs_counter := 0;
  gensym := proc(x::name) gs_counter := gs_counter + 1; x || gs_counter; end proc;

  do_pw := proc(l, ctx)
    local len;
    len := nops(l);
    if len = 0 then 0
    elif len = 1 then ToAST(l[1], ctx)
    else # l>=2. Note how conditions go through straight
      If(l[1], ToAST(l[2], ctx), thisproc(l[3..-1], ctx))
    end if;
  end;
end;

# this has to be global!
unsafeProb := proc(v)
  if type(v,'realcons') and signum(0, v, 1) = 1 then v else 'unsafeProb'(v) end if;
end proc;

# will get called on expressions containing 'unsafeProb'
`simplify/unsafeProb` := proc(x) local sub, f;
  sub := indets(x, 'specfunc'(anything, unsafeProb));
  f := proc(a) local b;
    b := op(1,a);
    if type(b, 'exp'(anything)) then exp_(op(1, b)) else a end if;
  end proc;
  subs(map(y -> y = f(y), sub), x)
end proc;

# works, but could be made more robust
`evalapply/if_` := proc(f, t) if_(op(1,f), op(2,f)(t[1]), op(3,f)(t[1])) end;

# SLO = Simplify Linear Operator.
#
#  This assumes that the input is the output of Language.Hakaru.Syntax.tester
# No checking is done that this is actually the case.
#
# SLO : simplifier
# AST : takes simplified form and transform to AST
#

SLO := module ()
  export ModuleApply, AST, simp, c; # very important: this c is "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw;

  t_binds := 'specfunc(anything, {int, Int, sum, Sum})';
  t_pw := 'specfunc(anything, piecewise)';

  ModuleApply := proc(inp::anything)
    local e;
    try
      simp(value(eval(inp(c), 'if_'=piecewise)));
    catch "Wrong kind of parameters in piecewise":
      error "Bug in Hakaru -> Maple translation, piecewise used incorrectly.";
    end try;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  AST := proc(inp::anything)
    local cs;
    cs := indets(inp, 'specfunc'(anything,c));
    # deal with trivial input first
    if inp=0 then
        0
    # then deal with 'bad' input
    elif nops(cs) = 0 then
      error "the constant", inp, " is not a measure."
    elif type(inp, `+`) then
      map(AST, SUM(op(inp)))
    else
      ToAST(inp, []);
    end if;
  end proc;

  # recursive function which does the main translation
  ToAST := proc(e, ctx)
    local a0, a1, var, vars, rng, ee, cof, d, ld, weight, binders,
      v, subst, ivars, ff, newvar, rest;
    if type(e, specfunc(name, c)) then
        return Return(op(e))
    # we might have recursively encountered a hidden 0
    elif (e = 0) then
       return 0
    # we might have done something odd, and there is no x anymore (and not 0)
    elif type(e, 'numeric') then
      error "the constant", e, "is not a measure"
    # invariant: we depend on c
    else
      binders := indets(e, t_binds);
      vars := indets(e, specfunc(anything, c));
      subst := map(x-> x = op(0,x)[op(x)], vars);
      ivars := map2(op, 2, subst);
      if binders = {} then
        # this is a 'raw' measure, with no integrals
        ee := subs(subst, e);
        if type(ee, 'polynom'(anything,ivars)) then
          ee := collect(ee, ivars, simplify);
          d := degree(ee, ivars);
          ld := ldegree(ee, ivars);
          cof := [coeffs(ee, ivars, 'v')]; # cof is a list, v expseq
          if (d = 1) and (ld = 1) then
            # WM = Weight-Measure pair
            ff := (x,y) -> WM(simplify(x), Return(op(y)));
            Superpose(op(zip(ff, cof, [v])));
            # `if`(cof=1, rest, Bind_(Factor(simplify(cof)), rest))
          else
            if (ld = 0) then
              error "non-zero constant encountered as a measure", ee
            else
              error "polynomial in c:", ee
            end if;
          end if;
        elif type(ee, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
          error "no binders, but still not a polynomial?", ee
        end if;
      else
        if type(e, 'specfunc'(anything, {'int','Int'})) then
          var, rng := op(op(2,e));
          ee := op(1,e);
          weight := simplify(op(2,rng)-op(1,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, [op(2,e), op(ctx)]);
            # should recognize densities here
            Bind(Lebesgue, var = rng, rest)
          else
            rest := ToAST(weight*ee, [op(2,e), op(ctx)]);
            # process the rest, and then recognize
            # recognize 'raw' uniform
            if type(rest, specfunc(identical(var), 'Return')) then
              Uniform(op(rng));
            elif type(rest, 'Superpose'('WM'(anything, anything))) then
              # finite range.
              weight := simplify(op([1,1], rest));
              ee := op([1,2], rest);
              if ctx=[] and type(ee, Return(anything)) then
                Bind(Uniform(op(1, rng), op(2, rng)), var,
                    Superpose(WM(weight, simplify(ee))))
              else
                error "almost uniform but not quite?", e
              end if;
            else
              Bind(Lebesgue, var = rng, rest)
            end if;
          end if;
        elif type(e, 'specfunc'(anything, {'sum','Sum'})) then
            error "sums not handled yet"
        elif type(e, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx);
        else
            error "constants should have been pushed inside already", e
        end if;
      end if;
    end if;
  end proc;

  # simp mostly pushes things in.
  simp := proc(e)
    local a, b, d;
    if type(e, `+`) then
      map(simp, e)
    elif type(e, `*`) then
      a, b := selectremove(type, e, t_binds);
      # now casesplit on what a is
      if a=1 then  # no binders
        a, b := selectremove(type, e, t_pw);
        if a=1 then # and no piecewise either
          d := expand(b); # probably need to write something less brutal
          if b=d then # nothing happened
            simplify(b)
          else # this might be better
            simp(d)
          end if
        elif type(a, `*`) then
          error "do not know how to multiply 2 pw:", a
        elif type(a, t_pw) then
          into_pw(b, a)
        else
          error "something weird happened:", a, " was supposed to be pw"
        end if
      elif type(a, `*`) then
        error "product of 2 binders?!?", a
      else
        subsop(1=myprod(simp(b),simp(op(1,a))), a)
      end if
    elif type(e, t_binds) then
      subsop(1=simp(op(1,e)), e)
    # need to go into pw even if there is no factor to push in
    elif type(e, t_pw) then
      into_pw(1, e)
    else
      simplify(e)
    end if;
  end;

  into_pw := proc(fact, pw)
    local n, f;

    n := nops(pw);
    f := proc(j)
      if j=n then # last one is special, always a value
        simp(myprod(fact, simp(op(j, pw))))
      elif type(j,'odd') then # a condition
        op(j, pw)
      else # j even
        simp(myprod(fact , simp(op(j, pw))))
      end if;
    end proc;
    piecewise(seq(f(i),i=1..n))
  end proc;

  # myprod takes care of pushing a product inside a `+`
  myprod := proc(a, b)
    if type(b,`+`) then
      map2(myprod, a, b)
    else
      a*b
    end if;
  end proc;

  gs_counter := 0;
  gensym := proc(x::name) gs_counter := gs_counter + 1; x || gs_counter; end proc;

  do_pw := proc(l, ctx)
    local len;
    len := nops(l);
    if len = 0 then 0
    elif len = 1 then ToAST(l[1], ctx)
    else # l>=2. Note how conditions go through straight
      If(l[1], ToAST(l[2], ctx), thisproc(l[3..-1], ctx))
    end if;
  end;
end;

# this has to be global!
unsafeProb := proc(v)
  if type(v,'realcons') and signum(0, v, 1) = 1 then v else 'unsafeProb'(v) end if;
end proc;

# will get called on expressions containing 'unsafeProb'
`simplify/unsafeProb` := proc(x) local sub, f;
  sub := indets(x, 'specfunc'(anything, unsafeProb));
  f := proc(a) local b;
    b := op(1,a);
    if type(b, 'exp'(anything)) then exp_(op(1, b)) else a end if;
  end proc;
  subs(map(y -> y = f(y), sub), x)
end proc;

# works, but could be made more robust
`evalapply/if_` := proc(f, t) if_(op(1,f), op(2,f)(t[1]), op(3,f)(t[1])) end;


now get_alpha should mimic exactly the code in polyselect.c

git-svn-id: 189946a10c5fc96e9dd03ba7cba917cd4c3d09f4@1274 de4796e2-0b1e-0410-91b4-86bc23549317

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mancoast/cado-nfs.git/'


Maple script to compute alpha(F)

Maple script to compute alpha(F)

git-svn-id: 189946a10c5fc96e9dd03ba7cba917cd4c3d09f4@132 de4796e2-0b1e-0410-91b4-86bc23549317


not tests, but still valuable.

not tests, but still valuable.

#
#  Currently, these are not 'tests' in the usual sense, in that they do
# not have correct answers encoded.  They are just meant to all be
# runnable (and are part of the stuff serving as input for the array
# simplification paper we're writing).

kernelopts(assertlevel=2): # be strict on all assertions while testing
kernelopts(opaquemodules=false): # allow testing of internal routines
if not (NewSLO :: `module`) then
  WARNING("loading NewSLO failed");
  `quit`(3);
end if;

with(Hakaru):
with(NewSLO):
with(Loop):

kb := KB:-assert(n :: nonnegint, KB:-empty):
i, kb := KB:-genType(i, HInt(closed_bounds(1..n)), kb):

t1 := Product(idx(x,j),j=1..n):
r1 := unproduct(t1, x, i=1..n, [], `*`, kb, kb);

t2 := 2:
r2 := unproduct(t2, x, i=1..n, [], `*`, kb, kb);

t3 := 2^n:
r3 := unproduct(t3, x, i=1..n, [], `*`, kb, kb);

t4 := Product(2*idx(x,j),j=1..n);
r4 := unproduct(t4, x, i=1..n, [], `*`, kb, kb);

t5 := Product(2+idx(x,j),j=1..n);
r5 := unproduct(t5, x, i=1..n, [], `*`, kb, kb);

t6 := Product(f(idx(x,j)),j=1..n);
r6 := unproduct(t6, x, i=1..n, [], `*`, kb, kb);

t7 := exp(Sum(g(idx(x,k)),k=1..n));
r7 := unproduct(t7, x, i=1..n, [], `*`, kb, kb);

t8 := t6*t7;
r8 := unproduct(t8, x, i=1..n, [], `*`, kb, kb);

t9 := Product(f(idx(x,j+1)),j=0..n-1);
r9 := unproduct(t9, x, i=1..n, [], `*`, kb, kb);

t10 := Product(f(idx(x,j)),j=1..n-1);
r10 := unproduct(t10, x, i=1..n, [], `*`, kb, kb);

# oops, this ones doesn't !!  Going under (above) is
# ok, but over does not.  Neither of the following:
# t10a := Product(f(idx(x,j)),j=1..n+1);
# r10a := unproduct(t10, x, i=1..n, [], `*`, kb, kb);
# t10b := Product(f(idx(x,j)),j=0..n);
# r10b := unproduct(t10, x, i=1..n, [], `*`, kb, kb);

t11 := Product(exp(Sum(f(idx(x,j))+g(idx(x,k)),k=1..j)),j=1..n):
r11 := unproduct(t11, x, i=1..n, [], `*`, kb, kb);

t12 := Product(exp(Sum(f(idx(x,j),j,k)+g(idx(x,k),j,k),k=1..j)),j=1..n):
r12 := unproduct(t12, x, i=1..n, [], `*`, kb, kb);

# this is sort-of buggy as well.
t13 := Product(f(idx(x,5))*g(idx(x,7))*h(j),j=1..n):
r13 := unproduct(t13, x, i=1..n, [], `*`, kb, kb);

# Bug!
# t14 := Product(idx(x,2*j),j=1..n/2):
# r14 := unproduct(t14, x, i=1..n, [], `*`, kb, kb);

t15 := Product(f(idx(x,j),j)*g(idx(x,n+1-j),j)*h(j),j=1..n):
r15 := unproduct(t15, x, i=1..n, [], `*`, kb, kb);

t16 := Product(piecewise(a<b,f(idx(x,j),j),g(idx(x,n+1-j),j)),j=1..n):
r16 := unproduct(t16, x, i=1..n, [], `*`, kb, kb);

t17 := Product(5^idx(x,j)*f(idx(x,j))*g(idx(x,n+1-j)),j=1..n):
r17 := unproduct(t17, x, i=1..n, [], `*`, kb, kb);

error: pathspec 'maple/unprod_tests.mpl' did not match any file(s) known to git


retrieve lb-maple.mpl file for Makefile purpose

LinBox:= module()
        description "Maple interface for LinBox library version 1.0 by Pascal Giorgi (LinBox project - www.linal.org)";
	local lbpath, lbInit, lbEnd, lbStart, lbStop:
	export lbDeterminant, lbRank, lbMinpoly, lbCharpoly, lbSolve, Dev:
	option package, load=lbInit, unload=lbEnd:

	lbpathvalue

	#############################################################
	# Function to initialize LinBox driver and LinBox interface #
	#############################################################
	lbStart  := define_external('lbStart' , MAPLE, LIB=lbpath);
	lbStop   := define_external('lbStop'  , MAPLE, LIB=lbpath);

	lbInit := proc() printf("  LinBox/Maple Interface Package beta version 1.0 \n  by Pascal Giorgi (pascal.giorgi@univ-perp.fr)\n");
			 lbStart();
		  end proc;
	lbEnd  := proc() end proc;#lbStop();end proc;

#####################################################################
#############  Definition of the low level submodule ################
#####################################################################

	Dev:= module()
	      description "low level interface for direct LinBox object manipulation";
	        local lbInit, lbEnd;
		export lbDataInfo,lbStart, lbStop,
	        lbElement, lbDomain, lbBlackbox, lbVector,
	      	lbSetPrimeField, lbSetRationalField, lbSetIntegerRing,
		lbCopyBlackbox, lbBlackboxDimension, lbSetBlackboxAtRandom, lbRebindBlackbox, lbWriteBlackbox, lbSetBlackbox,
		lbCopyVector, lbVectorDimension, lbSetVectorAtRandom, lbRebindVector, lbWriteVector, lbSetVector,
		lbWritePolynomial,
		lbDeterminant, lbRank, lbMinpoly, lbCharpoly, lbSolve,
		lbConvertElement, lbConvertBlackbox, lbConvertVector, lbConvertPolynomial,
		lbCopy, lbWrite, lbDimension, lbRebind, lbRandom:
		option package, load=lbInit, unload=lbEnd:

        	#############################################################
		# Function to initialize LinBox driver and LinBox interface #
		#############################################################
		lbStart  := define_external('lbStart' , MAPLE, LIB=lbpath);
		lbStop   := define_external('lbStop'  , MAPLE, LIB=lbpath);

		######################################################
		# Function to get information from the LinBox driver #
		######################################################
		lbDataInfo := define_external('lbDataInfo', MAPLE, LIB=lbpath);

		########################################
		# Function to set the LinBox data type #
		########################################
		lbSetPrimeField    := define_external('lbSetPrimeField'     , MAPLE, LIB=lbpath);
		lbSetRationalField := define_external('lbSetRationalField'  , MAPLE, LIB=lbpath);
		lbSetIntegerRing   := define_external('lbSetIntegerRing'    , MAPLE, LIB=lbpath);
		lbSetBlackbox      := define_external('lbSetBlackbox'       , MAPLE, LIB=lbpath);
		lbSetVector        := define_external('lbSetVector'         , MAPLE, LIB=lbpath);

		###############################################
		# Function to create LinBox object from Maple #
		###############################################
		lbElement   := define_external('lbCreateElement'   , MAPLE, LIB=lbpath);
		lbDomain    := define_external('lbCreateDomain'    , MAPLE, LIB=lbpath);
		lbBlackbox  := define_external('lbCreateBlackbox'  , MAPLE, LIB=lbpath);
		lbVector    := define_external('lbCreateVector'    , MAPLE, LIB=lbpath);

		#######################################
		# Function for LinBox blackbox object #
		#######################################
		lbCopyBlackbox        := define_external('lbCopyBlackbox'         , MAPLE, LIB=lbpath);
		lbBlackboxDimension   := define_external('lbGetBlackboxDimension' , MAPLE, LIB=lbpath);
		lbSetBlackboxAtRandom := define_external('lbSetBlackboxAtRandom'  , MAPLE, LIB=lbpath);
		lbRebindBlackbox      := define_external('lbRebindBlackbox'       , MAPLE, LIB=lbpath);
		lbWriteBlackbox       := define_external('lbWriteBlackbox'        , MAPLE, LIB=lbpath);

		#####################################
		# Function for LinBox vector object #
		#####################################
		lbCopyVector        := define_external('lbCopyVector'         , MAPLE, LIB=lbpath);
		lbVectorDimension   := define_external('lbGetVectorDimension' , MAPLE, LIB=lbpath);
		lbSetVectorAtRandom := define_external('lbSetVectorAtRandom'  , MAPLE, LIB=lbpath);
		lbRebindVector      := define_external('lbRebindVector'       , MAPLE, LIB=lbpath);
		lbWriteVector       := define_external('lbWriteVector'        , MAPLE, LIB=lbpath);

		#########################################
		# Function for LinBox polynomial object #
		#########################################
		lbWritePolynomial   := define_external('lbWritePolynomial'    , MAPLE, LIB=lbpath);

		##############################
		# Available LinBox solutions #
		##############################
		lbDeterminant := define_external('lbDeterminant'  , MAPLE, LIB=lbpath);
		lbRank        := define_external('lbRank'         , MAPLE, LIB=lbpath);
		lbMinpoly     := define_external('lbMinpoly'      , MAPLE, LIB=lbpath);
		lbCharpoly    := define_external('lbCharpoly'     , MAPLE, LIB=lbpath);
		lbSolve       := define_external('lbSolve'        , MAPLE, LIB=lbpath);

		##################################################
		# Conversion from LinBox object to Maple Objects #
		##################################################
		lbConvertElement    := define_external('lbConvertElement'    , MAPLE, LIB=lbpath);
		lbConvertBlackbox   := define_external('lbConvertBlackbox'   , MAPLE, LIB=lbpath);
		lbConvertVector     := define_external('lbConvertVector'     , MAPLE, LIB=lbpath);
		lbConvertPolynomial := define_external('lbConvertPolynomial' , MAPLE, LIB=lbpath);

		####################
		# Higher level API #
		####################
		lbCopy      := define_external('lbCopy'       , MAPLE, LIB=lbpath);
		lbWrite     := define_external('lbWrite'      , MAPLE, LIB=lbpath);
		lbDimension := define_external('lbDimension'  , MAPLE, LIB=lbpath);
		lbRebind    := define_external('lbRebind'     , MAPLE, LIB=lbpath);
		lbRandom    := define_external('lbRandom'     , MAPLE, LIB=lbpath);

	end module:

##############################################################
#############  end of the low level submodule ################
##############################################################

###################################################################
#############  definition of the high level module ################
###################################################################

		################################################
		# Determinant computation from a Maple Matrix  #
		################################################
		lbDeterminant := proc()
		      local d, A, det, t;
		      if (type(args[1], integer)) then
		      	 if (type(args[2], Matrix)) then
			    t := time();
			    A  := Dev:-lbBlackbox(args[1], args[2]);
			    t:= time()-t;
			 else
			    error("invalid argument",args[2], "must be a Matrix");
			 end if;
		      elif (type(args[1], Matrix)) then
			    t := time();
			    A := Dev:-lbBlackbox(args[1]);
			    t:= time()-t;
		      else
			    error("invalid argument",args[1], "must be a Matrix");
		      end if;
		      d   := Dev:-lbDeterminant(A);
		      det := Dev:-lbConvertElement(d);
		      if (printlevel>1) then
			      print("conversion time:",t);
		      end if;
		      return det;
		end;

		########################################
		# Rank computation from a Maple matrix #
		########################################
		lbRank := proc()
		      local A,t;
		      if (type(args[1], integer)) then
		      	 if (type(args[2], Matrix)) then
			    t := time();
			    A:=Dev:-lbBlackbox(args[1], args[2]);
			    t:=time()-t;
			 else
			    error("invalid argument",args[2], "must be a Matrix");
			 end if;
		      elif (type(args[1], Matrix)) then
			   t := time();
			   A := Dev:-lbBlackbox(args[1]);
			   t:=time()-t;
		      else
			    error("invalid argument",args[1], "must be a Matrix");
		      end if;
		      if (printlevel>1) then
			      print("conversion time:",t);
		      end if;
		      return Dev:-lbRank(A);
		end;

		######################################################
		# Minimal polynomial computation from a Maple matrix #
		######################################################
		lbMinpoly := proc()
		      local A, p, symb,t;
		      if (type(args[1], integer)) then
		      	 if (type(args[2], Matrix)) then
			    if (type(args[3], name)) then
			        t:=time();
			        A:=Dev:-lbBlackbox(args[1], args[2]);
				t:=time()-t;
				symb:=args[3];
			    else
				 error("invalid argument",args[3], "must be a name");
		            end if;
			 else
			     error("invalid argument",args[2], "must be a Matrix");
			 end if;
		      elif (type(args[1], Matrix)) then
			   if (type(args[2], name)) then
			      t:=time();
			      A := Dev:-lbBlackbox(args[1]);
			      t:=time()-t;
			      symb:=args[2];
		           else
			      error("invalid argument",args[2], "must be a name");
			   end if
		      else
			error("invalid argument",args[1], "must be a Matrix");
		      end if;
		      p:= Dev:-lbMinpoly(A);
		      if (printlevel>1) then
			      print("conversion time:",t);
		      end if;
		      return Dev:-lbConvertPolynomial(p,symb);
		end;

		#############################################################
		# Characteristic polynomial computation from a Maple matrix #
		#############################################################
		lbCharpoly := proc()
		      local A, p, symb,t;
		      if (type(args[1], integer)) then
		      	 if (type(args[2], Matrix)) then
			    if (type(args[3], name)) then
			        t:=time();
			        A:=Dev:-lbBlackbox(args[1], args[2]);
				t:=time()-t;
				symb:=args[3];
			    else
				 error("invalid argument",args[3], "must be a name");
		            end if;
			 else
			     error("invalid argument",args[2], "must be a Matrix");
			 end if;
		      elif (type(args[1], Matrix)) then
			   if (type(args[2], name)) then
			         t:=time();
				 A := Dev:-lbBlackbox(args[1]);
  			 	 t:=time()-t;
			      symb:=args[2];
		           else
			      error("invalid argument",args[2], "must be a name");
			   end if
		      else
			error("invalid argument",args[1], "must be a Matrix");
		      end if;
		      p:= Dev:-lbCharpoly(A);
		      if (printlevel>1) then
			      print("conversion time:",t);
		      end if;
		      return Dev:-lbConvertPolynomial(p,symb);
		end;

		#############################################################
		# Linear system solving from Maple matrix and Maple Vector  #
		#############################################################
		lbSolve := proc()
		      local A,b,x,y,t;
		      if (type(args[1], integer)) then
			 if (type(args[2], Matrix)) then
			    if (type(args[3], Vector)) then
			        t:=time();
			        A:=Dev:-lbBlackbox(args[1], args[2]);
				b:=Dev:-lbVector(args[1], args[3]);
				t:=time()-t;
			    else
				error("invalid argument",args[3], "must be a Vector");
			    fi;
			 else
			    error("invalid argument",args[2], "must be a Matrix");
			 fi;
		      elif (type(args[1], Matrix)) then
	      		   if (type(args[2], Vector)) then
			        t:=time();
				A:=Dev:-lbBlackbox(args[1]);
				b:=Dev:-lbVector(args[2]);
				t:=time()-t;
			   else
				error("invalid argument",args[2], "must be a Vector");
			   fi;
		      else
			   error("invalid argument",args[1], "must be a Matrix");
		      fi;
		      x:= Dev:-lbSolve(A,b);
		      y:=Dev:-lbConvertVector(x);
		      if (printlevel>1) then
			      print("conversion time:",t);
		      end if;
		      return y;
		end;
end module:

save_linbox:=proc(repo)
	global savelibname,libname:
	if (FileTools[Exists](cat(repo,"/maple.lib"))) then
		fremove(cat(repo,"/maple.lib"));
		fremove(cat(repo,"/maple.ind"));
#		fremove(cat(repo,"/maple.hdb"));
		rmdir(repo);
	fi:
	if (not(FileTools[Exists](repo))) then mkdir(repo);fi:
	march( 'create',repo, 1000 ):
	savelibname := repo: libname := savelibname, libname:
	savelib('LinBox'):
end:

save_linbox("LinBoxMaple");

error: pathspec 'linbox/interfaces/maple/lb-maple.mpl' did not match any file(s) known to git


gets exp to go through, but this is not quite right as there will eventually be the need for 2 exp.  But works for now, gets one more case through.

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, ufunc, bfunc, lbrack, rbrack, seqp;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(expr)
      b:-clear();
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("%d",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() p(n); b:-append(" / "); p(d); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  parens(proc() p(a1); b:-append(" ^ "); p(a2) end);
end;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Factor"] := ufunc("factor");
bi["UnsafeProb"] := ufunc("unsafeProb");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;

bi["Bind"] := proc(meas, rng, rest)
  p(meas);
  b:-append(" `bind` \\");
  if type(rng, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,rng));
    b:-append(" -> ");
  else
    error "variable range in `bind` not yet handled";
  end if;
  p(rest);
end;

bi["Superpose"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# this is a hack, and will break once we go nested.
bi["exp"] := ufunc("exp_");

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then error "empty sequence passed where non-empty expected";
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;
end module:

# Haskell -- this is a "to Haskell" 'printing' module.
#
# A single export
# This prints our AST representation of linear operators

Haskell := module ()
  export ModuleApply;
  local b, p, d, bi,
      parens, resolve, sp, ufunc, bfunc, lbrack, rbrack, seqp;
  uses StringTools;

  # this is to make things more efficient.  Note that it makes
  # things non-reentrant between Expr and p.
  b := StringBuffer();

  # for the long-term, go right to the 'right' way to do this,
  # which is to use the Inert form.  The flip-side of doing things
  # the right way would involve a proper pretty-printer, but that
  # can be added later easily enough.
  ModuleApply := proc(expr)
      b:-clear();
      p(ToInert(expr));
      b:-value();
  end;

  p := proc(e)
    if assigned(d[op(0,e)]) then
      d[op(0,e)](op(e))
    else
      error "Haskell: %1 not implemented yet (%2)", op(0,e), e
    end if;
  end;

# things get silly with too much indentation, so for this table, we cheat
d[_Inert_INTPOS] := proc(x) b:-appendf("%d",x) end;
d[_Inert_INTNEG] := proc(x) b:-appendf("%d",-x) end;
d[_Inert_RATIONAL] := proc(n,d)
  parens(proc() p(n); b:-append(" / "); p(d); end)
end;
d[_Inert_FUNCTION] := proc(f, s)
  local nm;
  nm := resolve(f);
  if assigned(bi[nm]) then
    bi[nm](op(s))
  else
    error "Haskell: cannot resolve function %1", f
  end if;
end proc;
# ignore a2 and subsequent things below
d[_Inert_ASSIGNEDNAME] := proc(a1, a2)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
d[_Inert_NAME] := proc(a1)
  if assigned(bi[a1]) then
    bi[a1]()
  else
    b:-append(a1);
  end if;
end proc;
# PROD is n-ary
d[_Inert_PROD] := proc()
  lparen(); seqp(" * ", [_passed]); rparen();
end;
d[_Inert_POWER] := proc(a1,a2)
  parens(proc() p(a1); b:-append(" ^ "); p(a2) end);
end;

# this is the table of known internal functions
bi["Bind_"] := proc(a1, a2) p(a1); b:-append(" `bind_` "); p(a2) end;
bi["Return"] := ufunc("dirac");
bi["Factor"] := ufunc("factor");
bi["UnsafeProb"] := ufunc("unsafeProb");
bi["Unit"] := proc() b:-append("unit") end;
bi["Uniform"] := bfunc("uniform ");
bi["Lebesgue"] := proc() b:-append("lebesgue") end;
bi["Pi"] := proc() b:-append("pi_") end;

bi["Bind"] := proc(meas, rng, rest)
  p(meas);
  b:-append(" `bind` \\");
  if type(rng, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,rng));
    b:-append(" -> ");
  else
    error "variable range in `bind` not yet handled";
  end if;
  p(rest);
end;

bi["Superpose"] := proc() b:-append("superpose"); sp();
  lbrack(); seqp(", ", [_passed]); rbrack();
end;

bi["WM"] := proc(w, m)
  b:-append("("); p(w); b:-append(","); p(m); b:-append(")");
end;

# utility routines:
# =================

# printing
  sp := proc() b:-append(" ") end;
  lbrack := proc() b:-append("[") end;
  rbrack := proc() b:-append("]") end;
  lparen := proc() b:-append("(") end;
  rparen := proc() b:-append(")") end;
  parens := proc(c) b:-append("("); c(); b:-append(")") end;
  ufunc := proc(f) proc(c) parens(proc() b:-append(f); sp(); p(c) end) end; end;
  bfunc := f -> ((x,y) -> parens(proc() b:-append(f); sp(); p(x); sp(); p(y); end));
  seqp := proc(s, l)
    if nops(l)=0 then error "empty sequence passed where non-empty expected";
    elif nops(l)=1 then p(l[1])
    else
      p(l[1]);
      b:-append(s);
      seqp(s, l[2..-1]);
    end if;
  end proc;

# resolve name
  resolve := proc(inrt)
    local s, nm;
    nm := eval(inrt, _Inert_ATTRIBUTE=NULL); # crude but effective
    if typematch(nm, specfunc('s'::'string', '_Inert_NAME')) then
      s
    elif type(nm, specfunc('string', '_Inert_ASSIGNEDNAME')) then
      op(1,nm)
    else
      error "cannot resolve an %1, namely %2", op(0,nm), nm;
    end if;
  end proc;
end module: