Simplify functions from ()

Simplify functions from ()

# 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: c is "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw,
    superpose, mkProb, getCtx, instantiate, lambda_wrap, fill_table,
    adjust_types, compute_domain, analyze_cond, flip_rr, isPos,
    MyHandler, getBinderForm, infer_type, join_type, join2type,
    simp_AST, simp_sup, simp_bind, simp_if, simp_WM, into_sup,
    comp, comp2, comp_algeb, comp_WM,
    mkRealDensity, recognize_density, density;

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

  ModuleApply := proc(spec::Typed(anything,anything))
    local expr, typ, glob, gsiz, ctx, r, inp, meastyp, res, gnumbering;
    expr := op(1, spec);
    typ := op(2, spec);
    glob, gnumbering, gsiz, meastyp := getCtx(typ, table(), table(), 0);
    r := Record('htyp' = typ, 'mtyp' = meastyp,
                'gctx' = glob, 'gnum' = gnumbering, 'gsize' = gsiz);
    inp := instantiate(expr, r, 0, typ);
    try
      NumericEventHandler(division_by_zero = MyHandler);
      res := HAST(simp(value(eval(inp(c), 'if_'=piecewise))), r);
    catch "Wrong kind of parameters in piecewise":
      error "Bug in Hakaru -> Maple translation, piecewise used incorrectly.";
    finally :
      NumericEventHandler(division_by_zero = default);
    end try;
    res;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  # environment variables plus indexing functions make tracking info easy!
  AST := proc(inp::HAST(anything, Context))
    local res, ctx, t, i, rng;

    ctx := op(2,inp);
    t := table(TopProp);

    # right at the start, put the global context in the 'path'.
    for i in [indices(ctx:-gctx, 'pairs')] do
      fill_table(t, lhs(i), rhs(i));
    end do;
    _EnvPathCond := eval(t);
    res := ToAST(op(inp));
    res := simp_AST(res);
    res := adjust_types(res, ctx:-mtyp, ctx);
    lambda_wrap(res, 0, ctx);
  end proc;

  # recursive function which does the main translation
  ToAST := proc(inp, ctx)
    local a0, a1, var, vars, rng, ee, cof, d, ld, weight, binders,
      v, subst, ivars, ff, newvar, rest, a, b, e, span;
    e := inp; # make e mutable
    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])));
          elif (ee=0) then # collect/simplify could have revealed this
            Superpose()
          elif (ld = 0) then
            error "non-zero constant encountered as a measure", ee
          else
            error "polynomial in c:", ee
          end if;
        elif type(ee, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx, BottomProp);
        elif type(ee, `+`) then
          superpose(map(ToAST, [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));
          span := RealRange(op(1,rng), op(2,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, ctx);
            if rng = -infinity..infinity then
              mkRealDensity(rest, var)
            else
              # recognize densities on partial range here
              Bind(Lebesgue, var = rng, rest)
            end if;
          else
            v := simplify(weight*ee) assuming var :: span;
            rest := ToAST(v, ctx);
            Bind(Uniform(op(rng)), var, rest);
          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, BottomProp);
        elif type(e, `+`) then
          superpose(map(ToAST, [op(e)], ctx));
        elif type(e, `*`) then
          # we have a binder in here somewhere
          a, b := selectremove(type, e, t_binds);
          # now casesplit on what a is
## from here
          if a=1 then  # no surface binders
            a, b := selectremove(type, e, t_pw);
            if a=1 then # and no piecewise either
              error "buried binder: ", b
            elif type(a, `*`) then
              error "do not know how to multiply 2 pw:", a
            elif type(a, t_pw) then
              Superpose('WM'(b, ToAST(a, ctx)))
            else
              error "something weird happened:", a, " was supposed to be pw"
            end if
          elif type(a, `*`) then
            error "product of 2 binders?!?", a
          else
            Superpose('WM'(b, ToAST(a, ctx)))
          end if
## to here
        else
            error "Not sure what to do with a ", e
        end if;
      end if;
    end if;
  end proc;

  # simp mostly recurses and simplifies as it goes
  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
        simp(b)*simp(a)
        # 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.
  # this assumes that the pw is univariate
  do_pw := proc(l, ctx, prop)
    local len, rel, prop_ctx, this, var;
    len := nops(l);
    if len = 0 then Superpose()
    elif len = 1 then ToAST(l[1], ctx)
    else # len>2.
      var, rel := analyze_cond(l[1]);
      prop_ctx := OrProp(prop, rel);
      if len=2 then
        if prop_ctx='real' then return ToAST(l[2], ctx) end if;
      end if;
      If(l[1], ToAST(l[2], ctx), thisproc(l[3..-1], ctx, prop_ctx))
    end if;
  end;

  superpose := proc(l)
    local t, i, j, idx;
    t := table('sparse');
    for i in l do
      if type(i, specfunc(anything, Superpose)) then
        for j in [op(i)] do
          idx := op(2,j);
          # yay for indexing functions!
          t[idx] := t[idx] + op(1,j);
        end do;
      else
        error "still don't know how to superpose ", i;
      end if;
    end do;
    Superpose(seq('WM'(t[op(i)], op(i)), i = [indices(t)]));
  end proc;

  mkProb := proc(w, ctx)
    local typ, i, ww, pos, rest;
    if type(w, `*`) then
      map(mkProb, w, ctx)
    elif type(w, 'exp'(anything)) then
      exp_(op(1,w));
    elif type(w, 'erf'(anything)) then
      erf_(mkProb(op(1,w)));
    elif type(w, 'ln'(anything)) then
      error "mkProb ln", w;
    elif type(w, anything^fraction) then
      typ := infer_type(op(1,w), ctx);
      if typ = 'Prob' then w else mkProb(op(1,w), ctx) ^ op(2,w) end if;
    elif type(w, 'unsafeProb'(anything)) then
      error "there should be no unsafeProb in", w
    else
      typ := infer_type(w, ctx);
      if typ = 'Prob' then
        w
      elif typ = 'Real' then
        # we are going to need to cast.  Is it safe?
        if not isPos(w) then WARNING("cannot insure it will not crash") end if;
        unsafeProb(w);
      else
        error "how do I make a Prob from ", w, "in", eval(_EnvPathCond)
      end if;
    end if;
  end proc;

  # use assumptions to figure out if we are actually positive, even
  # when the types say otherwise
  isPos := proc(w)
    local prop, res;

    prop := map(x -> op(1,x) :: op(2, x), [indices(_EnvPathCond, 'pairs')]);
    res := signum(0, w, 1) assuming op(prop);
    evalb(res = 1);
  end proc;

  fill_table := proc(t, nm, typ)
      if nm::name then
        if typ = 'Real' then
          t[nm] := RealRange(-infinity, infinity)
        elif typ = 'Prob' then
          t[nm] := RealRange(0, infinity)
        elif typ = 'Bool' then
          t[nm] := boolean
        elif typ = 'Unit' then
          t[nm] := Unit # ???
        else
          error "Real/Prob/Bool/Unit are the only base types:", typ;
        end if;
      elif typ :: 'Pair'(anything, anything) then
        fill_table(t, op(1, nm), op(1, typ));
        fill_table(t, op(2, nm), op(2, typ));
      elif typ :: 'Measure'(anything) then
        error "cannot handle first-class measure types yet"
      elif typ :: 'Arrow'(anything,anything) then
        error "cannot handle first-class -> types yet"
      else
        error "I don't know type", typ;
      end if;
  end proc;

  getBinderForm := proc(t)
    local left, right;
    if t = 'Real' then gensym('rr')
    elif t = 'Prob' then gensym('pp')
    elif t :: Pair(anything, anything) then
      left := getBinderForm(op(1,t));
      right := getBinderForm(op(2,t));
      Pair(left, right);
    elif t = 'Bool' then gensym('bb')
    elif t = 'Unit' then Unit
    else
      error "Tring to forma a name from a", t
    end if;
  end proc;

  getCtx := proc(typ, glob, globNum, ctr)
    local nm, t;
    if type(typ, 'Arrow'(anything, anything)) then
      t := op(1,typ);
      # 'nm' is a name-filled type structure, not necessarily a name
      nm := getBinderForm(t);
      globNum[ctr] := nm;
      glob[nm] := t;
      getCtx(op(2,typ), glob, globNum, ctr+1)
    elif type(typ, 'Measure'(anything)) then
      glob, globNum, ctr, typ
    else
      error "must have either Measure or Arrow, got", typ;
    end if;
  end proc;

  instantiate := proc(e, ctx, ctr, typ)
    local nm;
    if ctr = ctx:-gsize then
      e
    else
      nm := ctx:-gnum[ctr];
      instantiate(e(nm), ctx, ctr + 1, op(2,typ))
    end if;
  end proc;

  lambda_wrap := proc(expr, cnt, ctx)
    local var, sub;
    if cnt = ctx:-gsize then
      expr
    else
      var := ctx:-gnum[cnt];
      Lambda(var, lambda_wrap(expr, cnt+1, ctx));
    end if;
  end proc;

  infer_type := proc(e, ctx)
    local typ, l, res;
    if type(e, boolean) then
      'Bool'
    elif e = 'Pi' then Prob
    elif e = 'Unit' then Unit
    elif type(e, boolean) then
      'Bool'
    elif type(e, anything^integer) then
      infer_type(op(1,e), ctx);
    elif type(e, 'exp'(anything)) then
      typ := infer_type(op(1,e), ctx); # need to make sure it is inferable
      'Real' # someone else will make sure to cast this correctly
    elif type(e, anything^fraction) then
      typ := infer_type(op(1,e), ctx); # need to make sure it is inferable
      typ; # if it is <0, weird things will happen
      # someone else will make sure to cast this correctly
    elif type(e, 'ln'(anything)) then
      typ := infer_type(op(1,e), ctx); # need to make sure it is inferable
      'Real'
    elif type(e, 'symbol') then
      # if we have a type, use it
      if assigned(ctx:-gctx[e]) then return(ctx:-gctx[e]); end if;

      # otherwise, really do infer it
      typ := _EnvPathCond[e];
      if typ :: {'RealRange'(anything, anything),
                 identical(real), identical(TopProp)} then
        'Real'
      else
        error "Impossible: an untyped free variable", e, "in global context",
          eval(ctx:-gctx), "and local context", eval(_EnvPathCond)
      end if;
    elif type(e, 'realcons') and signum(0,e,1) = 1 then
      'Prob'
    elif type(e, 'realcons') then
      'Real'
    elif type(e, 'Pair'(anything, anything)) then
      map(infer_type, e, ctx);
    elif type(e, {`+`, `*`}) then
      l := map(infer_type, [op(e)], ctx);
      join_type(op(l));
    elif type(e, specfunc(anything, 'piecewise')) then
      typ := NULL;
      for l from 1 to nops(e) do
        if l::odd and l<nops(e) then
          next;
        else # last or e:: evan
          typ := typ, infer_type(op(l, e), ctx)
        end if;
      end do;
      join_type(typ);
    elif type(e, {specfunc(anything, 'NormalD')}) then
      Measure(Real)
    elif type(e, specfunc(anything, 'Superpose')) then
      res := map(infer_type, {op(e)}, ctx);
      if nops(res) = 1 then
        res[1]
      else
        error "superpose with multiple types", e
      end if;
    elif type(e, specfunc(anything, 'WM')) then
      infer_type(op(2, e), ctx)
    elif type(e, specfunc(anything, 'Uniform')) then
      Measure(Real)
    else
      error "how do I infer a type from", e;
    end if;
  end proc;

  join2type := proc(a,b)
    if a = b then a
    elif a = 'Real' or b = 'Real' then 'Real'
    else error "join2type of", a, b
    end if;
  end proc;

  # could foldl, but this will work too
  join_type := proc()
    if _npassed < 2 then error "cannot happen"
    elif _npassed = 2 then
      join2type(_passed[1], _passed[2])
    else
      join_type(join2type(_passed[1], _passed[2]), _passed[3..-1])
    end if;
  end proc;
  ####
  # Fix-up the types using contextual information.
# TODO: need to add unsafeProb around the Prob-typed input variables,
# and then fix-up things like log.
#
# The right way to do this is really to do
# - full 'type' inference of e
# - full 'range-of-value' inference of e
  adjust_types := proc(e, typ, ctx)
    local ee, dom, opc, res, var, left, right, inf_typ, tab, typ2,
          tab_left, tab_right;
    if type(e, specfunc(anything, 'Superpose')) then
      map(thisproc, e, typ, ctx)
    elif type(e, 'WM'(anything, anything)) then
      'WM'(mkProb(op(1,e), ctx), thisproc(op(2,e), typ, ctx));
    elif type(e, 'Return'(anything)) and type(typ, 'Measure'(anything)) then
      typ2 := op(1, typ);
      inf_typ := infer_type(op(1,e), ctx);
      if typ2 = Unit and op(1,e) = Unit then
        e
      elif typ2 = Prob then
        ee := op(1,e);
        res := mkProb(ee, ctx);
        'Return'(res);
      elif typ2 = Real and type(op(1,e), 'ln'(anything)) then
        ee := op(1,e);
        inf_typ := infer_type(op(1, ee), ctx);
        if inf_typ = 'Prob' then
          'Return'(ln_(op(1,ee)))
        else
          'Return'(ee);
        end if;
      # hmm, are things polymorphic enough that this is ok?
      # might need 'fromProb' to be inserted?
      elif typ2 = Real and member(inf_typ, {'Real', 'Prob'}) then
        'Return'(op(1,e))
      elif typ2 :: Pair(anything, anything) and
           op(1,e) :: Pair(anything, anything) then
        left  := adjust_types('Return'(op([1,1],e)), Measure(op(1,typ2)), ctx);
        right := adjust_types('Return'(op([1,2],e)), Measure(op(2,typ2)), ctx);
        'Return'(Pair(op(1,left), op(1,right)));
      elif typ2 = Bool and member(op(1,e), {true,false}) then
        e
      else
         error "adjust_types Type:", typ, inf_typ, e;
      end if;
    elif type(e, 'Bind'(anything, name, anything)) then
      dom := compute_domain(op(1,e));
      var := op(2,e);
      inf_typ := infer_type(op(1,e), ctx);
      # indexing function at work: if unassigned, get TopProp, which is id
      # but of course, LNED strikes, so we need to make copies ourselves
      tab := table(eval(_EnvPathCond));
      tab[var] := AndProp(tab[var], dom);
      _EnvPathCond := tab;
      # need to adjust types on first op, to its own type, as that may require
      # tweaking which functions are used
      'Bind'(adjust_types(op(1,e), inf_typ, ctx), var, adjust_types(op(3,e), typ, ctx));
    elif type(e, 'Bind'(identical(Lebesgue), name = range, anything)) then
      dom := RealRange(op([2,2,1],e), op([2,2,2], e));
      var := op([2,1],e);
      # indexing function at work: if unassigned, get TopProp, which is id
      tab := table(eval(_EnvPathCond));
      tab[var] := AndProp(tab[var], dom);
      _EnvPathCond := tab;
      'Bind'(op(1,e), var, adjust_types(op(3,e), typ, ctx));
    elif type(e, 'If'(anything, anything, anything)) then
      var, dom := analyze_cond(op(1,e));
      opc := _EnvPathCond[var];
      tab_left := table(eval(_EnvPathCond));
      tab_right := table(eval(_EnvPathCond));
      tab_left[var] := AndProp(opc, dom);
      _EnvPathCond := tab_left;
      left := adjust_types(op(2,e), typ, ctx);
      dom := flip_rr(dom);
      tab_right[var] := AndProp(opc, dom);
      _EnvPathCond := tab_right;
      right := adjust_types(op(3,e), typ, ctx);
      'If'(op(1,e), left, right);
    elif type(e, 'Uniform'(anything, anything)) and typ = 'Measure(Real)' then
      e
    elif type(e, 'Uniform'(anything, anything)) and typ = 'Measure(Prob)' then
      var := gensym('pp');
      Bind(e, var, Return(unsafeProb(var)))
    elif type(e, 'NormalD'(anything, anything)) and typ = 'Measure(Real)' then
      NormalD(op(1,e), mkProb(op(2, e), ctx))
    else
     error "adjust_types ", e, typ;
    end if;
  end proc;

  compute_domain := proc(e)
    local res;
    if type(e, 'Uniform'(anything, anything)) then
      'RealRange'(op(e));
    elif type(e, {identical('Lebesgue'), specfunc(anything, 'NormalD')}) then
      'real'
    elif type(e, specfunc(anything, 'Superpose')) then
      if nops(e)=1 then
        compute_domain(op([1,2],e))
      else
        res := map((x -> compute_domain(op(2,x))), {op(e)});
        if nops(res)=1 then
          res[1]
        else
          error "expression e", e, "has multiple domain", res
        end if;
      end if;
    else
      error "compute domain:", e;
    end if;
  end proc;

  analyze_cond := proc(c)
    local vars;
    vars := remove(type, indets(c, 'name'), 'constant');
    if nops(vars) > 1 then
      error "analyze_cond: multivariate condtion! ", c;
    else
      # buried magic!
      `property/ConvertRelation`(c);
    end if;
  end proc;

  # rr = real cannot happen
  flip_rr := proc(rr::RealRange(anything,anything))
    local l, r;

    if op(1,rr)=-infinity then
      l := op(2,rr);
      if l :: Open(anything) then
        RealRange(op(1,l), infinity)
      else
        RealRange(Open(op(1,l)), infinity)
      end if
    elif op(2,rr)=infinity then
      r := op(1,rr);
      if r :: Open(anything) then
        RealRange(-infinity, op(1,r))
      else
        RealRange(-infinity, Open(op(1,r)))
      end if;
    else
      error "flip_rr", rr
    end if;
  end proc;

  # while inside the evaluator, we want infinities
  MyHandler := proc(operator, operands, default_value)
    NumericStatus( division_by_zero = false);
    if operator='ln' then -infinity else default_value end if;
  end proc;

  # simplify ASTs (before they have been 'fixed' to be type-correct)
  simp_AST := proc(ast)
    local res;

    # first, simplify Bind
    res := ast;
    res := eval(res, 'Bind' = simp_bind);

    # second, simplify (and sort) Superpose
    res := eval(res, 'Superpose' = simp_sup);

    # third, remove 'undefined' branches of If
    res := eval(res, 'If' = simp_if);

    res;
  end proc;

  # dirac < uniform < NormalD < bind < Superpose
  # returns false on equality
  comp2 := proc(x,y)
    if x::Return(anything) then
      if y::Return(anything) then
	if op(1,x)::numeric and op(1,y)::numeric then
	  evalb(op(1,x) < op(1,y))
	else
	  evalb(length(op(1,x)) < length(op(1,y)))
	end if
      else
	true
      end if
    elif x::Uniform(numeric, numeric) then
      if y::Uniform(numeric, numeric) then
	evalb(op(1,x) < op(1,y))
      else
	evalb(not member(op(0,y), {Return}))
      end if
    elif x::specfunc(anything, Bind) then
      if y::specfunc(anything, Bind) then
	comp2(op(3, x), op(3, y))
      else
	evalb(not member(op(0,y), {Return, Uniform}));
      end if
    elif x::specfunc(anything, NormalD) then
      if y::specfunc(anything, NormalD) then
        `and`(op(zip(comp_WM, [op(x)], [op(y)])))
      else
	evalb(not member(op(0,y), {Return, Uniform, NormalD}));
      end if;
    elif x::specfunc(anything, Superpose) then
      if y::specfunc(anything, Superpose) then
        `and`(op(zip(comp_WM, [op(x)], [op(y)])))
      else
	evalb(not member(op(0,y), {Return, Uniform, NormalD, Superpose}));
      end if;
    else
      error "cannot compare", x, y
    end if;
  end proc;

  comp_WM := proc(x,y) comp2(op(2,x), op(2,y)) end proc;

  comp_algeb := proc(x,y)
  end proc;

  comp := proc(x, y) comp2(op(2,x), op(2,y)) end;

  # helper routines for simplifying ASTs
  simp_sup := proc()
    local l;
    if _npassed = 0 then 'Superpose'()
    elif _npassed=1 and type(_passed[1], 'WM'(identical(1), anything)) then
      op(2, _passed[1])
    else
      l := map(simp_WM, [args]);
      if not (l = [args]) then
        l := simp_sup(op(l));
        if l :: specfunc(anything, 'Superpose') then
          simp_sup(op(l))
        else
          l
        end if;
      else
        Superpose(op(sort(l, 'strict'=comp)))
      end if;
    end if;
  end proc;

  simp_WM := proc(wm)
    local w,m;
    w, m := op(wm);
    if type(m, specfunc(anything, 'Superpose')) then
       'WM'(1, simp_sup(op(map(into_sup, m, w))));
    else
      'WM'(w,m)
    end if;
  end;

  into_sup := proc(wm, w) 'WM'(simplify(w*op(1,wm)), op(2,wm)) end proc;

  simp_bind := proc(w, var, meas)
    if meas = Return(var) then w else 'Bind'(w, var, meas) end if;
  end proc;

  simp_if := proc(cond, tb, eb)
    if tb = Return(undefined) then
      eb
    elif tb = eb then
      eb
    else
      'If'(cond, tb, eb)
    end if;
  end;

  # density recognizer
  recognize_density := proc(dens, var)
    local de, init, diffop, Dx, a0, a1, scale, at0, mu, sigma;
    de := gfun[holexprtodiffeq](dens, f(var));
    init, de := selectremove(type, de, `=`);
    if nops(init)=1 and nops(de)=1 then
      init := rhs(init[1]);
      de := de[1];
      diffop := DEtools[de2diffop](de, f(var), [Dx, var]);
      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 then
          scale := coeff(a0, var, 1);
          mu := -coeff(a0, var, 0)/scale;
          sigma := sqrt(coeff(a1, var, 0)/scale);
          at0 := simplify(eval(init/density[NormalD](mu, sigma, 0)));
          return simp_sup('WM'(at0, NormalD(mu,sigma)));
	end if;
      end if;
    end if;
    NULL;
  end proc;

  mkRealDensity := proc(dens, var)
    local res;
    if dens :: specfunc(anything, 'Superpose') then
      simp_sup(op(map(thisproc, dens, var)));
    elif dens :: specfunc(anything, 'WM') then
      res := recognize_density(op(1,dens), var);
      if res<>NULL then
        'WM'(1, Bind(res, var, op(2,dens)))
      else
        'WM'(1, Bind(Lebesgue, var, simp_sup(dens)))
      end if;
    else
      Bind(Lebesgue, var, dens)
    end if
  end proc;

  density[NormalD] := proc(mu, sigma, x)
    1/sigma/sqrt(2)/sqrt(Pi)*exp(-(x-mu)^2/2/sigma^2)
  end proc;
end;

# 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;

# A Context contains
# - a (Maple-encoded) Hakaru type 'htyp' (H-types)
# - a Measure type
# - a global context of var = H-types
# - a global numbering context for var names
# - the size of the global context (in # of variables)
`type/Context` := 'record'('htyp', 'mtyp', 'gctx', 'gnum', 'gsize');

# like index/identity, but for properties
`index/TopProp` := proc(Idx::list,Tbl::table,Entry::list)
  if (nargs = 2) then
    if assigned(Tbl[op(Idx)]) then Tbl[op(Idx)] else TopProp end if;
  elif Entry = [TopProp] then
    TopProp;
  else
    Tbl[op(Idx)] := op(Entry);
  end if;
end proc:

# 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: c is "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw,
    superpose, mkProb, getCtx, instantiate, lambda_wrap, fill_table,
    adjust_types, compute_domain, analyze_cond, flip_rr, isPos,
    MyHandler, getBinderForm, infer_type, join_type, join2type,
    simp_AST, simp_sup, simp_bind, simp_if, simp_WM, into_sup,
    comp, comp2, comp_algeb, comp_WM,
    mkRealDensity, recognize_density, density;

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

  ModuleApply := proc(spec::Typed(anything,anything))
    local expr, typ, glob, gsiz, ctx, r, inp, meastyp, res, gnumbering;
    expr := op(1, spec);
    typ := op(2, spec);
    glob, gnumbering, gsiz, meastyp := getCtx(typ, table(), table(), 0);
    r := Record('htyp' = typ, 'mtyp' = meastyp,
                'gctx' = glob, 'gnum' = gnumbering, 'gsize' = gsiz);
    inp := instantiate(expr, r, 0, typ);
    try
      NumericEventHandler(division_by_zero = MyHandler);
      res := HAST(simp(value(eval(inp(c), 'if_'=piecewise))), r);
    catch "Wrong kind of parameters in piecewise":
      error "Bug in Hakaru -> Maple translation, piecewise used incorrectly.";
    finally :
      NumericEventHandler(division_by_zero = default);
    end try;
    res;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  # environment variables plus indexing functions make tracking info easy!
  AST := proc(inp::HAST(anything, Context))
    local res, ctx, t, i, rng;

    ctx := op(2,inp);
    t := table(TopProp);

    # right at the start, put the global context in the 'path'.
    for i in [indices(ctx:-gctx, 'pairs')] do
      fill_table(t, lhs(i), rhs(i));
    end do;
    _EnvPathCond := eval(t);
    res := ToAST(op(inp));
    res := simp_AST(res);
    res := adjust_types(res, ctx:-mtyp, ctx);
    lambda_wrap(res, 0, ctx);
  end proc;

  # recursive function which does the main translation
  ToAST := proc(inp, ctx)
    local a0, a1, var, vars, rng, ee, cof, d, ld, weight, binders,
      v, subst, ivars, ff, newvar, rest, a, b, e, span;
    e := inp; # make e mutable
    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])));
          elif (ee=0) then # collect/simplify could have revealed this
            Superpose()
          elif (ld = 0) then
            error "non-zero constant encountered as a measure", ee
          else
            error "polynomial in c:", ee
          end if;
        elif type(ee, t_pw) then
          return do_pw(map(simplify, [op(e)]), ctx, BottomProp);
        elif type(ee, `+`) then
          superpose(map(ToAST, [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));
          span := RealRange(op(1,rng), op(2,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, ctx);
            if rng = -infinity..infinity then
              mkRealDensity(rest, var)
            else
              # recognize densities on partial range here
              Bind(Lebesgue, var = rng, rest)
            end if;
          else
            v := simplify(weight*ee) assuming var :: span;
            rest := ToAST(v, ctx);
            Bind(Uniform(op(rng)), var, rest);
          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, BottomProp);
        elif type(e, `+`) then
          superpose(map(ToAST, [op(e)], ctx));
        elif type(e, `*`) then
          # we have a binder in here somewhere
          a, b := selectremove(type, e, t_binds);
          # now casesplit on what a is
## from here
          if a=1 then  # no surface binders
            a, b := selectremove(type, e, t_pw);
            if a=1 then # and no piecewise either
              error "buried binder: ", b
            elif type(a, `*`) then
              error "do not know how to multiply 2 pw:", a
            elif type(a, t_pw) then
              Superpose('WM'(b, ToAST(a, ctx)))
            else
              error "something weird happened:", a, " was supposed to be pw"
            end if
          elif type(a, `*`) then
            error "product of 2 binders?!?", a
          else
            Superpose('WM'(b, ToAST(a, ctx)))
          end if
## to here
        else
            error "Not sure what to do with a ", e
        end if;
      end if;
    end if;
  end proc;

  # simp mostly recurses and simplifies as it goes
  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
        simp(b)*simp(a)
        # 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.
  # this assumes that the pw is univariate
  do_pw := proc(l, ctx, prop)
    local len, rel, prop_ctx, this, var;
    len := nops(l);
    if len = 0 then Superpose()
    elif len = 1 then ToAST(l[1], ctx)
    else # len>2.
      var, rel := analyze_cond(l[1]);
      prop_ctx := OrProp(prop, rel);
      if len=2 then
        if prop_ctx='real' then return ToAST(l[2], ctx) end if;
      end if;
      If(l[1], ToAST(l[2], ctx), thisproc(l[3..-1], ctx, prop_ctx))
    end if;
  end;

  superpose := proc(l)
    local t, i, j, idx;
    t := table('sparse');
    for i in l do
      if type(i, specfunc(anything, Superpose)) then
        for j in [op(i)] do
          idx := op(2,j);
          # yay for indexing functions!
          t[idx] := t[idx] + op(1,j);
        end do;
      else
        error "still don't know how to superpose ", i;
      end if;
    end do;
    Superpose(seq('WM'(t[op(i)], op(i)), i = [indices(t)]));
  end proc;

  mkProb := proc(w, ctx)
    local typ, i, ww, pos, rest;
    if type(w, `*`) then
      map(mkProb, w, ctx)
    elif type(w, 'exp'(anything)) then
      exp_(op(1,w));
    elif type(w, 'erf'(anything)) then
      erf_(mkProb(op(1,w)));
    elif type(w, 'ln'(anything)) then
      error "mkProb ln", w;
    elif type(w, anything^fraction) then
      typ := infer_type(op(1,w), ctx);
      if typ = 'Prob' then w else mkProb(op(1,w), ctx) ^ op(2,w) end if;
    elif type(w, 'unsafeProb'(anything)) then
      error "there should be no unsafeProb in", w
    else
      typ := infer_type(w, ctx);
      if typ = 'Prob' then
        w
      elif typ = 'Real' then
        # we are going to need to cast.  Is it safe?
        if not isPos(w) then WARNING("cannot insure it will not crash") end if;
        unsafeProb(w);
      else
        error "how do I make a Prob from ", w, "in", eval(_EnvPathCond)
      end if;
    end if;
  end proc;

  # use assumptions to figure out if we are actually positive, even
  # when the types say otherwise
  isPos := proc(w)
    local prop, res;

    prop := map(x -> op(1,x) :: op(2, x), [indices(_EnvPathCond, 'pairs')]);
    res := signum(0, w, 1) assuming op(prop);
    evalb(res = 1);
  end proc;

  fill_table := proc(t, nm, typ)
      if nm::name then
        if typ = 'Real' then
          t[nm] := RealRange(-infinity, infinity)
        elif typ = 'Prob' then
          t[nm] := RealRange(0, infinity)
        elif typ = 'Bool' then
          t[nm] := boolean
        elif typ = 'Unit' then
          t[nm] := Unit # ???
        else
          error "Real/Prob/Bool/Unit are the only base types:", typ;
        end if;
      elif typ :: 'Pair'(anything, anything) then
        fill_table(t, op(1, nm), op(1, typ));
        fill_table(t, op(2, nm), op(2, typ));
      elif typ :: 'Measure'(anything) then
        error "cannot handle first-class measure types yet"
      elif typ :: 'Arrow'(anything,anything) then
        error "cannot handle first-class -> types yet"
      else
        error "I don't know type", typ;
      end if;
  end proc;

  getBinderForm := proc(t)
    local left, right;
    if t = 'Real' then gensym('rr')
    elif t = 'Prob' then gensym('pp')
    elif t :: Pair(anything, anything) then
      left := getBinderForm(op(1,t));
      right := getBinderForm(op(2,t));
      Pair(left, right);
    elif t = 'Bool' then gensym('bb')
    else
      error "Tring to forma a name from a", t
    end if;
  end proc;

  getCtx := proc(typ, glob, globNum, ctr)
    local nm, t;
    if type(typ, 'Arrow'(anything, anything)) then
      t := op(1,typ);
      # 'nm' is a name-filled type structure, not necessarily a name
      nm := getBinderForm(t);
      globNum[ctr] := nm;
      glob[nm] := t;
      getCtx(op(2,typ), glob, globNum, ctr+1)
    elif type(typ, 'Measure'(anything)) then
      glob, globNum, ctr, typ
    else
      error "must have either Measure or Arrow, got", typ;
    end if;
  end proc;

  instantiate := proc(e, ctx, ctr, typ)
    local nm;
    if ctr = ctx:-gsize then
      e
    else
      nm := ctx:-gnum[ctr];
      instantiate(e(nm), ctx, ctr + 1, op(2,typ))
    end if;
  end proc;

  lambda_wrap := proc(expr, cnt, ctx)
    local var, sub;
    if cnt = ctx:-gsize then
      expr
    else
      var := ctx:-gnum[cnt];
      Lambda(var, lambda_wrap(expr, cnt+1, ctx));
    end if;
  end proc;

  infer_type := proc(e, ctx)
    local typ, l, res;
    if type(e, boolean) then
      'Bool'
    elif e = 'Pi' then Prob
    elif e = 'Unit' then Unit
    elif type(e, boolean) then
      'Bool'
    elif type(e, anything^integer) then
      infer_type(op(1,e), ctx);
    elif type(e, 'exp'(anything)) then
      typ := infer_type(op(1,e), ctx); # need to make sure it is inferable
      'Real' # someone else will make sure to cast this correctly
    elif type(e, anything^fraction) then
      typ := infer_type(op(1,e), ctx); # need to make sure it is inferable
      typ; # if it is <0, weird things will happen
      # someone else will make sure to cast this correctly
    elif type(e, 'ln'(anything)) then
      typ := infer_type(op(1,e), ctx); # need to make sure it is inferable
      'Real'
    elif type(e, 'symbol') then
      # if we have a type, use it
      if assigned(ctx:-gctx[e]) then return(ctx:-gctx[e]); end if;

      # otherwise, really do infer it
      typ := _EnvPathCond[e];
      if typ :: {'RealRange'(anything, anything),
                 identical(real), identical(TopProp)} then
        'Real'
      else
        error "Impossible: an untyped free variable", e, "in global context",
          eval(ctx:-gctx), "and local context", eval(_EnvPathCond)
      end if;
    elif type(e, 'realcons') and signum(0,e,1) = 1 then
      'Prob'
    elif type(e, 'realcons') then
      'Real'
    elif type(e, 'Pair'(anything, anything)) then
      map(infer_type, e, ctx);
    elif type(e, {`+`, `*`}) then
      l := map(infer_type, [op(e)], ctx);
      join_type(op(l));
    elif type(e, specfunc(anything, 'piecewise')) then
      typ := NULL;
      for l from 1 to nops(e) do
        if l::odd and l<nops(e) then
          next;
        else # last or e:: evan
          typ := typ, infer_type(op(l, e), ctx)
        end if;
      end do;
      join_type(typ);
    elif type(e, {specfunc(anything, 'NormalD')}) then
      Measure(Real)
    elif type(e, specfunc(anything, 'Superpose')) then
      res := map(infer_type, {op(e)}, ctx);
      if nops(res) = 1 then
        res[1]
      else
        error "superpose with multiple types", e
      end if;
    elif type(e, specfunc(anything, 'WM')) then
      infer_type(op(2, e), ctx)
    elif type(e, specfunc(anything, 'Uniform')) then
      Measure(Real)
    else
      error "how do I infer a type from", e;
    end if;
  end proc;

  join2type := proc(a,b)
    if a = b then a
    elif a = 'Real' or b = 'Real' then 'Real'
    else error "join2type of", a, b
    end if;
  end proc;

  # could foldl, but this will work too
  join_type := proc()
    if _npassed < 2 then error "cannot happen"
    elif _npassed = 2 then
      join2type(_passed[1], _passed[2])
    else
      join_type(join2type(_passed[1], _passed[2]), _passed[3..-1])
    end if;
  end proc;
  ####
  # Fix-up the types using contextual information.
# TODO: need to add unsafeProb around the Prob-typed input variables,
# and then fix-up things like log.
#
# The right way to do this is really to do
# - full 'type' inference of e
# - full 'range-of-value' inference of e
  adjust_types := proc(e, typ, ctx)
    local ee, dom, opc, res, var, left, right, inf_typ, tab, typ2,
          tab_left, tab_right;
    if type(e, specfunc(anything, 'Superpose')) then
      map(thisproc, e, typ, ctx)
    elif type(e, 'WM'(anything, anything)) then
      'WM'(mkProb(op(1,e), ctx), thisproc(op(2,e), typ, ctx));
    elif type(e, 'Return'(anything)) and type(typ, 'Measure'(anything)) then
      typ2 := op(1, typ);
      inf_typ := infer_type(op(1,e), ctx);
      if typ2 = Unit and op(1,e) = Unit then
        e
      elif typ2 = Prob then
        ee := op(1,e);
        res := mkProb(ee, ctx);
        'Return'(res);
      elif typ2 = Real and type(op(1,e), 'ln'(anything)) then
        ee := op(1,e);
        inf_typ := infer_type(op(1, ee), ctx);
        if inf_typ = 'Prob' then
          'Return'(ln_(op(1,ee)))
        else
          'Return'(ee);
        end if;
      # hmm, are things polymorphic enough that this is ok?
      # might need 'fromProb' to be inserted?
      elif typ2 = Real and member(inf_typ, {'Real', 'Prob'}) then
        'Return'(op(1,e))
      elif typ2 :: Pair(anything, anything) and
           op(1,e) :: Pair(anything, anything) then
        left  := adjust_types('Return'(op([1,1],e)), Measure(op(1,typ2)), ctx);
        right := adjust_types('Return'(op([1,2],e)), Measure(op(2,typ2)), ctx);
        'Return'(Pair(op(1,left), op(1,right)));
      elif typ2 = Bool and member(op(1,e), {true,false}) then
        e
      else
         error "adjust_types Type:", typ, inf_typ, e;
      end if;
    elif type(e, 'Bind'(anything, name, anything)) then
      dom := compute_domain(op(1,e));
      var := op(2,e);
      inf_typ := infer_type(op(1,e), ctx);
      # indexing function at work: if unassigned, get TopProp, which is id
      # but of course, LNED strikes, so we need to make copies ourselves
      tab := table(eval(_EnvPathCond));
      tab[var] := AndProp(tab[var], dom);
      _EnvPathCond := tab;
      # need to adjust types on first op, to its own type, as that may require
      # tweaking which functions are used
      'Bind'(adjust_types(op(1,e), inf_typ, ctx), var, adjust_types(op(3,e), typ, ctx));
    elif type(e, 'Bind'(identical(Lebesgue), name = range, anything)) then
      dom := RealRange(op([2,2,1],e), op([2,2,2], e));
      var := op([2,1],e);
      # indexing function at work: if unassigned, get TopProp, which is id
      tab := table(eval(_EnvPathCond));
      tab[var] := AndProp(tab[var], dom);
      _EnvPathCond := tab;
      'Bind'(op(1,e), var, adjust_types(op(3,e), typ, ctx));
    elif type(e, 'If'(anything, anything, anything)) then
      var, dom := analyze_cond(op(1,e));
      opc := _EnvPathCond[var];
      tab_left := table(eval(_EnvPathCond));
      tab_right := table(eval(_EnvPathCond));
      tab_left[var] := AndProp(opc, dom);
      _EnvPathCond := tab_left;
      left := adjust_types(op(2,e), typ, ctx);
      dom := flip_rr(dom);
      tab_right[var] := AndProp(opc, dom);
      _EnvPathCond := tab_right;
      right := adjust_types(op(3,e), typ, ctx);
      'If'(op(1,e), left, right);
    elif type(e, 'Uniform'(anything, anything)) and typ = 'Measure(Real)' then
      e
    elif type(e, 'Uniform'(anything, anything)) and typ = 'Measure(Prob)' then
      var := gensym('pp');
      Bind(e, var, Return(unsafeProb(var)))
    elif type(e, 'NormalD'(anything, anything)) and typ = 'Measure(Real)' then
      NormalD(op(1,e), mkProb(op(2, e), ctx))
    else
     error "adjust_types ", e, typ;
    end if;
  end proc;

  compute_domain := proc(e)
    local res;
    if type(e, 'Uniform'(anything, anything)) then
      'RealRange'(op(e));
    elif type(e, {identical('Lebesgue'), specfunc(anything, 'NormalD')}) then
      'real'
    elif type(e, specfunc(anything, 'Superpose')) then
      if nops(e)=1 then
        compute_domain(op([1,2],e))
      else
        res := map((x -> compute_domain(op(2,x))), {op(e)});
        if nops(res)=1 then
          res[1]
        else
          error "expression e", e, "has multiple domain", res
        end if;
      end if;
    else
      error "compute domain:", e;
    end if;
  end proc;

  analyze_cond := proc(c)
    local vars;
    vars := remove(type, indets(c, 'name'), 'constant');
    if nops(vars) > 1 then
      error "analyze_cond: multivariate condtion! ", c;
    else
      # buried magic!
      `property/ConvertRelation`(c);
    end if;
  end proc;

  # rr = real cannot happen
  flip_rr := proc(rr::RealRange(anything,anything))
    local l, r;

    if op(1,rr)=-infinity then
      l := op(2,rr);
      if l :: Open(anything) then
        RealRange(op(1,l), infinity)
      else
        RealRange(Open(op(1,l)), infinity)
      end if
    elif op(2,rr)=infinity then
      r := op(1,rr);
      if r :: Open(anything) then
        RealRange(-infinity, op(1,r))
      else
        RealRange(-infinity, Open(op(1,r)))
      end if;
    else
      error "flip_rr", rr
    end if;
  end proc;

  # while inside the evaluator, we want infinities
  MyHandler := proc(operator, operands, default_value)
    NumericStatus( division_by_zero = false);
    if operator='ln' then -infinity else default_value end if;
  end proc;

  # simplify ASTs (before they have been 'fixed' to be type-correct)
  simp_AST := proc(ast)
    local res;

    # first, simplify Bind
    res := ast;
    res := eval(res, 'Bind' = simp_bind);

    # second, simplify (and sort) Superpose
    res := eval(res, 'Superpose' = simp_sup);

    # third, remove 'undefined' branches of If
    res := eval(res, 'If' = simp_if);

    res;
  end proc;

  # dirac < uniform < NormalD < bind < Superpose
  # returns false on equality
  comp2 := proc(x,y)
    if x::Return(anything) then
      if y::Return(anything) then
	if op(1,x)::numeric and op(1,y)::numeric then
	  evalb(op(1,x) < op(1,y))
	else
	  evalb(length(op(1,x)) < length(op(1,y)))
	end if
      else
	true
      end if
    elif x::Uniform(numeric, numeric) then
      if y::Uniform(numeric, numeric) then
	evalb(op(1,x) < op(1,y))
      else
	evalb(not member(op(0,y), {Return}))
      end if
    elif x::specfunc(anything, Bind) then
      if y::specfunc(anything, Bind) then
	comp2(op(3, x), op(3, y))
      else
	evalb(not member(op(0,y), {Return, Uniform}));
      end if
    elif x::specfunc(anything, NormalD) then
      if y::specfunc(anything, NormalD) then
        `and`(op(zip(comp_WM, [op(x)], [op(y)])))
      else
	evalb(not member(op(0,y), {Return, Uniform, NormalD}));
      end if;
    elif x::specfunc(anything, Superpose) then
      if y::specfunc(anything, Superpose) then
        `and`(op(zip(comp_WM, [op(x)], [op(y)])))
      else
	evalb(not member(op(0,y), {Return, Uniform, NormalD, Superpose}));
      end if;
    else
      error "cannot compare", x, y
    end if;
  end proc;

  comp_WM := proc(x,y) comp2(op(2,x), op(2,y)) end proc;

  comp_algeb := proc(x,y)
  end proc;

  comp := proc(x, y) comp2(op(2,x), op(2,y)) end;

  # helper routines for simplifying ASTs
  simp_sup := proc()
    local l;
    if _npassed = 0 then 'Superpose'()
    elif _npassed=1 and type(_passed[1], 'WM'(identical(1), anything)) then
      op(2, _passed[1])
    else
      l := map(simp_WM, [args]);
      if not (l = [args]) then
        l := simp_sup(op(l));
        if l :: specfunc(anything, 'Superpose') then
          simp_sup(op(l))
        else
          l
        end if;
      else
        Superpose(op(sort(l, 'strict'=comp)))
      end if;
    end if;
  end proc;

  simp_WM := proc(wm)
    local w,m;
    w, m := op(wm);
    if type(m, specfunc(anything, 'Superpose')) then
       'WM'(1, simp_sup(op(map(into_sup, m, w))));
    else
      'WM'(w,m)
    end if;
  end;

  into_sup := proc(wm, w) 'WM'(simplify(w*op(1,wm)), op(2,wm)) end proc;

  simp_bind := proc(w, var, meas)
    if meas = Return(var) then w else 'Bind'(w, var, meas) end if;
  end proc;

  simp_if := proc(cond, tb, eb)
    if tb = Return(undefined) then
      eb
    elif tb = eb then
      eb
    else
      'If'(cond, tb, eb)
    end if;
  end;

  # density recognizer
  recognize_density := proc(dens, var)
    local de, init, diffop, Dx, a0, a1, scale, at0, mu, sigma;
    de := gfun[holexprtodiffeq](dens, f(var));
    init, de := selectremove(type, de, `=`);
    if nops(init)=1 and nops(de)=1 then
      init := rhs(init[1]);
      de := de[1];
      diffop := DEtools[de2diffop](de, f(var), [Dx, var]);
      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 then
          scale := coeff(a0, var, 1);
          mu := -coeff(a0, var, 0)/scale;
          sigma := sqrt(coeff(a1, var, 0)/scale);
          at0 := simplify(eval(init/density[NormalD](mu, sigma, 0)));
          return simp_sup('WM'(at0, NormalD(mu,sigma)));
	end if;
      end if;
    end if;
    NULL;
  end proc;

  mkRealDensity := proc(dens, var)
    local res;
    if dens :: specfunc(anything, 'Superpose') then
      simp_sup(op(map(thisproc, dens, var)));
    elif dens :: specfunc(anything, 'WM') then
      res := recognize_density(op(1,dens), var);
      if res<>NULL then
        'WM'(1, Bind(res, var, op(2,dens)))
      else
        'WM'(1, Bind(Lebesgue, var, simp_sup(dens)))
      end if;
    else
      Bind(Lebesgue, var, dens)
    end if
  end proc;

  density[NormalD] := proc(mu, sigma, x)
    1/sigma/sqrt(2)/sqrt(Pi)*exp(-(x-mu)^2/2/sigma^2)
  end proc;
end;

# 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;

# A Context contains
# - a (Maple-encoded) Hakaru type 'htyp' (H-types)
# - a Measure type
# - a global context of var = H-types
# - a global numbering context for var names
# - the size of the global context (in # of variables)
`type/Context` := 'record'('htyp', 'mtyp', 'gctx', 'gnum', 'gsize');

# like index/identity, but for properties
`index/TopProp` := proc(Idx::list,Tbl::table,Entry::list)
  if (nargs = 2) then
    if assigned(Tbl[op(Idx)]) then Tbl[op(Idx)] else TopProp end if;
  elif Entry = [TopProp] then
    TopProp;
  else
    Tbl[op(Idx)] := op(Entry);
  end if;
end proc:


Add interpretation (not recognition) of Uniform

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('hh');
    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 :: 'Msum(list)' then
      `+`(op(map(integrate, op(1,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('hl');
    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(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('xu');
      # 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('xu');
      # 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

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,
         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('hh');
    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 :: 'Msum(list)' then
      `+`(op(map(integrate, op(1,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 :: '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('hl');
    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(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('xu');
      # 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('xu');
      # 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


translation of upper-bounded integrals was backwards.

# 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, isPos;

      isPos := proc(y) evalb(signum(0, eval(y,sqrt_=sqrt),1)=1) end;
      b:-clear();

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

      # 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
      expr := subsindets(expr, satisfies(isPos)^identical(1/2),
               (x -> sqrt_(op(1,x))));
      expr := subsindets(expr, anything^identical(1/2),
               (x -> Sqrt(op(1,x))));

      # 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;

      # unsafeProb(..)^(fraction)
      expr := subsindets(expr, specfunc(anything,'unsafeProb')^fraction,
        x -> pow_(op(1,x), op(2,x)));

      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["Counting"] := proc() b:-append("counting") end;
bi["Pi"] := proc() b:-append("pi_") end;
bi["Fst"] := ufunc("fst_");
bi["Snd"] := ufunc("snd_");
bi["pow_"] := bfunc("pow_");

# SOP functions
bi["Tag"] := proc(a,b) ufunc("tag")(b); end proc;
bi["Zero"] := ufunc("_Z");
bi["Succ"] := ufunc("_S");
bi["Cons"] := bfunc("_Cons");
bi["Nil"] := proc() b:-append("_Nil") end;

# 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.
# Note that we use < and > rather than <= and >= since the background
# measure is assumed to be Lebesgue
  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(var < upper, 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, isPos;

      isPos := proc(y) evalb(signum(0, eval(y,sqrt_=sqrt),1)=1) end;
      b:-clear();

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

      # 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
      expr := subsindets(expr, satisfies(isPos)^identical(1/2),
               (x -> sqrt_(op(1,x))));
      expr := subsindets(expr, anything^identical(1/2),
               (x -> Sqrt(op(1,x))));

      # 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;

      # unsafeProb(..)^(fraction)
      expr := subsindets(expr, specfunc(anything,'unsafeProb')^fraction,
        x -> pow_(op(1,x), op(2,x)));

      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["Counting"] := proc() b:-append("counting") end;
bi["Pi"] := proc() b:-append("pi_") end;
bi["Fst"] := ufunc("fst_");
bi["Snd"] := ufunc("snd_");
bi["pow_"] := bfunc("pow_");

# SOP functions
bi["Tag"] := proc(a,b) ufunc("tag")(b); end proc;
bi["Zero"] := ufunc("_Z");
bi["Succ"] := ufunc("_S");
bi["Cons"] := bfunc("_Cons");
bi["Nil"] := proc() b:-append("_Nil") end;

# 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.
# Note that we use < and > rather than <= and >= since the background
# measure is assumed to be Lebesgue
  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:


Add file

Add file

    # eval_piecewise has the same calling convention as eval_factor.
    # It simplifies piecewise expressions.
    eval_piecewise := proc(e :: specfunc(piecewise),
                           kb :: t_kb, mode :: identical(`*`,`+`),
                           loops :: list([identical(product,Product,sum,Sum),
                                          name=range]),
                           $)
      local default, kbs, pieces, i, cond, inds, res, x, b, a;
      default := 0; # the catch-all "else" result
      kbs[1] := kb;
      for i from 1 by 2 to nops(e) do
        if i = nops(e) then
          default := op(i,e);
          pieces[i] := default;
        else
          # Simplify piecewise conditions using KB
          cond := op(i,e);
          # cond := eval_factor(cond, kbs[i], `+`, []);
          kbs[i+1] := assert(cond, kbs[i]);
          cond := map(proc(cond::[identical(assert),anything], $)
                        op(2,cond)
                      end proc,
                      kb_subtract(kbs[i+1], kbs[i]));
          if nops(cond) = 0 then
            default := op(i+1,e);
            pieces[i] := default;
            break;
          else
            cond := `if`(nops(cond)=1, op(1,cond), And(op(cond)));
            # TODO: Extend KB interface to optimize for
            #       entails(kb,cond) := nops(kb_subtract(assert(cond,kb),kb))=0
            kbs[i+2] := assert(Not(cond), kbs[i]);
            if nops(kb_subtract(kbs[i+2], kbs[i])) > 0 then
              pieces[i] := cond;
              pieces[i+1] := op(i+1,e);
            else
              # This condition is false in context, so delete this piece
              # by not putting anything inside "pieces"
            end if
          end if
        end if
      end do;
      # Combine duplicate branches at end
      inds := [indices(pieces, 'nolist', 'indexorder')];
      for i in ListTools:-Reverse(select(type, inds, 'even')) do
        if Testzero(pieces[i]-default) then
          pieces[i  ] := evaln(pieces[i  ]);
          pieces[i-1] := evaln(pieces[i-1]);
        else
          break;
        end if
      end do;
      # Special processing for when the pieces are few
      res := [entries(pieces, 'nolist', 'indexorder')];
      if nops(res) <= 1 then
        return eval_factor(default, kb, mode, loops);
      end if;
      if nops(res) <= 3 and op(1,res) :: `=` and Testzero(default - mode()) then
        # Reduce product(piecewise(i=3,f(i),1),i=1..10) to f(3)
        for i from 1 to nops(loops) do
          x := op([i,2,1],loops);
          if depends(op(1,res), x) then
            if ispoly(`-`(op(op(1,res))), 'linear', x, 'b', 'a') then
              b := Normalizer(-b/a);
              if nops(kb_subtract(assert(And(b :: integer,
                                             op([i,2,2,1],loops) <= b,
                                             b <= op([i,2,2,2],loops)),
                                         kb), kb)) = 0 then
                return eval_factor(eval(op(2,res), x=b),
                                   assert(x=b, kb), # TODO: why not just use kb?
                                   mode,
                                   eval(subsop(i=NULL, loops), x=b));
              end if;
            end if;
            break;
          end if;
        end do;
      end if;
      # Recursively process pieces
      inds := [indices(pieces, 'nolist', 'indexorder')];
      for i in inds do
        if i::even or i=op(-1,inds) then
          pieces[i] := eval_factor(pieces[i], kbs[i], mode, []);
        end if;
      end do;
      res := piecewise(entries(pieces, 'nolist', 'indexorder'));
      for i in loops do res := op(1,i)(res, op(2,i)) end do;
      return res;
    end proc;

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


Add seperate Partition unit test(s?)

Add seperate Partition unit test(s?)

with(Hakaru):
with(NewSLO):
with(Partition):
with(KB):

TestHakaru(Partition(a<b, VAL, b>a, VAL), VAL, label="Partition with identical bodies");

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