much nicer way to do local path info.

much nicer way to do local path info.

# 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, arrrg; # very important: c and arrrg are "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw,
    superpose, mkProb, getCtx, addCtx, instantiate, lambda_wrap,
    adjust_types, compute_domain, check_real;

  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;
    expr := op(1, spec);
    typ := op(2, spec);
    glob, gsiz, meastyp := getCtx(typ, table(), 0);
    r := Record('htyp' = typ, 'mtyp' = meastyp,
                'gctx' = glob, 'gsize' = gsiz, 'lctx' = table());
    inp := instantiate(expr, r, 0);
    try
      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.";
    end try;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  AST := proc(inp::HAST(anything, Context))
    local res, ctx;
    res := ToAST(op(inp));
    ctx := op(2,inp);
    # environment variables plus indexing functions make tracking info easy!
    _EnvPathCond := table(TopProp);
    res := adjust_types(res, ctx:-mtyp, ctx);
    lambda_wrap(res, 0, ctx);
  end proc;

  getCtx := proc(typ, glob, ctr)
    if type(typ, 'Measure'(anything)) then
      glob, ctr, op(1,typ)
    elif type(typ, 'Arrow'(anything, anything)) then
      glob[ctr] := op(1,typ);
      getCtx(op(2,typ), glob, ctr+1)
    else
      error "must have either Measure or Arrow, got", typ;
    end if;
  end proc;

  lambda_wrap := proc(expr, cnt, ctx)
    local var, sub;
    if cnt = ctx:-gsize then
      expr
    else
      var := cat('yy', cnt);
      sub := arrrg[cnt] = var;
      Lambda(var, lambda_wrap(subs(sub, expr), cnt+1, ctx));
    end if;
  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;
    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])));
            # `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, typ);
        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));
          if assigned(ctx:-lctx[var]) then
            # must alpha-rename
            newvar := gensym(_YY);
            e := subs(var = newvar, e);
            var := newvar;
          end if;
          ee := op(1,e);
          weight := simplify(op(2,rng)-op(1,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, addCtx(op(2,e), ctx));
            # should recognize densities here
            Bind(Lebesgue, var = rng, rest)
          else
            v := simplify(weight*ee)
                 assuming var :: RealRange(op(1,rng), op(2,rng));
            rest := ToAST(v, addCtx(op(2,e), ctx));
            # process the rest, and then recognize
            # recognize 'raw' uniform
            if type(rest, specfunc(identical(var), 'Return')) then
              if ctx:-mtyp = 'Real' then
                Uniform(op(rng));
              elif ctx:-mtyp = 'Prob' then
                if signum(0,op(1,rng),1) = 1 and
                   signum(0,op(2,rng),1) = 1 then
                  # someone will add the unsafeProb later
                  Bind(Uniform(op(rng)), var, Return(var));
                else
                  error "uniform with a negative range cannot be a Prob";
                end if;
              else
                error "uniform can only result in Real or Prob";
              end if;
            else
              # should really simplify rest
              Bind(Uniform(op(1, rng), op(2, rng)), var, 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, typ);
        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.
  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;

  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);
          # yeah 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, var, rng, sub;
    if type(w, 'realcons') and signum(0,w,1)=1 then
      w
    elif type(w, `*`) then
      map(mkProb, w, ctx)
    elif type(w, 'specindex'(arrrg)) then
      typ := ctx:-gctx[op(1,w)];
      if typ = 'Prob' then w
      else error "how can I make a Prob from ", w, "of type ", typ;
      end if;
    elif type(w, 'exp'(anything)) then
      exp_(op(1,w));
    # elif type(w, 'exp_'(anything)) then
    #  w
    elif type(w, 'unsafeProb'(anything)) then
      error "there should be no unsafeProb in", w
    else
      # use assumptions to figure out if we can 'do it'.
      ww := w;
      for i in [indices(ctx:-lctx, 'pairs')] do
          var := gensym(_ZZ);
          rng := rhs(i);
          assume(var, RealRange(op(1,rng), op(2,rng)));
          sub := lhs(i) = var;
          ww := subs(sub, ww);
      end do;
      if signum(0, ww, 1) = 1 then
        unsafeProb(w)
      else
        error "how do I make a Prob from ", w, "in local ctx", eval(ctx:-lctx);
      end if;
    end if;
  end proc;

  # for adding to the local context.  Make it imperative!
  addCtx := proc(a, r)
    local var, typ;
    var, typ := op(a);
    if assigned(r:-lctx[var]) then
      error "variable ", var, "seems to be used more than once in a binder"
    end if;
    r:-lctx[var] := typ;
    r;
  end proc;

  instantiate := proc(e, r, ctr)
    if ctr = r:-gsize then e else instantiate(e(arrrg[ctr]), r, ctr+1) end if;
  end proc;

  check_real := proc(e, ctx)
    local typ;
    if type(e, 'realcons') then
      e;
    elif type(e, 'symbol') then
      # 'symbol' means x_i, in pathcond
      typ := _EnvPathCond[e];
      if typ :: {'RealRange'(anything, anything), identical(real)} then
        e
      else
        error "Real: ", e, eval(_EnvPathCond);
      end if;
    elif type(e, {'exp'(anything), anything^integer}) then
      map(check_real, e, ctx)
    else
      error "Real: ", e
    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;
    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)) then
      if typ = Unit and op(1,e) = Unit then
        e
      elif typ = Prob then
        ee := op(1,e);
        res := mkProb(ee, ctx);
        'Return'(res);
      elif typ = Real then
        'Return'(check_real(op(1,e), ctx));
      elif typ :: Pair(anything, anything) and
           op(1,e) :: Pair(anything, anything) then
        left  := adjust_types('Return'(op([1,1],e)), op(1,typ), ctx);
        right := adjust_types('Return'(op([1,2],e)), op(2,typ), ctx);
        'Return'(Pair(op(1,left), op(1,right)));
      elif typ = Bool_ and member(op(1,e), {true,false}) then
        e
      else
         error "adjust_types Type:", typ;
      end if;
    elif type(e, 'Bind'(anything, name, anything)) then
      dom := compute_domain(op(1,e));
      var := op(2,e);
      # indexing function at work: if unassigned, get TopProp, which is id
      _EnvPathCond[var] := AndProp(_EnvPathCond[var], dom);
      'Bind'(op(1,e), 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
      _EnvPathCond[var] := AndProp(_EnvPathCond[var], dom);
      'Bind'(op(1,e), var, adjust_types(op(3,e), typ, ctx));
    elif type(e, 'If'(anything, anything, anything)) then
      error "If", e;
    elif type(e, 'Uniform'(anything, anything)) then
      e
    else
     error "adjust_types ", e, typ;
    end if;
  end proc;

  compute_domain := proc(e)
    if type(e, 'Uniform'(anything, anything)) then
      'RealRange'(op(e));
    else
      error "compute domain:", e;
    end if;
  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
# - the size of the global context
# - a local context of binders, var = range
`type/Context` := 'record'('htyp', 'mtyp', 'gctx', 'gsize', 'lctx');

if_ := proc(cond, tc, ec)
  if ec = false then And(cond, tc)
  elif tc = true then Or(cond, ec)
  else
      'if_'(cond, tc, ec)
  end if;
end proc;

# 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, arrrg; # very important: c and arrrg are "global".
  local ToAST, t_binds, t_pw, into_pw, myprod, gensym, gs_counter, do_pw,
    superpose, mkProb, getCtx, addCtx, instantiate, lambda_wrap,
    adjust_types, compute_domain, check_real;

  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;
    expr := op(1, spec);
    typ := op(2, spec);
    glob, gsiz, meastyp := getCtx(typ, table(), 0);
    r := Record('htyp' = typ, 'mtyp' = meastyp,
                'gctx' = glob, 'gsize' = gsiz, 'lctx' = table());
    inp := instantiate(expr, r, 0);
    try
      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.";
    end try;
  end proc;

  # AST transforms the Maple to a representation of the mochastic AST
  AST := proc(inp::HAST(anything, Context))
    local res, ctx;
    res := ToAST(op(inp));
    ctx := op(2,inp);
    res := adjust_types(res, ctx:-mtyp, ctx, table());
    lambda_wrap(res, 0, ctx);
  end proc;

  getCtx := proc(typ, glob, ctr)
    if type(typ, 'Measure'(anything)) then
      glob, ctr, op(1,typ)
    elif type(typ, 'Arrow'(anything, anything)) then
      glob[ctr] := op(1,typ);
      getCtx(op(2,typ), glob, ctr+1)
    else
      error "must have either Measure or Arrow, got", typ;
    end if;
  end proc;

  lambda_wrap := proc(expr, cnt, ctx)
    local var, sub;
    if cnt = ctx:-gsize then
      expr
    else
      var := cat('yy', cnt);
      sub := arrrg[cnt] = var;
      Lambda(var, lambda_wrap(subs(sub, expr), cnt+1, ctx));
    end if;
  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;
    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])));
            # `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, typ);
        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));
          if assigned(ctx:-lctx[var]) then
            # must alpha-rename
            newvar := gensym(_YY);
            e := subs(var = newvar, e);
            var := newvar;
          end if;
          ee := op(1,e);
          weight := simplify(op(2,rng)-op(1,rng));
          if type(weight, 'SymbolicInfinity') then
            rest := ToAST(ee, addCtx(op(2,e), ctx));
            # should recognize densities here
            Bind(Lebesgue, var = rng, rest)
          else
            v := simplify(weight*ee)
                 assuming var :: RealRange(op(1,rng), op(2,rng));
            rest := ToAST(v, addCtx(op(2,e), ctx));
            # process the rest, and then recognize
            # recognize 'raw' uniform
            if type(rest, specfunc(identical(var), 'Return')) then
              if ctx:-mtyp = 'Real' then
                Uniform(op(rng));
              elif ctx:-mtyp = 'Prob' then
                if signum(0,op(1,rng),1) = 1 and
                   signum(0,op(2,rng),1) = 1 then
                  # someone will add the unsafeProb later
                  Bind(Uniform(op(rng)), var, Return(var));
                else
                  error "uniform with a negative range cannot be a Prob";
                end if;
              else
                error "uniform can only result in Real or Prob";
              end if;
            else
              # should really simplify rest
              Bind(Uniform(op(1, rng), op(2, rng)), var, 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, typ);
        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.
  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;

  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);
          # yeah 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, var, rng, sub;
    if type(w, 'realcons') and signum(0,w,1)=1 then
      w
    elif type(w, `*`) then
      map(mkProb, w, ctx)
    elif type(w, 'specindex'(arrrg)) then
      typ := ctx:-gctx[op(1,w)];
      if typ = 'Prob' then w
      else error "how can I make a Prob from ", w, "of type ", typ;
      end if;
    elif type(w, 'exp'(anything)) then
      exp_(op(1,w));
    # elif type(w, 'exp_'(anything)) then
    #  w
    elif type(w, 'unsafeProb'(anything)) then
      error "there should be no unsafeProb in", w
    else
      # use assumptions to figure out if we can 'do it'.
      ww := w;
      for i in [indices(ctx:-lctx, 'pairs')] do
          var := gensym(_ZZ);
          rng := rhs(i);
          assume(var, RealRange(op(1,rng), op(2,rng)));
          sub := lhs(i) = var;
          ww := subs(sub, ww);
      end do;
      if signum(0, ww, 1) = 1 then
        unsafeProb(w)
      else
        error "how do I make a Prob from ", w, "in local ctx", eval(ctx:-lctx);
      end if;
    end if;
  end proc;

  # for adding to the local context.  Make it imperative!
  addCtx := proc(a, r)
    local var, typ;
    var, typ := op(a);
    if assigned(r:-lctx[var]) then
      error "variable ", var, "seems to be used more than once in a binder"
    end if;
    r:-lctx[var] := typ;
    r;
  end proc;

  instantiate := proc(e, r, ctr)
    if ctr = r:-gsize then
      e
    else
      # only assume on Prob/Real, for now.
      if r:-gctx[ctr] = 'Prob' then
        assume(arrrg[ctr] >= 0);
      elif r:-gctx[ctr] = 'Real' then
        assume(arrrg[ctr], 'real');
      end if;
      instantiate(e(arrrg[ctr]), r, ctr+1)
    end if;
  end proc;

  check_real := proc(e, ctx, pathcond)
    local typ;
    if type(e, 'realcons') then
      e;
    elif type(e, 'symbol') then
      # 'symbol' means x_i, in pathcond
      typ := pathcond[e];
      if typ :: {'RealRange'(anything, anything), identical(real)} then
        e
      else
        error "Real: ", e, eval(pathcond);
      end if;
    elif type(e, {'exp'(anything), anything^integer}) then
      map(check_real, e, ctx, pathcond)
    else
      error "Real: ", e
    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.
  adjust_types := proc(e, typ, ctx, pathcond)
    local ee, dom, opc, res, var, left, right;
    if type(e, specfunc(anything, 'Superpose')) then
      map(thisproc, e, typ, ctx, pathcond)
    elif type(e, 'WM'(anything, anything)) then
      'WM'(mkProb(op(1,e), ctx), thisproc(op(2,e), typ, ctx, pathcond));
    elif type(e, 'Return'(anything)) then
      if typ = Unit and op(1,e) = Unit then
        e
      elif typ = Prob then
        ee := op(1,e);
        res := mkProb(ee, ctx, pathcond);
        'Return'(res);
      elif typ = Real then
        'Return'(check_real(op(1,e), ctx, pathcond));
      elif typ :: Pair(anything, anything) and
           op(1,e) :: Pair(anything, anything) then
        left  := adjust_types('Return'(op([1,1],e)), op(1,typ), ctx, pathcond);
        right := adjust_types('Return'(op([1,2],e)), op(2,typ), ctx, pathcond);
        'Return'(Pair(op(1,left), op(1,right)));
      elif typ = Bool_ and member(op(1,e), {true,false}) then
        e
      else
         error "adjust_types Type:", typ;
      end if;
    elif type(e, 'Bind'(anything, name, anything)) then
      dom := compute_domain(op(1,e));
      var := op(2,e);
      if assigned(pathcond[var]) then
        opc := pathcond[var];
        pathcond[var] := AndProp(opc, dom);
      else
        opc := NULL;
        pathcond[var] := dom;
      end if;
      res := 'Bind'(op(1,e), var, adjust_types(op(3,e), typ, ctx, pathcond));
      if opc=NULL then
        pathcond[var] := 'pathcond[var]';
      else
        pathcond[var] := opc;
      end if;
      res;
    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);
      if assigned(pathcond[var]) then
        opc := pathcond[var];
        pathcond[var] := AndProp(opc, dom);
      else
        opc := NULL;
        pathcond[var] := dom;
      end if;
      res := 'Bind'(op(1,e), var, adjust_types(op(3,e), typ, ctx, pathcond));
      if opc=NULL then
        pathcond[var] := 'pathcond[var]';
      else
        pathcond[var] := opc;
      end if;
      res;
    elif type(e, 'If'(anything, anything, anything)) then
      error "If:", e;
    elif type(e, 'Uniform'(anything, anything)) then
      e
    else
     error "adjust_types ", e, typ;
    end if;
  end proc;

  compute_domain := proc(e)
    if type(e, 'Uniform'(anything, anything)) then
      'RealRange'(op(e));
    else
      error "compute domain:", e;
    end if;
  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
# - the size of the global context
# - a local context of binders, var = range
`type/Context` := 'record'('htyp', 'mtyp', 'gctx', 'gsize', 'lctx');

if_ := proc(cond, tc, ec)
  if ec = false then And(cond, tc)
  elif tc = true then Or(cond, ec)
  else
      'if_'(cond, tc, ec)
  end if;
end proc;


added more auxiliary functions

added more auxiliary functions

git-svn-id: 189946a10c5fc96e9dd03ba7cba917cd4c3d09f4@1265 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/'


translate <= too

translate <= too

# 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;
  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;
# 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
  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["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, var, rest)
  local rng;
  p(meas);
  b:-append(" `bind` \\");
  if type(var, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,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["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;

bi["exp"] := ufunc("exp");
bi["exp_"] := ufunc("exp_");
bi["ln"] := ufunc("ln");

bi["If"] := proc()
  ASSERT(_npassed>0);
  if _npassed = 1 then p(_passed[1])
  elif _npassed = 2 then
    b:-append("if_ ");
    p(_passed[1]);
    sp();
    lparen(); p(_passed[2]); rparen();
    sp();
    b:-append("0");
  else
    b:-append("if_ ");
    p(_passed[1]);
    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 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,
      lparen, rparen;
  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;
# 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
  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;

# 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, var, rest)
  local rng;
  p(meas);
  b:-append(" `bind` \\");
  if type(var, specfunc(anything,'_Inert_NAME')) then
    b:-append(op(1,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["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;

bi["exp"] := ufunc("exp");
bi["exp_"] := ufunc("exp_");
bi["ln"] := ufunc("ln");

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


renamed from org.campagnelab.mps.editor2svg.mpl

<?xml version="1.0" encoding="UTF-8"?>
<language namespace="org.campagnelab.mps.editor2pdf" uuid="93bc01ac-08ca-4f11-9c7d-614d04055dfb">
  <models>
    <modelRoot contentPath="${module}" type="default">
      <sourceRoot location="languageModels" />
    </modelRoot>
  </models>
  <accessoryModels />
  <generators>
    <generator name="" generatorUID="org.campagnelab.mps.editor2pdf#8751972264247094546" uuid="dcf04043-d992-430c-a03d-cd21b993eafa">
      <models>
        <modelRoot contentPath="${module}" type="default">
          <sourceRoot location="generator/template" />
        </modelRoot>
      </models>
      <external-templates>
        <generator generatorUID="0647eca7-da98-422a-8a8b-6ebc0bd014ea(jetbrains.mps.lang.editor#1129914002149)" />
      </external-templates>
      <dependencies>
        <dependency reexport="false">18bc6592-03a6-4e29-a83a-7ff23bde13ba(jetbrains.mps.lang.editor)</dependency>
      </dependencies>
      <usedLanguages>
        <usedLanguage>18bc6592-03a6-4e29-a83a-7ff23bde13ba(jetbrains.mps.lang.editor)</usedLanguage>
        <usedLanguage>b401a680-8325-4110-8fd3-84331ff25bef(jetbrains.mps.lang.generator)</usedLanguage>
        <usedLanguage>d7706f63-9be2-479c-a3da-ae92af1e64d5(jetbrains.mps.lang.generator.generationContext)</usedLanguage>
        <usedLanguage>93bc01ac-08ca-4f11-9c7d-614d04055dfb(org.campagnelab.mps.editor2pdf)</usedLanguage>
      </usedLanguages>
      <usedDevKits>
        <usedDevKit>fbc25dd2-5da4-483a-8b19-70928e1b62d7(jetbrains.mps.devkit.general-purpose)</usedDevKit>
      </usedDevKits>
      <mapping-priorities />
    </generator>
  </generators>
  <sourcePath />
  <dependencies>
    <dependency reexport="false">6354ebe7-c22a-4a0f-ac54-50b52ab9b065(JDK)</dependency>
    <dependency reexport="false">1ed103c3-3aa6-49b7-9c21-6765ee11f224(MPS.Editor)</dependency>
    <dependency reexport="true">fae75b6b-e1b0-446e-af11-a56ff9bea2b3(com.itext)</dependency>
    <dependency reexport="false">18bc6592-03a6-4e29-a83a-7ff23bde13ba(jetbrains.mps.lang.editor)</dependency>
  </dependencies>
  <usedLanguages>
    <usedLanguage>13744753-c81f-424a-9c1b-cf8943bf4e86(jetbrains.mps.lang.sharedConcepts)</usedLanguage>
  </usedLanguages>
  <usedDevKits>
    <usedDevKit>fbc25dd2-5da4-483a-8b19-70928e1b62d7(jetbrains.mps.devkit.general-purpose)</usedDevKit>
    <usedDevKit>2677cb18-f558-4e33-bc38-a5139cee06dc(jetbrains.mps.devkit.language-design)</usedDevKit>
  </usedDevKits>
  <extendedLanguages>
    <extendedLanguage>18bc6592-03a6-4e29-a83a-7ff23bde13ba(jetbrains.mps.lang.editor)</extendedLanguage>
  </extendedLanguages>
</language>

error: pathspec 'languages/org.campagnelab.mps.editor2pdf/org.campagnelab.mps.editor2pdf.mpl' did not match any file(s) known to git