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

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

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

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

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

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

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

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

# hygiene for Bind
TestHakaru(Bind(Bind(Uniform(0,1),x,Ret(x^2)),y,Ret(x^3)),
           Ret(x^3),
           label = "hygiene for Bind");

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

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

TestHakaru(Bind(GammaD(1,1),lambda,PoissonD(lambda)), NegativeBinomial(1,1/2),
           label = "integrate out GammaD with PoissonD likelihood to Geometric");
TestHakaru(Bind(GammaD(r,1/(1/p-1)),lambda,PoissonD(lambda)), NegativeBinomial(r,p),
           ctx = [0<p,p<1],
           label = "integrate out GammaD with PoissonD likelihood to NegativeBinomial");

# Kalman filter; note the parameter + assumption
module()
  local y, kalman;
  kalman :=
    Bind(Gaussian(0,1),x,Weight(NewSLO:-density[Gaussian](x,1)(y),Ret(x))):
  TestHakaru(kalman,
    Weight(exp(-y^2/4)/2/sqrt(Pi),Gaussian(y/2,1/sqrt(2))),
    label = "Kalman filter", ctx = [y::real]);
end module:

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

TestHakaru(model4, model4s, label = "piecewise test");
sliced :=
  Weight(exp(-lu),
  Bind(Gaussian(0,1), x,
  Weight(1/exp(-x^2/2),
  piecewise(exp(-lu) < exp(-x^2/2), piecewise(0<exp(-lu), Ret(x)))))):
sliceds :=
  Weight(2*sqrt(lu)*exp(-lu)/sqrt(Pi),
  Uniform(-sqrt(2*lu),sqrt(2*lu))):
TestHakaru(sliced, sliceds, label = "slice sampling", ctx = [lu>0]);
module()
  local d, m, uMax, kb, result;
  for d in [Gaussian(0,1), GammaD(1,1)] do
    m := Bind(d, x,
              piecewise(And(0<u, u<density[op(0,d)](op(d))(x)),
              Weight(1/density[op(0,d)](op(d))(x),
              Ret(x)))):
    uMax := maximize(density[op(0,d)](op(d))(x), x):
    kb := KB:-assert(And(0<u, u<uMax), KB:-empty):
    result := fromLO(improve(toLO(m), _ctx=kb), _ctx=kb):
    CodeTools[Test](type(result, 'Weight(anything, Uniform(anything, anything))'),
                    true,
                    label = sprintf("slice sampling %a", d)):
  end do;
end module:

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

TestHakaru(introLO, introLO_opt, simp = (x -> x), label = "2 uniform - no change");
TestHakaru(introLO, introLOs, simp = ((x,y) -> value(x)), label = "2 uniform + value = elimination");
TestHakaru(introLO, introLOs, label = "2 uniform + simplifier  elimination");

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

# tests that basic densities are properly recognized
# continuous
TestHakaru(Bind(Uniform(0,1),x,Weight(x*2,Ret(x))), BetaD(2,1),
  label="BetaD(2,1) recog");
TestHakaru(BetaD(alpha,beta), label="BetaD recog.");
TestHakaru(GammaD(a,b), label="GammaD recog.", ctx = [a>0,b>0]);
TestHakaru(GammaD(1/2,2), label="GammaD(1/2,2) recog.");
TestHakaru(LO(h, int(exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(2,GammaD(1,2)), label="GammaD(1,2) recog.");
TestHakaru(LO(h, int(x*exp(-x/2)*applyintegrand(h,x),x=0..infinity)), Weight(4,GammaD(2,2)), label="GammaD(2,2) recog.");
TestHakaru(Bind(Lebesgue(-infinity,infinity), x, Weight(1/x^2, Ret(x))));
TestHakaru(Cauchy(loc,scale), ctx = [scale>0], label="Cauchy recog.");
TestHakaru(StudentT(nu,loc,scale), ctx=[nu>0,scale>0], label = "StudentT recog.");
TestHakaru(StudentT(1,loc,scale),Cauchy(loc,scale), ctx = [scale>0],
  label = "StudentT(1,loc,scale) recog.");
# discrete
TestHakaru(Weight(1/26,Counting(17,43)), label="Discrete uniform recog.");
TestHakaru(NegativeBinomial(r,1-p-q), label="NegativeBinomial recog.");
TestHakaru(Poisson(foo/exp(bar)), label="Poisson recog.");

# how far does myint get us?
TestHakaru(
  Bind(Uniform(0,1),x,Weight(x,Ret(Unit))),
  Weight(1/2,Ret(Unit)),
  label = "eliminate Uniform");

# just the front-end is already enough to get this
TestHakaru(
  Bind(Weight(1/2,Ret(Unit)),x,Ret(Unit)),
  Weight(1/2, Ret(Unit)),
  label = "integrate at work");

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

# easy-easy-HMM
eeHMM := Bind(GammaD(1,1),t,
                 Weight(NewSLO:-density[Gaussian](0,1/sqrt(t))(a),
                 Ret(t))):
ees := Weight(1/(a^2+2)^(3/2), GammaD(3/2, 1/((1/2)*a^2+1))):

TestHakaru(eeHMM, ees, ctx = [a::real], label = "easy-easy-HMM");

# from an email conversation on Sept. 11
model6 := Bind(Gaussian(0,1),x, piecewise(x>4,Ret(4),Ret(x))):
TestHakaru(model6, model6, label = "clamped Gaussian");

# and now models (then tests) taken from Tests.RoundTrip
t1 := Bind(Uniform(0, 1), a0, Msum(Weight(a0, Ret(Unit)))):
t2 := BetaD(1,1):
t2s := Uniform(0, 1):
t3 := Gaussian(0,10):
t4 := Bind(BetaD(1, 1), a0,
      Bind(Msum(Weight(a0, Ret(true)),
                Weight((1-a0), Ret(false))), a1,
      Ret(Pair(a0, a1)))):
t4s := Bind(Uniform(0, 1), a0,
       Msum(Weight(a0, Ret(Pair(a0, true))),
            Weight((1+(a0*(-1))), Ret(Pair(a0, false))))):
t5 := Bind(Msum(Weight((1/2), Ret(Unit))), a0, Ret(Unit)):
t5s := Weight((1/2), Ret(Unit)):
t6 := Ret(5):
t7 := Bind(Uniform(0, 1), a0,
  Bind(Msum(Weight((a0+1), Ret(Unit))), a1, Ret((a0*a0)))):
t7s := Bind(Uniform(0,1),a3,Weight(a3+1,Ret(a3^2))):
t7n := Bind(Uniform((-1), 0), a0,
  Bind(Msum(Weight((a0+1), Ret(Unit))), a1, Ret((a0*a0)))):
t7ns := Bind(Uniform(-1,0),a3,Weight(a3+1,Ret(a3^2))):
t8 := Bind(Gaussian(0, 10), a0, Bind(Gaussian(a0, 20), a1, Ret(Pair(a0, a1)))):
t9 := Bind(Lebesgue(-infinity,infinity), a0,
  Bind(Msum(Weight(piecewise(And((3<a0), (a0<7)), (1/2), 0), Ret(Unit))), a1, Ret(a0))):
t9a := Bind(Lebesgue(-infinity,infinity), a0,
  piecewise(3>=a0, Msum(), a0>=7, Msum(), Weight(1/2, Ret(a0)))):
t9s := Weight(2, Uniform(3,7)):

#t23, "bayesNet", to show exact inference.  Original used bern, which
# is here expanded in terms of MSum.
t23 :=
  Bind(Msum(Weight((1/2), Ret(true)), Weight((1-(1/2)), Ret(false))), a0,
  Bind(Msum(Weight(piecewise(a0 = true, (9/10), (1/10)), Ret(true)),
            Weight((1-piecewise(a0 = true, (9/10), (1/10))), Ret(false))), a1,
  Bind(Msum(Weight(piecewise(a0 = true, (9/10), (1/10)), Ret(true)),
            Weight((1-piecewise(a0 = true, (9/10), (1/10))), Ret(false))), a2,
  Ret(Pair(a1, a2))))):
t23s := Msum(Weight(41/100,Ret(Pair(true,true))),
             Weight(9/100,Ret(Pair(true,false))),
             Weight(9/100,Ret(Pair(false,true))),
             Weight(41/100,Ret(Pair(false,false)))):

# to exercise myint_pw
model_pw := Bind(Uniform(0,4), x,
  piecewise(x<1, Ret(x), x<2, Ret(2*x), x<3, Ret(3*x), Ret(5*x))):
model_pw1 := { Bind(Uniform(0,4), x,
  piecewise(x<1, Ret(x), x<2, Ret(2*x), x<3, Ret(3*x), 3<x, Ret(5*x))),
               Bind(Uniform(0,4),`x`,
  piecewise(x<1, Ret(x), 1<=x and x<2, Ret(2*x), 2<=x and x<3, Ret(3*x),3 <= x,Ret(5*x)))
}:
model_pw2 := Bind(Uniform(0,4), x, Weight(piecewise(x<1, 1, x<2, 2, x<3, 3, 5),Ret(x))):
model_pw3 := Bind(Uniform(0,4), x,
  piecewise(x<1, Ret(x), x<2, Weight(2,Ret(x)), x<3, Weight(3,Ret(x)), x>=3, Weight(5,Ret(x)))):
model_pw3_r := { Bind(Uniform(0,4), x,
  piecewise(x<1, Ret(x), x<2, Weight(2,Ret(x)), x<3, Weight(3,Ret(x)), x>=3, Weight(5,Ret(x)))) ,
               Bind(Uniform(0,4),x,
  piecewise(x < 1,Ret(x),1 <= x and x < 2,Weight(2,Ret(x)),2 <= x and x < 3,Weight(3,Ret(x)),3 <= x,Weight(5,Ret(x))))
}:
model_pw5 := Bind(Uniform(0,4), x, Weight(piecewise(x<1, 1, x<2, 2, x<3, 3, x>=3, 5),Ret(x))):
TestHakaru(model_pw , model_pw1, label = "multi-branch choice");
TestHakaru(model_pw3, model_pw3_r, label = "fake multi-branch weight");
TestHakaru(model_pw2, model_pw5, label = "proper multi-branch weight");

fake_pw1 := Bind(Uniform(1,3),x, piecewise(0 < x, Msum(), Ret(x))):
fake_pw2 := Bind(Uniform(1,3),x, piecewise(x < 0, Ret(x), Msum())):
TestHakaru(fake_pw1, Msum(), label = "fake piecewise 1"):
TestHakaru(fake_pw2, Msum(), label = "fake piecewise 2"):

# t43 without the explicit lam
t43 := piecewise(x0=true, Uniform(0, 1), Bind(BetaD(1, 1), a1, Ret(a1))):
t43s := Uniform(0, 1):

t80 := Bind(GammaD(1, 1), a0, Gaussian(0, a0)):

TestHakaru(t1, t5s, label = "t1");
TestHakaru(t2, t2s, label = "t2");
TestHakaru(t3, t3, label = "t3");
TestHakaru(t4, t4s, label = "t4");
TestHakaru(t5, t5s, label = "t5");
TestHakaru(t6, t6, label = "t6");
TestHakaru(t7, t7s, label = "t7");
TestHakaru(t7n, t7ns, label = "t7n");
TestHakaru(t8, t8, label = "t8");
TestHakaru(t9, t9s, label = "t9");
TestHakaru(t9a, t9s, label = "t9a");
TestHakaru(t23, t23s, label = "t23");
TestHakaru(t43, t43s, label = "t43"):

TestHakaru(t80, t80, label = "t80");

## based on https://github.com/hakaru-dev/hakaru/issues/60
module()
  local kb, clamp_t, clamp_r;
  kb := [y::real]:
  clamp_t :=
    Bind(Gaussian(0,1),x,
         Partition(And(0<y,y<density[Gaussian](0,1)(x)),
                   Weight(density[Uniform](0,density[Gaussian](0,1)(x))(y),
                          Ret(x)),
                   Msum())):
  clamp_r :=
    Partition(And(0<y, y<density[Gaussian](0,1)(0)),
              Weight(2 * sqrt(-ln(2)-ln(Pi)-2*ln(y)),
                     Uniform(-sqrt(-ln(2)-ln(Pi)-2*ln(y)),
                             sqrt(-ln(2)-ln(Pi)-2*ln(y)))),
              Msum()):
  TestHakaru( clamp_t, clamp_r, ctx=kb, label="clamp condition to move it out of integral" ):
end module:

###
# From disintegration paper
disint1 :=
Bind(Lebesgue(-infinity,infinity),y, Weight(piecewise(0<y and y<1, 1, 0), Weight(y/2, Ret(y)))):

TestHakaru(disint1, Weight(1/4,BetaD(2,1)), label="minor miracle");

ind1  := Bind(Uniform(0,1),x, Weight(piecewise(x>0,1,0), Weight(piecewise(x>1/2,0,1), Weight(piecewise(0<x,1,0), Ret(x))))):
ind1s := Weight(1/2, Uniform(0,1/2)):
ind2  := Bind(Lebesgue(-infinity,infinity),x, Weight(piecewise(x<0,0,x<1,x,0), Ret(x))):
ind2s := Weight(1/2, BetaD(2,1)):
ind3  := Bind(Uniform(0,1),x, Weight(piecewise(1<x and x<0,1,0), Ret(x))):
ind3s := Msum():
TestHakaru(ind1, ind1s, label="exponentiated indicator");
TestHakaru(ind2, ind2s, label="negated and conjoined indicator");
TestHakaru(ind3, ind3s, label="bounds ordering");
TestHakaru(Msum(ind1,ind2), Msum(ind1s,ind2s), label="simplify under sum");
TestHakaru(piecewise(c>0,ind1,ind2), piecewise(c>0,ind1s,ind2s), label="simplify under piecewise");

# test how banish handles piecewise
m1 := Uniform(0,1):
m2 := BetaD(2,1):
m3 := BetaD(1,2):
bp := proc() Bind(Gaussian(0,1), x,
             Bind(Gaussian(0,1), y,
             piecewise(_passed))) end proc:
TestHakaru(bp(x>y, m1, m2         ), Msum(Weight(1/2, m1), Weight(1/2, m2)                 ), label="banish piecewise 1");
TestHakaru(bp(x>0, m1, m2         ), Msum(Weight(1/2, m1), Weight(1/2, m2)                 ), label="banish piecewise 2");
TestHakaru(bp(y>0, m1, m2         ), Msum(Weight(1/2, m1), Weight(1/2, m2)                 ), label="banish piecewise 3");
TestHakaru(bp(x>y, m1, x>0, m2, m3), Msum(Weight(1/2, m1), Weight(1/8, m2), Weight(3/8, m3)), label="banish piecewise 4");
TestHakaru(bp(x>0, m1, x>y, m2, m3), Msum(Weight(1/2, m1), Weight(1/8, m2), Weight(3/8, m3)), label="banish piecewise 5");
TestHakaru(bp(y>x, m1, y>0, m2, m3), Msum(Weight(1/2, m1), Weight(1/8, m2), Weight(3/8, m3)), label="banish piecewise 6");
TestHakaru(bp(y>0, m1, y>x, m2, m3), Msum(Weight(1/2, m1), Weight(1/8, m2), Weight(3/8, m3)), label="banish piecewise 7");

# Simplify is not yet idempotent
TestHakaru(Bind(Uniform(0,1), x, Weight(x, Uniform(0,x))), Weight(1/2, BetaD(1, 2)));

# Test for change of variables; see Tests/Relationships.hs
# t1
# cv1 := Bind(Gaussian(mu, sigma), x, Ret((x-mu)/sigma)):
# cv1s := Gaussian(0,1):
# TestHakaru(cv1, cv1s, ctx = [sigma>0], label = "renormalize Gaussian");

# t28
# cv2 := Bind(BetaD(a,b), x, Ret(1-x)):
# cv2s := BetaD(b,a):
# TestHakaru(cv2, cv2s, ctx=[a>0,b>0], label = "swap BetaD");

unk_pw := Bind(m, y, Bind(Gaussian(0,1), x, piecewise(x<0, Ret(-x), Ret(x)))):
unk1   := Bind(Gaussian(0,1), x, Bind(m, y, Bind(Gaussian(x,1), z, Ret([y,z])))):
unk1s  := Bind(m, y, Bind(Gaussian(0,sqrt(2)), z, Ret([y,z]))):
unk2   := Bind(Gaussian(0,1), x, Bind(Gaussian(x,1), z, Bind(m, y, Ret([y,z])))):
unk2s  := Bind(Gaussian(0,sqrt(2)), z, Bind(m, y, Ret([y,z]))):
unk3   := Bind(Gaussian(0,1), x, Bind(m(x), y, Bind(Gaussian(x,1), z, Ret([y,z])))):
unk4   := Bind(Gaussian(0,1), x, Bind(Gaussian(x,1), z, Bind(m(x), y, Ret([y,z])))):
TestHakaru(unk_pw, unk_pw, label="Don't simplify Integrand willy-nilly");
TestHakaru(unk1, unk1s, label="Banish into Integrand 1");
TestHakaru(unk2, unk2s, label="Banish into Integrand 2");
TestHakaru(unk3, unk3, label="Banish into Integrand 3");
TestHakaru(unk4, unk4, label="Banish into Integrand 4");

# Disintegration of easierRoadmapProg1 -- variables to be integrated out
rmProg1 := Msum(Weight(1, Msum(Weight(1, Msum(Weight(1, Msum(Weight(1, Bind(Lebesgue(-infinity,infinity), a4, Msum(Weight(1, Msum(Weight(1, Bind(Lebesgue(-infinity,infinity), a5, Msum(Weight(1, Bind(Lebesgue(-infinity,infinity), a6, Msum(Weight(((exp((-(((p3-a6)*(p3-a6))*(1/(2*exp((ln(a5)*2)))))))*(1/a5))*(1/exp((ln((2*Pi))*(1/2))))), Msum(Weight(1, Bind(Lebesgue(-infinity,infinity), a7, Msum(Weight(((exp((-(((a6-a7)*(a6-a7))*(1/(2*exp((ln(a4)*2)))))))*(1/a4))*(1/exp((ln((2*Pi))*(1/2))))), Msum(Weight(((exp((-(((p2-a7)*(p2-a7))*(1/(2*exp((ln(a5)*2)))))))*(1/a5))*(1/exp((ln((2*Pi))*(1/2))))), Msum(Weight(((exp((-((a7*a7)*(1/(2*exp((ln(a4)*2)))))))*(1/a4))*(1/exp((ln((2*Pi))*(1/2))))), Msum(Weight((1/3), Msum(Weight(1, piecewise((a5<4), piecewise((1<a5), Msum(Weight((1/5), Msum(Weight(1, piecewise((a4<8), piecewise((3<a4), Ret(Pair(a4, a5)), Msum()), Msum())), Weight(1, Msum())))), Msum()), Msum())), Weight(1, Msum())))))))))))))))))))))), Weight(1, Msum())))))), Weight(1, Msum())))))):
rmProg1_w := Weight(exp(-(1/2)*(2*p2^2*a4^2+p2^2*a5^2-2*p2*p3*a4^2+p3^2*a4^2+p3^2*a5^2)/(a4^4+3*a4^2*a5^2+a5^4))/sqrt(a4^4+3*a4^2*a5^2+a5^4), Ret(Pair(a4, a5))):
rmProg1_r := {
Weight(1/(2*Pi), Bind(Uniform(1, 4), a5, Bind(Uniform(3, 8), a4, rmProg1_w))),
Weight(1/(2*Pi), Bind(Uniform(3, 8), a4, Bind(Uniform(1, 4), a5, rmProg1_w)))}:
TestHakaru(rmProg1, rmProg1_r, label="Tests.RoundTrip.rmProg1");
# easierRoadmapProg4 -- MH transition kernel with unclamped acceptance ratio
module()
  local unpair, fst, snd, rmProg4;
  unpair := proc(f,p)
    f(fst(p),snd(p))
  end proc;
  fst := proc(p, $)
    if p :: Pair(anything,anything) then op(1,p)
    elif p :: 't_piecewiselike' then map_piecewiselike(procname, _passed)
    else 'procname(_passed)' end if
  end proc:
  snd := proc(p, $)
    if p :: Pair(anything,anything) then op(2,p)
    elif p :: 't_piecewiselike' then map_piecewiselike(procname, _passed)
    else 'procname(_passed)' end if
  end proc:
  rmProg4 := lam(x0,blah, app(lam(x1,blah, lam(x2,blah, Bind(unpair(( (p3 , p4) -> Msum(Weight((1/2), Bind(Uniform(3, 8), a5, Ret(Pair(a5, p4)))), Weight((1/2), Bind(Uniform(1, 4), a6, Ret(Pair(p3, a6)))))), x2), a7, Ret(Pair(a7, (app(x1,a7)/app(x1,x2))))))),lam(x8,blah, unpair(( (p151 , p152) -> app(p152,lam(x153,blah, 1))), app(app(lam(x9,blah, lam(x10,blah, unpair(( (p11 , p12) -> app(lam(x13,blah, app(lam(x14,blah, Pair(Msum(Weight(x13, unpair(( (p15 , p16) -> p15), x14))), lam(x17,blah, (0+(x13*app(unpair(( (p18 , p19) -> p19), x14),x17)))))),app(lam(x20,blah, app(lam(x21,blah, Pair(Msum(Weight(x20, unpair(( (p22 , p23) -> p22), x21))), lam(x24,blah, (0+(x20*app(unpair(( (p25 , p26) -> p26), x21),x24)))))),app(lam(x27,blah, app(lam(x28,blah, app(lam(x29,blah, app(lam(x30,blah, Pair(Msum(Weight(x27, unpair(( (p31 , p32) -> p31), x28)), Weight(x29, unpair(( (p33 , p34) -> p33), x30))), lam(x35,blah, ((0+(x27*app(unpair(( (p36 , p37) -> p37), x28),x35)))+(x29*app(unpair(( (p38 , p39) -> p39), x30),x35)))))),Pair(Msum(), lam(x40,blah, 0)))),1)),app(lam(x41,blah, app(lam(x42,blah, Pair(Msum(Weight(x41, unpair(( (p43 , p44) -> p43), x42))), lam(x45,blah, (0+(x41*app(unpair(( (p46 , p47) -> p47), x42),x45)))))),app(lam(x48,blah, app(lam(x49,blah, app(lam(x50,blah, app(lam(x51,blah, Pair(Msum(Weight(x48, unpair(( (p52 , p53) -> p52), x49)), Weight(x50, unpair(( (p54 , p55) -> p54), x51))), lam(x56,blah, ((0+(x48*app(unpair(( (p57 , p58) -> p58), x49),x56)))+(x50*app(unpair(( (p59 , p60) -> p60), x51),x56)))))),Pair(Msum(), lam(x61,blah, 0)))),1)),app(lam(x62,blah, app(lam(x63,blah, Pair(Msum(Weight(x62, unpair(( (p64 , p65) -> p64), x63))), lam(x66,blah, (0+(x62*app(unpair(( (p67 , p68) -> p68), x63),x66)))))),unpair(( (p69 , p70) -> unpair(( (p71 , p72) -> unpair(( (p73 , p74) -> unpair(( (p75 , p76) -> unpair(( (p77 , p78) -> unpair(( (p79 , p80) -> unpair(( (p81 , p82) -> unpair(( (p83 , p84) -> unpair(( (p85 , p86) -> unpair(( (p87 , p88) -> app(lam(x89,blah, app(lam(x90,blah, Pair(Msum(Weight(x89, unpair(( (p91 , p92) -> p91), x90))), lam(x93,blah, (0+(x89*app(unpair(( (p94 , p95) -> p95), x90),x93)))))),app(lam(x96,blah, app(lam(x97,blah, Pair(Msum(Weight(x96, unpair(( (p98 , p99) -> p98), x97))), lam(x100,blah, (0+(x96*app(unpair(( (p101 , p102) -> p102), x97),x100)))))),app(lam(x103,blah, app(lam(x104,blah, app(lam(x105,blah, app(lam(x106,blah, Pair(Msum(Weight(x103, unpair(( (p107 , p108) -> p107), x104)), Weight(x105, unpair(( (p109 , p110) -> p109), x106))), lam(x111,blah, ((0+(x103*app(unpair(( (p112 , p113) -> p113), x104),x111)))+(x105*app(unpair(( (p114 , p115) -> p115), x106),x111)))))),Pair(Msum(), lam(x116,blah, 0)))),1)),piecewise((p12<4), piecewise((1<p12), app(lam(x117,blah, app(lam(x118,blah, Pair(Msum(Weight(x117, unpair(( (p119 , p120) -> p119), x118))), lam(x121,blah, (0+(x117*app(unpair(( (p122 , p123) -> p123), x118),x121)))))),app(lam(x124,blah, app(lam(x125,blah, app(lam(x126,blah, app(lam(x127,blah, Pair(Msum(Weight(x124, unpair(( (p128 , p129) -> p128), x125)), Weight(x126, unpair(( (p130 , p131) -> p130), x127))), lam(x132,blah, ((0+(x124*app(unpair(( (p133 , p134) -> p134), x125),x132)))+(x126*app(unpair(( (p135 , p136) -> p136), x127),x132)))))),Pair(Msum(), lam(x137,blah, 0)))),1)),piecewise((p11<8), piecewise((3<p11), app(lam(x138,blah, app(lam(x139,blah, Pair(Msum(Weight(x138, unpair(( (p140 , p141) -> p140), x139))), lam(x142,blah, (0+(x138*app(unpair(( (p143 , p144) -> p144), x139),x142)))))),app(lam(x145,blah, Pair(Ret(x145), lam(x146,blah, app(x146,x145)))),Pair(p11, p12)))),5), Pair(Msum(), lam(x147,blah, 0))), Pair(Msum(), lam(x148,blah, 0))))),1))),(1/5)), Pair(Msum(), lam(x149,blah, 0))), Pair(Msum(), lam(x150,blah, 0))))),1))),(1/3)))),((((1/Pi)*exp((((((((((p69*p71)*(p11*p11))*2)+((((p11*p11)*p73)*p76)*(-2)))+((p78*p80)*(p11*p11)))+((p12*p12)*(p81*p83)))+((p12*p12)*(p86*p88)))*(1/((((p11*p11)*(p11*p11))+(((p12*p12)*(p11*p11))*3))+((p12*p12)*(p12*p12)))))*(-(1/2)))))*exp((ln(((exp(((x -> piecewise(x<0, -337, ln(x)))(p11)*4))+((exp(((x -> piecewise(x<0, -337, ln(x)))(p12)*2))*exp(((x -> piecewise(x<0, -337, ln(x)))(p11)*2)))*3))+exp(((x -> piecewise(x<0, -337, ln(x)))(p12)*4))))*(-(1/2)))))*(1/10)))), x9)), x9)), x9)), x9)), x9)), x9)), x9)), x9)), x9)), x9))),1))),1))),1))),1))),1))),1)), x10))),x0),x8))))):
  TestHakaru(app(app(rmProg4,Pair(r1,r2)),Pair(p1,p2)), Msum(Weight(1/2, Bind(Uniform(3, 8), a5, Ret(Pair(Pair(a5, p2), exp((1/2)*(-p1+a5)*(a5+p1)*(p1^2*p2^2*r1^2+p1^2*p2^2*r2^2+2*p1^2*r1^2*a5^2-2*p1^2*r1*r2*a5^2+p1^2*r2^2*a5^2+p2^4*r1^2+2*p2^4*r1*r2+2*p2^4*r2^2+p2^2*r1^2*a5^2+p2^2*r2^2*a5^2)/((p2^4+3*p2^2*a5^2+a5^4)*(p1^4+3*p1^2*p2^2+p2^4)))*sqrt(p1^4+3*p1^2*p2^2+p2^4)/sqrt(p2^4+3*p2^2*a5^2+a5^4))))), Weight(1/2, Bind(Uniform(1, 4), a6, Ret(Pair(Pair(p1, a6), exp((1/2)*(-p2+a6)*(a6+p2)*(5*p1^4*r1^2-6*p1^4*r1*r2+2*p1^4*r2^2+2*p1^2*p2^2*r1^2-2*p1^2*p2^2*r1*r2+p1^2*p2^2*r2^2+2*p1^2*r1^2*a6^2-2*p1^2*r1*r2*a6^2+p1^2*r2^2*a6^2+p2^2*r1^2*a6^2+p2^2*r2^2*a6^2)/((p1^4+3*p1^2*a6^2+a6^4)*(p1^4+3*p1^2*p2^2+p2^4)))*sqrt(p1^4+3*p1^2*p2^2+p2^4)/sqrt(p1^4+3*p1^2*a6^2+a6^4)))))),
  label="rmProg4",
  ctx= [3<p1, p1<8, 1<p2, p2<4]);
end module:

#####################################################################
#
# conjugacy tests
#
#####################################################################
gaussian_gaussian   := Bind(Gaussian(mu0,sigma0),mu, Weight(NewSLO:-density[Gaussian](mu,sigma1)(x), Ret(mu))):
gaussian_gaussian_s := Weight((1/2)*sqrt(2)*exp(-(1/2)*(mu0-x)^2/(sigma0^2+sigma1^2))/(sqrt(Pi)*sqrt(sigma0^2+sigma1^2)), Gaussian((mu0*sigma1^2+sigma0^2*x)/(sigma0^2+sigma1^2), sigma0*sigma1/sqrt(sigma0^2+sigma1^2))):
TestHakaru(gaussian_gaussian, gaussian_gaussian_s,
  label="gaussian_gaussian conjugacy",
  ctx = [mu0::real, sigma0>0, sigma1>0, x::real]);
invgamma_gaussian   := Bind(GammaD(shape,scale),lambda, Weight(NewSLO:-density[Gaussian](mu,lambda^(-1/2))(x), Ret(lambda))):
invgamma_gaussian_s := Weight(GAMMA(1/2+shape)*sqrt(scale)*((1/2)*scale*mu^2-scale*mu*x+(1/2)*scale*x^2+1)^(-shape)/(GAMMA(shape)*sqrt(scale*mu^2-2*scale*mu*x+scale*x^2+2)*sqrt(Pi)), GammaD(1/2+shape, 2*scale/(scale*mu^2-2*scale*mu*x+scale*x^2+2))):
TestHakaru(invgamma_gaussian, invgamma_gaussian_s,
  label="invgamma_gaussian conjugacy",
  ctx = [mu::real, shape>0, scale>0, x::real]);
gaussian_invgamma_gaussian   := Bind(GammaD(shape,scale),tau, Bind(Gaussian(mu0*sqrt(tau),1/sqrt(nu)),mu, Weight(NewSLO:-density[Gaussian](mu*tau^(-1/2),tau^(-1/2))(x), Ret([mu,tau])))):
gaussian_invgamma_gaussian_s := Weight(GAMMA(1/2+shape)*sqrt(nu)*sqrt(scale)*(scale*mu0^2*nu-2*scale*mu0*nu*x+scale*nu*x^2+2*nu+2)^(-1/2-shape)*(2*nu+2)^shape/(GAMMA(shape)*sqrt(Pi)), Bind(GammaD(1/2+shape, 2*scale*(nu+1)/(scale*mu0^2*nu-2*scale*mu0*nu*x+scale*nu*x^2+2*nu+2)),tau, Bind(Gaussian(sqrt(tau)*(mu0*nu+x)/(nu+1), 1/sqrt(nu+1)),mu, Ret([mu,tau])))):
TestHakaru(gaussian_invgamma_gaussian, gaussian_invgamma_gaussian_s,
  label="gaussian_invgamma_gaussian conjugacy",
  ctx = [mu0::real, nu>0, shape>0, scale>0, x::real]);
gamma_gamma   := Bind(GammaD(alpha0,1/beta0),beta, Weight(NewSLO:-density[GammaD](alpha,1/beta)(x), Ret(beta))):
gamma_gamma_s := Weight(beta0^alpha0*x^(alpha-1)*GAMMA(alpha+alpha0)*(beta0+x)^(-alpha-alpha0)/(GAMMA(alpha0)*GAMMA(alpha)), GammaD(alpha+alpha0, 1/(beta0+x))):
TestHakaru(gamma_gamma, gamma_gamma_s, label="gamma_gamma conjugacy",
  ctx = [alpha0>0, beta0>0, alpha>0, x>0]);
gamma_poisson   := Bind(GammaD(shape,scale),lambda, Weight(NewSLO:-density[PoissonD](lambda)(k), Ret(lambda))):
gamma_poisson_s := Weight(scale^k*(scale+1)^(-k-shape)*GAMMA(k+shape)/(GAMMA(shape)*GAMMA(k+1)), GammaD(k+shape, scale/(scale+1))):
TestHakaru(gamma_poisson, gamma_poisson_s, label="gamma_poisson conjugacy",
           ctx=[shape>0, scale>0, k::nonnegint]);

# For the following test, banishing fails because Maple currently evaluates
#   int(piecewise(x < y, 1/(1-x), 0), x = 0 .. 1) assuming y<1
# to "undefined".  (See ppaml-l discussion "NewSLO giving weird output"
# around 2015-12-10.)  The test is that we handle the failure gracefully.
TestHakaru(Bind(Uniform(0,1), x, Uniform(x,1)),
          {Bind(Uniform(0,1), x, Uniform(x,1)),
           Bind(Uniform(0,1), x, Weight(ln(1/(1-x)), Ret(x)))},
  label="roundtrip despite banishing failure");

TestHakaru(Bind(Ret(ary(n,i,i*2)), v, Ret(idx(v,42))), Ret(84), label="basic array indexing");

#####################################################################
#
# Tests for type-directed simplification
#
#####################################################################

module()
  local hpair, hbool,         heither,       hreal, hprob,
        ppair, ptrue, pfalse, pleft, pright,
        dpair, dtrue, dfalse, dleft, dright,
        unpair;
  uses CodeTools;
  hpair   := (t1,t2) -> HData(DatumStruct(pair,[Konst(t1),Konst(t2)])):
  hbool   := HData(DatumStruct(true,[]),DatumStruct(false,[])):
  heither := (t1,t2) -> HData(DatumStruct(left,[Konst(t1)]),DatumStruct(right,[Konst(t2)])):
  hreal   := HReal():
  hprob   := HReal(Bound(`>=`,0)):
  ppair   := (p1,p2) -> PDatum(pair,PInl(PEt(p1,PEt(p2,PDone)))):
  ptrue   := PDatum(true,PInl(PDone)):
  pfalse  := PDatum(false,PInr(PInl(PDone))):
  pleft   := p -> PDatum(left,PInl(PEt(p,PDone))):
  pright  := p -> PDatum(right,PInr(PInl(PEt(p,PDone)))):
  dpair   := (d1,d2) -> Datum(pair,Inl(Et(d1,Et(d2,Done)))):
  dtrue   := Datum(true,Inl(Done)):
  dfalse  := Datum(false,Inr(Inl(Done))):
  dleft   := d -> Datum(left,Inl(Et(d,Done))):
  dright  := d -> Datum(right,Inr(Inl(Et(d,Done)))):
  unpair  := (e1,x,y,e0) -> case(e1,Branches(Branch(ppair(PVar(x),PVar(y)),e0))):
  TestSimplify(lam(pr,hpair(hprob,hreal),unpair(pr,x,y,sqrt(x^2)+y)),
               HFunction(hpair(hprob,hreal),hreal),
               lam(pr,hpair(hprob,hreal),unpair(pr,x,y,x+y)),
               label="Transfer function argument type to KB");
  TestSimplify(lam(b,hbool,case(b,Branches(Branch(pfalse,3),Branch(ptrue,4)))),
               HFunction(hbool,HInt()),
               lam(b,hbool,case(b,Branches(Branch(ptrue,4),Branch(pfalse,3)))),
               label="Eta-expand pure function from boolean");
  TestSimplify(lam(pr,hpair(hbool,hbool),unpair(pr,x,y,dpair(y,x))),
               HFunction(hpair(hbool,hbool), hpair(hbool,hbool)),
               lam(pr,hpair(hbool,hbool),case(pr,Branches(
                 Branch(ppair(ptrue ,ptrue ), dpair(dtrue ,dtrue )),
                 Branch(ppair(ptrue ,pfalse), dpair(dfalse,dtrue )),
                 Branch(ppair(pfalse,ptrue ), dpair(dtrue ,dfalse)),
                 Branch(ppair(pfalse,pfalse), dpair(dfalse,dfalse))))),
               label="Eta-expand pure function from pair of booleans");
  TestSimplify(lam(b,hbool,
                     Bind(Uniform(0,1),p,
                     Weight(case(b,Branches(Branch(pfalse,1-p),
                                            Branch(ptrue,p))),
                     Ret(p)))),
               HFunction(hbool,HMeasure(hreal)),
               lam(b,hbool,
                     case(b,Branches(Branch(ptrue , Weight(1/2,BetaD(2,1))),
                                     Branch(pfalse, Weight(1/2,BetaD(1,2)))))),
               label="Eta-expand function from boolean to measure");
end module:

###########
#
# RoundTrip tests; due to bug in CodeTest, use lower-level function directly

TestTools:-SetRecord(false):
module()
  local kb, rt1, rt1r;
  kb := [x::real]:
  rt1 := Context(kb, Bind(Gaussian(0,1), x, Ret(0))):
  rt1r := sprintf("%a", eval(ToInert(Context(kb, Ret(0))), _Inert_ATTRIBUTE=NULL)):
  TestTools:-Try("simple case of RoundTrip", RoundTrip(rt1), rt1r);
end module:

# Categorical distribution
TestHakaru(Counting(0,11),
           label="Counting roundtrip");
TestHakaru(Bind(Counting(0,2),x,Weight(p^x*(1-p)^(1-x),Ret(x))),
           Categorical([1-p,p]),
           label="Categorical introduction",
           ctx=[0<=p, p<=1]);
TestHakaru(Bind(Categorical([p,1-p]),x,Weight(p^x*(1-p)^(1-x),Ret(x))),
           Weight(p*(1-p),Counting(0,2)),
           label="Categorical elimination",
           ctx=[0<=p, p<=1]);
module()
  local bern, burglary;
  bern := p -> Bind(Categorical(ary(2,i,piecewise(i=0,p,1-p))), i, Ret(i=0)):
  burglary := Bind(bern(1/10000), b,
              Bind(bern(piecewise(b=true,19/20,1/100)), a,
              Ret(a))):
  TestHakaru(burglary, bern(5047/500000), label="burglary");
  TestHakaru(Bind(BetaD(alpha,beta), p, bern(p)),
             Weight(1/(alpha+beta), Bind(Categorical([alpha,beta]), i, Ret(i=0))),
             label="integrate BetaD out of BetaD-Bernoulli"):
end module:


read "../ComputeIdentifiableFunctions.mpl";

cases := [
    [
        [
            diff(x1(t), t) = (a * x1(t) - b * x1(t) * x2(t) + u(t)),
            diff(x2(t), t) = (-c * x2(t) + d * x1(t) * x2(t)),
            y(t) = x1(t)
        ], [1, {a, c, d}]
    ],
    [
        [
            diff(xa(t), t) = k1 * xa(t),
            diff(xb(t), t) = k1 * xa(t) - k2 * xb(t),
            diff(xc(t), t) = k2 * xb(t),
            diff(eA(t), t) = 0,
            diff(eC(t), t) = 0,
            y1(t) = eA(t) * xa(t) + eB * xb(t) + eC(t) * xc(t),
            y2(t) = xc(t),
            y3(t) = eA(t),
            y4(t) = eC(t)
        ], [2, {k1, k2, eB}]
    ]
]:

num_passed := 0:
num_failed := 0:

for case in cases do
    input := case[1]:
    correct := case[2]:
    result := MultiExperimentIdentifiableFunctions(input, infolevel=0, simplified_generators=true):
    if CompareFields(result[3], correct[2]) and result[1] = correct[1] then
        printf("PASSED\n");
        num_passed := num_passed + 1:
    else
        num_failed := num_failed + 1:
        printf("FAILED\n");
        printf("Expected %a, got %a", correct, result);
    end if:
end do:

printf("Passed: %a, failed %a \n", num_passed, num_failed);


######################################################################
# W(N)(A) is Map(A,R^N)/Const(A,R^N).
#
# Elements are represented as tables indexed by A, whose values
# are lists of length N of real numbers.  The equivalence relation
# is built into the definition of the function `is_equal/W` rather
# than the representation of the elements.

`is_element/W` := (N::posint) -> (A::set) -> proc(x)
 `is_element/vector_functions`(N)(A)(x);
end;

######################################################################

`normalise/W` := (N::posint) -> (A::set) -> proc(x)
 local x0,u,a;

 x0 := table();
 u := [0$N];

 for a in A do
  x0[a] := x[a];
  u := u +~ x[a];
 od;
 u := u /~ nops(A);
 for a in A do
  x0[a] := x0[a] -~ u;
 od;
 return(eval(x0));
end;

######################################################################

`bottom_normalise/W` := (N::posint) -> (A::set) -> proc(x)
 local x0,u,a,i;

 u := [seq(min(seq(x[a][i],a in A)),i=1..N)];
 x0 := table():
 for a in A do
  x0[a] := x[a] -~ u;
 od:
 return(eval(x0));
end;

######################################################################

`is_equal/W` := (N::posint) -> (A::set) -> proc(x,y)
 local x0,y0,a;

 x0 := `normalise/W`(N)(A)(x);
 y0 := `normalise/W`(N)(A)(y);

 return `is_equal/vector_functions`(N)(A)(x0,y0);
end;

######################################################################

`is_leq/W` := NULL;

######################################################################

`is_zero/W` := (N::posint) -> (A::set) -> proc(x)
 local x0,a;

 x0 := `normalise/W`(N)(A)(x);
 return `is_zero/vector_functions`(N)(A)(x0);
end;

######################################################################

`norm/W` := (N::posint) -> (A::set) -> proc(x)
 local x0,a;

 x0 := `normalise/W`(N)(A)(x);
 return `norm/vector_functions`(N)(A)(x0);
end;

######################################################################

`width/W` := (N::posint) -> (A::set) -> proc(x)
 local i,a;
 max(seq(max(seq(x[a][i],a in A)) -  min(seq(x[a][i],a in A)),i=1..N));
end;

######################################################################

`random_element/W` := (N::posint) -> (A::set) -> proc()
 local x,a,u;

 u := [0$N];
 x := table();
 for a in A do
  x[a] := `random_element/R`(N)();
  u := u +~ x[a];
 od:
 u := u /~ nops(A);
 for a in A do
  x[a] := x[a] -~ u;
 od;

 return eval(x);
end;

`list_elements/W` := NULL;
`count_elements/W` := NULL;

######################################################################
# Here C is assumed to be a subset of B, and rho is the usual map
# from W(N,B) to W(N,C).

`rho/W` := (B,C) -> proc(x)
 local y,c;

 y := table();
 for c in C do y[c] := x[c]; od;
 return eval(y);
end;


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: gga_exc *)

a := -1:
b := 11.8:
c :=  0.150670:
d := 11.02e-3/RS_FACTOR:

(* I added an abs() to this equation, as otherwise the f_num is
   complex for negative values of z. Of course it is not clear at all
   what was the original intential of Wilson, or if he even considered
   this problem. *)
if evalb(Polarization = "unpol") then
    f_num := z -> a:
else
    (* without the max function we get a float exception for derivatives > 2 *)
    f_num := z -> a*sqrt(1 -  m_max(m_abs(z), 1e-10)^(5/3)):
end if:
f_den := (rs, xt) -> b + c*xt^(51/16) + d*xt^2*rs + rs:

(* Equation (25) *)
f := (rs, z, xt, xs0, xs1) ->
  f_num(z)/f_den(rs, xt):


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: gga_exc *)
(* prefix:
  gga_x_hjs_params *params;

  assert(p->params != NULL);
  params = (gga_x_hjs_params * )(p->params);
*)

$include "gga_x_hjs.mpl"

hjs2_xi := 1/(exp(20) - 1):
hjs2_fs := s -> -log((exp(-s) + hjs2_xi)/(1 + hjs2_xi)):

hjs_fx := (rs, z, x) -> hjs_f1(rs, z, hjs2_fs(X2S*x)):


(* type: lda_exc *)

a :=  0.0311:
b := -0.048:
c :=  0.009:
d := -0.017:

f_ls := (rs, zeta) -> a*log(rs) + b + c*rs*log(rs) + d*rs:
f_ms := (rs, zeta) -> -0.06156 + 0.01898*log(rs):
f_hs := (rs, zeta) -> 0.438/rs + 1.325/rs^(3/2) - 1.47/rs^2 - 0.4/rs^(5/2):

f := (rs, zeta) -> my_piecewise3(
  rs < 0.7, f_ls(rs, zeta),  my_piecewise3(rs < 10,  f_ms(rs, zeta), f_hs(rs, zeta))):


# Proof by PDF that X <~ rayleigh(1/sqrt(2*lambda)) == X^2 <~ exponential(lambda)

PDF_rayleigh := (a, x) -> 2*x*exp(-x^2/a)/a;

PDF_transform := (x) -> PDF_rayleigh(1,sqrt(x))*diff(sqrt(x),x);
simplify(PDF_transform(x));

PDF_exponential := (l, x) -> l*exp(-l*x);
simplify(PDF_exponential(1, x));

evalb(PDF_exponential(1, x) = PDF_transform(x));


# Berechne kinematische Zwangsbedingungen für Viergelenkkette
# Einleitung

# Die impliziten kinematischen Zwangsbedingungen werden aufgestellt: Annahme : Alle MDH-Winkel seien unabhängig und die Kette sei offen
#
# fivebar1_OL -> Fünfgelenkkette, modellierung impliziten der Zwangsbedingungen mit Ausdrücken einer offenen Kette  und basierend auf der MDH-Tabelle.
# Bei Matlab: Abhängige Winkel durch die Ausdrücke von TE aus der Datei "fourbar1TE_kinconstr_expl_mdh_sym_varpar" ersetzen.
# Quelle
# SA Bejaoui: Bejaoui2018_S749; "Modellierung kinematischer Zwangsbedingungen für hybride serielle Roboter mit planaren Parallelmechanismen"
# Autor
# Abderahman Bejaoui
# Studienarbeit bei: Moritz Schappler, schappler@irt.uni-hannover.de, 2018-08
# (C) Institut fuer Mechatronische Systeme, Leibniz Universitaet Hannover
#
# Initialisierung
restart:
kin_constraints_exist := true: # Für Speicherung
;
with(StringTools): # Für Zeitausgabe
with(LinearAlgebra):
with(codegen):
with(CodeGeneration):
codegen_act := true:
codegen_opt := 1: # Geringerer Optimierungsgrad. Sonst zu lange.
codegen_debug := 0: # Zur Code-Generierung auch für Nicht-Inert-Ausdrücke
;
read "../helper/proc_MatlabExport":
read "../transformation/proc_rotx":
read "../transformation/proc_roty":
read "../transformation/proc_rotz":
read "../transformation/proc_trotz":
read "../transformation/proc_transl":
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
read "../helper/proc_intersect_circle":
with(RealDomain): # Schränkt alle Funktionen auf den reellen Bereich ein. Muss nach Definition von MatlabExport kommen. Sonst geht dieses nicht.
;
read "../robot_codegen_definitions/robot_env_IC":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name_OL):
# Ergebnisse der Kinematik laden
read sprintf("../codeexport/%s/tmp/kinematics_floatb_%s_rotmat_maple.m", robot_name_OL, base_method_name);
read "../robot_codegen_definitions/robot_env_IC":
Trf := Trf:
Trf_c := Trf_c:
Trf
;
# Fourbar1 0-3-4-5-6-2-1-0
# Schleife 0-1-2-4
T_0_5 := combine(Matrix(Trf(1..4,1..4, 3)) . Matrix(Trf(1..4,1..4,4)). Matrix(Trf(1..4,1..4, 5)));
# Schleife 0-3-5
T_0_6:= combine(Matrix(Trf(1..4,1..4, 1)) . Matrix(Trf(1..4,1..4,2)) . Matrix(Trf(1..4,1..4,6)));
h1t := T_0_6(1..3,4) - T_0_5(1..3,4);
tmp := Transpose( Matrix(T_0_6(1..3,1..3)) ) . Matrix(T_0_5(1..3,1..3));  # nur anzeigen lassen für h1r
;
 combine(tmp); # nur anzeigen lassen für h1r
;
h1r:=qJ1(t) + qJ2(t) - qJ3(t) - qJ4(t) - qJ5(t);
# Zusammenstellen aller Zwangsbedingungen
implconstr_t := <h1t([1, 2]);h1r>;
implconstr_s := convert_t_s(implconstr_t):
# Exportiere Code für folgende Skripte
kin_constraints_exist:=true:
save implconstr_t, implconstr_s, kin_constraints_exist, sprintf("../codeexport/%s/tmp/kinematic_constraints_implicit_maple.m", robot_name):
# Exportieren des vollständigen Ausdruckes
if codegen_act then
  MatlabExport(implconstr_s, sprintf("../codeexport/%s/tmp/kinconstr_impl_matlab.m", robot_name), 2):
end if:
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( implconstr_s )):
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_implicit_constraints_symbols_list_maple", robot_name):
MatlabExport(Transpose(kc_symbols), sprintf("../codeexport/%s/tmp/kinematic_implicit_constraints_symbols_list_matlab.m", robot_name), 2):


flat_torus_complex := proc(n::posint,m::posint)
 local f,g,T,V,E,F,R,r;

 f := (i) -> modp(i+1,n);
 g := (j) -> modp(j+1,m);

 V := [seq(seq([i,j],j=0..m-1),i=0..n-1)];
 E := [seq(seq([[i,j],[f(i),j]],j=0..m-1),i=0..n-1),
       seq(seq([[i,j],[i,g(j)]],j=0..m-1),i=0..n-1),
       seq(seq([[i,j],[f(i),g(j)]],j=0..m-1),i=0..n-1)];
 F := [seq(seq([[i,j],[f(i),j],[f(i),g(j)]],j=0..m-1),i=0..n-1),
       seq(seq([[i,j],[i,g(j)],[f(i),g(j)]],j=0..m-1),i=0..n-1)];

 T := table([]);

 T["vertices"] := V;
 T["edges"] := E;
 T["faces"] := F;
 T["max_simplices"] := F;
 T["simplices"] := [map(v -> [v],V),op(E),op(F)];

 R := 3;
 r := 1;

 T["embedding_dim"] := 3;
 T["embedding"] :=
  table([seq(seq([i,j] = evalf(torus_embedding(R,r)(i/n,j/m)),j=0..m-1),i=0..n-1)]);

 T["plot"] := `plot/simplicial_complex`(T["vertices"])(T["faces"],3,T["embedding"]);

 return eval(T);

end:


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: work_mgga_x *)

malpha := (x, t) -> (t - x^2/8)/K_FACTOR_C:

gx_cx0 := 4/3*(2/Pi)^(1/3):
gx_cx1 := X_FACTOR_C:

gx_c0 :=  0.827411:
gx_c1 := -0.643560:

gx_gx0 := a ->
  + gx_cx0/gx_cx1
  + a*(gx_c0 + gx_c1*a)/(1.0 + (gx_c0 + gx_c1 - 1)*a) * (1 - gx_cx0/gx_cx1):

gx_alphainf := 0.852:
gx_gx1 := a ->
  1 + (1 - gx_alphainf)*(1 - a)/(1 + a):

f_gx_a := a->
  + gx_gx0(a)*Heaviside(1 - a)
  + gx_gx1(a)*Heaviside(a - 1):

f := (rs, x, t, u) ->
  f_gx_a(malpha(x, t)):


(*
 Copyright (C) 2020 Susi Lehtola

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: mgga_exc *)
(* prefix:
  mgga_k_lk_params *params;

  assert(p->params != NULL);
  params = (mgga_k_lk_params * ) (p->params);
*)

lk_p := x -> X2S^2*x^2:
lk_q := u -> X2S^2*u:

(* Equation (10) *)
lk_delta := (p, q) -> 8/81*q^2 - 1/9*p*q + 8/243*p^2:
(* Equation (15) *)
lk_f0 := (x1, x2) -> 1 + params_a_kappa*(2 - 1/(1+x1/params_a_kappa) - 1/(1+x2/params_a_kappa)):
(* Equation (16) *)
lk_x1 := (p, q) -> 5/27*p + lk_delta(p,q) + (5/27*p)^2/params_a_kappa:
(* Equation (17) *)
lk_x2 := (p, q) -> 2*(5/27*p)*lk_delta(p,q)/params_a_kappa + (5/27*p)^3/params_a_kappa^2:

(* Full functional *)
lk_f := (x, u) ->
  lk_f0(lk_x1(lk_p(x),lk_q(u)), lk_x2(lk_p(x),lk_q(u))):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_kinetic(lk_f, rs, z, xs0, xs1, u0, u1):


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: mgga_exc *)
(* prefix:
  mgga_k_pc07_params *params;

  assert(p->params != NULL);
  params = (mgga_k_pc07_params * ) (p->params);
*)

pc07_p := x -> X2S^2*x^2:
pc07_q := u -> X2S^2*u:

(* Equation (15) redefined with decaying exponentials to avoid inf/inf situations *)
pc07_fab0 := z -> exp(-params_a_a*params_a_b/z) * (1+exp(-params_a_a/(params_a_a-z)))^params_a_b/(exp(-params_a_a/z) + exp(-params_a_a/(params_a_a-z)))^params_a_b:
(* The function is ill-behaving at z=0 and z=a.
   However, it also goes to 0 and 1 very quickly near these points.
   pc07_fab0(params_a_a/40) is ~ 1.6e-17, which is smaller than machine epsilon.
*)
pc07_thr := 1/40:
pc07_zlo := pc07_thr*params_a_a:
pc07_zhi := (1-pc07_thr)*params_a_a:
pc07_fab := z -> my_piecewise5(z<=pc07_zlo, 0, z>=pc07_zhi, 1, pc07_fab0( m_min(pc07_zhi, m_max(pc07_zlo, z)) ) ):

(* Equation (7) *)
pc07_Delta := (x, u) ->
  8*pc07_q(u)^2/81 - pc07_p(x)*pc07_q(u)/9 + 8*pc07_p(x)^2/243:

pc07_f_W    := x -> 5*pc07_p(x)/3:

(* Equation (8) *)
pc07_GE4  := (x, u) ->
  1 + 5*pc07_p(x)/27 + 20*pc07_q(u)/9 + pc07_Delta(x, u):

(* Equation (11) *)
pc07_GE4_M := (x, u) ->
  pc07_GE4(x, u)/sqrt(1 + pc07_Delta(x, u)^2/(1 + pc07_f_W(x))^2):

(* Equation (17) *)
pc07_f := (x, u) ->
  pc07_f_W(x) + (pc07_GE4_M(x, u) - pc07_f_W(x))*pc07_fab(pc07_GE4_M(x, u) - pc07_f_W(x)):

f := (rs, z, xt, xs0, xs1, u0, u1, t0, t1) ->
  mgga_kinetic(pc07_f, rs, z, xs0, xs1, u0, u1):


######################################################################

`is_element/partord` := (A::set) -> proc(R)
 global reason;

 if not `is_element/autorel`(A)(R) then
  reason := ["is_element/partord","R is not a relation on A",R,A,reason];
  return false;
 fi;

 if not(`is_reflexive/autorel`(A)(R)) then
  reason := ["is_element/partord","R is not reflexive",R];
  return false;
 fi;

 if not(`is_transitive/autorel`(A)(R)) then
  reason := ["is_element/partord","R is not transitive",R];
  return false;
 fi;

 if not(`is_separated/autorel`(A)(R)) then
  reason := ["is_element/partord","R is not separated",R];
  return false;
 fi;

 return true;
end;

######################################################################

`is_equal/partord`     := eval(`is_equal/autorel`);
`is_leq/partord`       := eval(`is_leq/autorel`);
`is_separated/partord` := eval(`is_separated/autorel`);

######################################################################

`op/partord` := eval(`op/autorel`);

######################################################################

`random_element/partord` := (A::set) -> proc()
 local M,B,E,RB,RA,DS,xy,x,y,d,m,a,e;
 if nops(A) <= 1 then return {seq([a,a],a in A)}; fi;

 M := `random_element/nonempty_subsets`(A)();
 B := A minus M;
 RB := `random_element/partord`(B)();
 DS := `list_elements/subsets`(B);
 for xy in RB do
  x,y := op(xy);
  if x <> y then
   DS := select(S -> (member(x,S) or not(member(y,S))),DS);
  fi;
 od;
 d := nops(DS);
 RA := RB union {seq([m,m],m in M)};
 for m in M do
  E := DS[rand(1..d)()];
  RA := RA union {seq([e,m],e in E)};
 od;

 return RA;
end:

######################################################################

`top_element/partord` := (A) -> proc(R)
 local n,a,U;
 n := nops(A);
 for a in A do
  U := select(e -> e[2] = a,R);
  if nops(U) = n then
   return a;
  fi;
 od:

 return FAIL;
end:

######################################################################

`bottom_element/partord` := (A) -> proc(R)
 local n,a,U;
 n := nops(A);
 for a in A do
  U := select(e -> e[1] = a,R);
  if nops(U) = n then
   return a;
  fi;
 od:

 return FAIL;
end:

######################################################################

`rank_table/partord` := (A::set) -> proc(R)
 local pi,pi0,a,b,r,k,B;

 r := table():
 for a in A do
  r[a] := nops(select(x -> member([x,a],R),A)) - 1;
 od;

 return eval(r);
end;

######################################################################

`hasse_diagram/partord` := (A::set) -> proc(R)
 local R1,R2;
 R1 := R minus `id/autorel`(A);
 R2 := `o/autorel`(A)(R1,R1);
 return R1 minus R2;
end:

######################################################################

`maximal_chains/partord` := (A::set) -> proc(R)
 local H,LC,UC,a,C,C0,extra,c,u;

 H := `hasse_diagram/partord`(A)(R);
 LC := table():
 UC := table():
 for a in A do
  LC[a] := map(e -> e[1],select(e -> e[2] = a,H));
  UC[a] := map(e -> e[2],select(e -> e[1] = a,H));
 od:

 C := map(a -> [a],select(a -> LC[a] = {},A));
 extra := true;
 while extra do
  extra := false;
  C0 := C;
  C := NULL;
  for c in C0 do
   u := UC[c[-1]];
   if u = {} then
    C := C,c;
   else
    C := C,seq([op(c),a],a in u);
    extra := true;
   fi;
  od:
  C := {C};
 od;

 return C;
end:

######################################################################

`partord_is_leq` := (A::set) -> (R) -> (a,b) -> member([a,b],R);

######################################################################

`partord_is_equiv` := (A::set) -> (R) -> (a,b) ->
  member([a,b],R) and member([b,a],R);

######################################################################

`partord_is_less` := (A::set) -> (R) -> (a,b) ->
  member([a,b],R) and not(member([b,a],R));

######################################################################
# Returns [A0,R0] where A0 is of the form {1,...,n} and
# (A0,R0) is isomorphic to (A,R).

`skeleton/partord` := (A::set) -> proc(R)
 local n,i,A0,Ai,R0;
 n := nops(A);
 A0 := {seq(i,i=1..n)};
 Ai := table():
 for i from 1 to n do Ai[A[i]] := i; od;
 R0 := map(u -> [Ai[u[1]],Ai[u[2]]],R);
 return [A0,R0];
end:

######################################################################

`partord/from_comparator` := (A::set) -> proc(C)
 local R,a,b;

 R := {seq(seq([a,b],b in A),a in A)};
 R := select(ab -> C(op(ab)),R);

 return [A,R];
end:

######################################################################

`skeleton/partord/from_comparator` := (A::{set,list}) -> proc(C)
 local n,i,j,A0,R0;

 n := nops(A);
 A0 := {seq(i,i=1..n)};
 R0 := {seq(seq([i,j],j = 1..n),i = 1..n)};
 R0 := select(ij -> C(A[ij[1]],A[ij[2]]),R0);

 return [A0,R0];
end:

######################################################################

`homology/partord` := (A::set) -> proc(R,p::nonnegint := 0)
 local U,C,Cn,Ci,dM,rdM,BN,H,c,c1,d,d_max,a,i,i1,j,k,t;

 U := table():
 for a in A do
  U[a] := select(b -> (b <> a and member([a,b],R)),A):
 od:
 C[0] := [seq(chain(a),a in A)]:
 d := 0;
 while C[d] <> [] do
  d := d+1;
  C[d] := [seq(seq(chain(op(c),a),a in U[op(d,c)]),c in C[d-1])]:
 od:
 d_max := d - 1;
 for d from 0 to d_max do
  Cn[d] := nops(C[d]):
  Ci[d] := table():
  for i from 1 to nops(C[d]) do
   Ci[d][C[d][i]] := i;
  od:
 od:

 dM := table():
 rdM := table():
 rdM[0] := 0;
 rdM[d_max+1] := 0;

 for d from 1 to d_max do
  dM[d] := Matrix(Cn[d-1],Cn[d]);
  for i from 1 to Cn[d] do
   c := [op(C[d][i])];
   for j from 0 to d do
    c1 := chain(seq(c[k+1],k=0..j-1),seq(c[k+1],k=j+1..d));
    i1 := Ci[d-1][c1];
    dM[d][i1,i] := (-1)^j;
   od:
  od:
  if p = 0 then
   rdM[d] := LinearAlgebra[Rank](dM[d]);
  else
   rdM[d] := LinearAlgebra[Modular][Rank](p,dM[d]);
  fi;
 od:

 BN := table():
 for d from 0 to d_max do
  BN[d] := Cn[d] - rdM[d] - rdM[d+1];
 od:

 H := table():
 H["characteristic"] := p;
 H["dim"] := d_max;
 H["chains"] := eval(C);
 H["chain_index"] := eval(Ci);
 H["differential_matrix"] := eval(dM);
 H["chain_number"] := eval(Cn);
 H["betti_number"] := eval(BN):
 H["poincare_series"] := unapply(add(BN[i]*t^i,i=0..d_max),t);
 H["euler_characteristic"] := add((-1)^d * BN[d],d = 0..d_max):

 return eval(H):
end:

######################################################################

`simplex/partord` := proc(n)
 local i,j;
 return [{seq(i,i=0..n)},{seq(seq([i,j],j=i..n),i=0..n)}];
end:

`crown/partord` := proc(n)
 local A,R,i;
 A := {seq(i,i=1..2*n)};
 R := {seq([i,i],i=1..2*n),
       seq([2*i-1,2*i],i=1..n),
       seq([2*i+1,2*i],i=1..n-1),
       [1,2*n]};
 return [A,R];
end:

`saw/partord` := proc(n)
 local A,R,i;
 A := {seq(i,i=1..n)};
 R := {seq([i,i],i=1..n),
       seq([2*i-1,2*i],i=1..floor(n/2)),
       seq([2*i+1,2*i],i=1..floor((n-1)/2))};
 return [A,R];
end:

`diamond/partord` := proc(n)
 local A,R,i,j;

 A := {seq(i,i=1..2*n)};
 R := {seq([i,i],i=1..2*n),
       seq(seq([2*i-1,j],j=2*i+1..2*n),i=1..n),
       seq(seq([2*i  ,j],j=2*i+1..2*n),i=1..n)};
 return [A,R];
end:


restart;
kernelopts(printbytes=false):
partitions := proc(c::list(integer),subtotal::integer) :: integer:
  local i,m,total,cards;
  cards := c;
  m := 0;
  # Hit
  for i from 1 to 10 do
    if (cards[i]>0) then
      total := subtotal+i;
      if (total < 21) then
        # Stand
        m := m+1;
	# Hit again
        cards[i] := cards[i]-1;
        m := m+partitions(cards, total);
        cards[i] := cards[i]+1;
      elif (total=21) then
        # Stand; hit again is an automatic bust
        m := m+1;
      end if;
    end if;
  end do;
  return m;
end proc:

deck := [4,4,4,4,4,4,4,4,4,16]:
d := 0:

for i from 1 to 10 do
  # Dealer showing
  p := 0:
  deck[i] := deck[i]-1:
  for j from 1 to 10 do
    deck[j] := deck[j]-1:
    p := p+partitions(deck,j):
    deck[j] := deck[j]+1:
  end do:
  deck[i] := deck[i]+1:
  printf("Dealer showing %d partitions = %d\n",i-1,p):
  d := d+p:
end do:
printf("Total partitions = %d\n",d):


check_koszul := proc()
 local A,n,dA,u,J,i;

 printf("%a()\n",procname);

 A := <<1|5|4|9>,<2|2|7|5>,<3|9|9|6>,<4|3|2|1>>;
 n := Dimension(A)[1];
 dA := Determinant(A);
 u := [4,5,6,11];

 J := Matrix(n,n);
 for i from 1 to n do J[i,n+1-i] := (-1)^(i-1); od;

 _ASSERT(
  Equal(koszul_adjoint(0,A), <<Determinant(A)>>),
  "koszul adjoint(0,A) = det(A)"
 );

 _ASSERT(
  Equal(koszul_adjoint(1,A), Adjoint(A)),
  "koszul_adjoint(1,A) = adj(A)"
 );

 _ASSERT(
  Equal(koszul_adjoint(n-1,A), Transpose((-1)^(n-1) * J . A . J)),
  "koszul_adjoint(n-1,A) is conjugate to A^T"
 );

 _ASSERT(
  Equal(koszul_adjoint(n,A), <<1>>),
  "koszul_adjoint(n,A) = 1"
 );

 _ASSERT(
  `and`(seq(Equal(exterior_power(k,A) . koszul_adjoint(k,A),
                  dA * IdentityMatrix(binomial(n,k))),k=0..n)),
  "exterior_power(k,A) o koszul_adjoint(k,A) = det(A) in all degrees"
 );

 _ASSERT(
  `and`(seq(Equal(koszul_d(k,u) . koszul_d(k+1,u),
                  Matrix(binomial(n,k-1),binomial(n,k+1))),k=1..n-1)),
  "koszul_d ^ 2 = 0"
 );
end:

check_koszul_comparison := proc()
 global v,n,u_vec,v_vec,w_vec,x_vec,x_vars,Iv,Mv,Nv,
        soc_u,soc_v,soc_w,A,B,p;

 v := [x[1]^2+x[2]^3,x[1]*x[2]+x[3],x[1]^4-x[3]^2*x[2],x[4]-x[2]^3];
 koszul_setup(v);

 _ASSERT(
  Equal(map(koszul_pmod,map(expand,u_vec)),
        map(koszul_pmod,map(expand,v_vec . A))),
  "u = v . A"
 );

 _ASSERT(
  Equal(map(koszul_pmod,map(expand,v_vec)),
        map(koszul_pmod,map(expand,w_vec . B))),
  "v = w . B"
 );

 _ASSERT(
   Equal(map(koszul_pmod,map(Nv,soc_v * x_vec)),Transpose(Vector(n))),
   "soc_v is in the socle"
 );

 _ASSERT(
   not(koszul_pmod(Nv(soc_v)) = 0),
   "soc_v is nonzero"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,v_vec) . exterior_power(k,A)),
	 map(expand,exterior_power(k-1,A) . koszul_d(k,u_vec))),
   k=1..n
  )),
  "exterior_power(*,A) is a chain map"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,w_vec) . exterior_power(k,B)),
	 map(expand,exterior_power(k-1,B) . koszul_d(k,v_vec))),
   k=1..n
  )),
  "exterior_power(*,B) is a chain map"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,u_vec) . koszul_adjoint(k,A)),
	 map(expand,koszul_adjoint(k-1,A) . koszul_d(k,v_vec))),
   k=1..n
  )),
  "koszul_adjoint(*,A) is a chain map"
 );

 _ASSERT(
  `and`(seq(
   Equal(map(expand,koszul_d(k,v_vec) . koszul_adjoint(k,B)),
	 map(expand,koszul_adjoint(k-1,B) . koszul_d(k,w_vec))),
   k=1..n
  )),
  "koszul_adjoint(*,B) is a chain map"
 );

end:


######################################################################
# simplex(A) is the set of maps x : A -> [0,1] with sum = 1.

`is_element/simplex` := (A::set) -> proc(x)
 local a,u,v;
 global reason;

 if not type(x,table) then
  reason := [convert(procname,string),"x is not a table",x];
  return false;
 fi;

 if map(op,{indices(x)}) <> A then
  reason := [convert(procname,string),"x is not indexed by A",x,A];
  return false;
 fi;

 v := 0;
 for a in A do
  u := x[a];
  if not (`is_element/RR`(u) and u >= 0 and u <= 1) then
   reason := [convert(procname,string),"x[a] is not in the unit interval",a,u];
   return false;
  fi;

  v := v + u;
 od;

 if simplify(v - 1) <> 0 then
  reason := [convert(procname,string),"entries in x do not sum to 1",x,v];
  return false;
 fi;

 return true;
end;

`is_equal/simplex` := (A::set) -> proc(x,y)
 local a;
 global reason;

 for a in A do
  if simplify(x[a] - y[a]) <> 0 then
   reason := [convert(procname,string),"x[a] <> y[a]",a,x[a],y[a]];
   return false;
  fi;
 od;
 return true;
end;

`is_leq/simplex` := NULL;

`random_element/simplex` := (A::set) -> proc(d::posint := 5)
 local x,a,r1,r2,u;
 if A = {} then return FAIL; fi;

 r1 := rand(0..d);
 r2 := rand(1..d);
 x := table();
 u := 0;
 while u = 0 do
  for a in A do
   x[a] := r1()/r2();
   u := u + x[a];
  od;
 od;

 for a in A do x[a] := x[a]/u; od;

 return eval(x);
end;

`list_elements/simplex` := NULL;
`count_elements/simplex` := NULL;


######################################################################

`is_element/height_functions` := (A::set) -> proc(h)
 local P,U,V,a,u;
 global reason;

 if not(type(h,table)) then
  reason := [convert(procname,string),"h is not a table",h];
  return false;
 fi;

 P := {op(`list_elements/nonempty_subsets`(A))};
 if map(op,{indices(h)}) <> P then
  reason := [convert(procname,string),"h is not indexed by the nonempty subsets of A",h,A];
  return false;
 fi;

 for a in A do if h[{a}] <> 0 then
  reason := [convert(procname,string),"h({a}) <> 0",h,a];
  return false;
 fi; od;

 for U in P do
  u := h[U];
  if not (`is_element/RR`(u) and u >= 0 and u <= 1) then
   reason := [convert(procname,string),"h(U) is not in the unit interval",U,u];
   return false;
  fi;
 od;

 for U in P do
  for V in P do
   if U intersect V <> {} and
      h[U union V] <> max(h[U],h[V]) then
    reason := [convert(procname,string),"h(U u V) <> max(h(U),h(V))",U,V,h[U],h[V],h[U union V]];
    return false;
   fi;
  od;
 od;

 return true;
end;

######################################################################

`is_equal/height_functions` := (A::set) -> proc(h1,h2)
 local P,U;
 P := `list_elements/nonempty_subsets`(A);
 for U in P do
  if h1[U] <> h2[U] then return false; fi;
 od;
 return true;
end;

######################################################################

`is_leq/height_functions` := NULL;

`list_elements/height_functions` := NULL;
`count_elements/height_functions` := NULL;

######################################################################

`is_critical/height_functions` := (A::set) -> proc(h,U)
 local V,a;

 V := A minus U;

 if V = {} then return evalb(h[A] < 1); fi;

 for a in V do
  if h[U union {a}] = h[U] then return false; fi;
 od;

 return true;
end;

######################################################################

`critical_tree/height_functions` := (A::set) -> proc(h)
 local P;

 P := `list_elements/nonempty_subsets`(A);

 return {op(select(U ->`is_critical/height_functions`(A)(h,U),P))};
end;

######################################################################

`theta/partitions/height_functions` := (A::set) -> proc(pi)
 local h,P,T,B,Q;

 h := table();
 P := `list_elements/nonempty_subsets`(A);
 for T in P do h[T] := 1; od;
 for B in pi do
  Q := `list_elements/nonempty_subsets`(B);
  for T in Q do h[T] := 0; od;
 od;

 return eval(h);
end;

######################################################################

`theta/realisation/partitions/height_functions` := (A::set) -> proc(x)
 local P,T,C,pi,t,k,h;

 h := table();
 P := `list_elements/nonempty_subsets`(A);
 for T in P do h[T] := 0; od;

 C := map(op,[indices(x)]);

 for pi in C do
  t := x[pi];
  k := `theta/partitions`(A)(pi);
  for T in P do
   h[T] := h[T] + t * k[T];
  od;
 od;

 return eval(h);
end:

######################################################################

`theta_inv/realisation/partitions/height_functions` := (A::set) -> proc(h)
 local TT,TTT,S,r,s,t,x,U,X,Y,pi,a,m,i;

 TT := `critical_tree/height_functions`(A)(h);
 S := map(T -> h[T],TT) minus {1};
 r := nops(S) - 1;
 s := table();
 s[-1] := 1;
 for i from 0 to r do s[i] := S[r+1-i]; od;
 TTT := table();
 x := table();
 for i from 0 to r do
  TTT[i] := select(U -> h[U] <= s[i],TT);
  X := TTT[i];
  pi[i] := {};
  while X <> {} do
   a := X[1][1];
   Y := select(T -> member(a,T),X);
   m := max(map(nops,Y));
   U := select(T -> nops(T) = m,Y)[1];
   pi[i] := {op(pi[i]),U};
   X := X minus Y;
  od;
  x[pi[i]] := s[i-1] - s[i];
 od;

 return eval(x);
end:


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: work_gga_x *)

ad  := 1e-8:
b   := 0.024974:
a2  := (ad + 0.1234)/b:
a4  := 29.790:
a6  := 22.417:
a8  := 12.119:
a10 := 1570.1:
a12 := 55.944:

f0 := s-> 1 + a2*s^2 + a4*s^4 + a6*s^6 + a8*s^8 + a10*s^10 + a12*s^12:
f1 := s-> f0(s)^b/(1 + ad*s^2):

f  := x->f1(X2S*x):


DV := NumberTheory[Divisors]:

ghost_coeff := (n) -> proc(x)
 local d;
 return add(d * x[d]^(n/d), d in DV(n));
end:

ghost_vector := (n::posint) -> proc(x)
 local m;
 return [seq(ghost_coeff(m)(x),m=1..n)];
end:

unghost_vector := (n::posint) -> proc(w)
 local x,m,d;
 x := []:
 for m from 1 to n do
  x := [op(x),expand((w[m] - add(d*x[d]^(m/d),d in DV(m) minus {m}))/m)];
 od:
 return x;
end:

witt_add_term := proc(n::posint)
 option remember;
 local x,y,u,d,rel;

 for d in DV(n) minus {n} do
  u[d] := witt_add_term(d)(x,y);
 od:

 rel := ghost_coeff(n)(u) - ghost_coeff(n)(x) - ghost_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_add := (n::posint) -> proc(x,y)
 local m;
 return [seq(witt_add_term(m)(x,y),m=1..n)];
end:

witt_mult_term := proc(n::posint)
 option remember;
 local x,y,u,d,rel;

 for d in DV(n) minus {n} do
  u[d] := witt_mult_term(d)(x,y);
 od:

 rel := ghost_coeff(n)(u) - ghost_coeff(n)(x) * ghost_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_mult := (n::posint) -> proc(x,y)
 local m;
 return [seq(witt_mult_term(m)(x,y),m=1..n)];
end:

witt_series := (n::posint) -> proc(x)
 local m;
 return expand(rem(mul(1 - x[m]*t^m,m=1..n),t^(n+1),t));
end:

witt_unseries := (n::posint) -> proc(f)
 local c,g,d;
 c := []:
 g := f;
 for d from 1 to n do
  c := [op(c),-coeff(g,t,d)];
  g := expand(convert(series(g/(1-c[d]*t^d),t=0,n+1),polynom,t));
 od:
 return c;
end:

ghost_p_coeff := (n) -> proc(x)
 local i;
 return add(p^i * x[i]^(p^(n-i)), i=0..n);
end:

ghost_p_vector := (n::nonnegint) -> proc(x)
 local i;
 return table([seq(i = ghost_p_coeff(i)(x),i=0..n-1)]);
end:

ghost_p_add := (n::nonnegint) -> proc(a,b)
 local i;
 return table([seq(i=expand(a[i]+b[i]),i=0..n-1)]);
end:

ghost_p_sub := (n::nonnegint) -> proc(a,b)
 local i;
 return table([seq(i=expand(a[i]-b[i]),i=0..n-1)]);
end:

ghost_p_mult := (n::nonnegint) -> proc(a,b)
 local i;
 return table([seq(i=expand(a[i]*b[i]),i=0..n-1)]);
end:

ghost_p_is_equal := (n::nonnegint) -> proc(a,b)
 local i;
 return `and`(seq(evalb(simplify(a[i]-b[i])=0),i=0..n-1));
end:

unghost_p_vector := (n::nonnegint) -> proc(w)
 local x,m,k;
 x := table:
 for m from 0 to n-1 do
  x[m] := expand((w[m] - add(p^k*x[k]^(p^(m-k)),k=0..m-1))/p^m);
 od:
 return eval(x);
end:

witt_p_add_term := proc(n::nonnegint)
 option remember;
 local x,y,u,m,rel;
 u := table():
 for m from 0 to n-1 do
  u[m] := witt_p_add_term(m)(x,y);
 od:

 rel := ghost_p_coeff(n)(u) - ghost_p_coeff(n)(x) - ghost_p_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_p_add := (n::posint) -> proc(x,y)
 local m;
 return table([seq(m=witt_p_add_term(m)(x,y),m=0..n-1)]);
end:

witt_p_mult_term := proc(n::nonnegint)
 option remember;
 local x,y,u,m,rel;
 u := table():
 for m from 0 to n-1 do
  u[m] := witt_p_mult_term(m)(x,y);
 od:

 rel := ghost_p_coeff(n)(u) - ghost_p_coeff(n)(x) * ghost_p_coeff(n)(y);
 u[n] := expand(solve(rel,u[n]));
 return unapply(u[n],x,y);
end:

witt_p_mult := (n::posint) -> proc(x,y)
 local m;
 return table([seq(m=witt_p_mult_term(m)(x,y),m=0..n-1)]);
end:


program sample29;
var unused1 : integer;
    UnusedArrayForTest : array[200] of char;
procedure gcmlcm(m, n, gc, lc : integer);
var a, b, r : integer;
    begin
        a := m;
        b := n;
        while b <> 0 do begin
            r := a - (a div b) * b;
            a := b;
            b := r
        end;
        gc := a;
        lc := (m div gc) * n
    end;
procedure abs(a, b : integer);
        if a < 0 then
            b := -a
        else
            b := a
    end;
procedure gcm(a, b, gc : integer);
var lc, aa, bb : integer;
        if (a = 0) or (b = 0) then
            gc := 1
        else
                call abs(a, aa);
                call abs(b, bb);
                call gcmlcm(aa, bb, gc, lc)
            end
    end;
procedure lcm(a, b, lc : integer);
var gc, aa, bb : integer;
        if (a = 0) or (b = 0) then
            lc := 1
        else
                call abs(a, aa);
                call abs(b, bb);
                call gcmlcm(aa, bb, gc, lc)
            end
    end;
var unusedchar : char;
procedure reduce(a1, a2 : integer);
var gc : integer;
        if a1 = 0 then
                a2 := 1;
                return
            end;
        if a2 = 0 then
                a1 := 1;
                return
            end;
        if a2 < 0 then
                a1 := -a1;
                a2 := -a2
            end;
        call gcm(a1, a2, gc);
        a1 := a1 div gc;
        a2 := a2 div gc
    end;
procedure sum(x1, x2, y1, y2 : integer);
var lc, y11 : integer;
        call lcm(x2, y2, lc);
        x1 := x1 * (lc div x2);
        y11 := y1 * (lc div y2);
        x1 := x1 + y11;
        x2 := lc;
        call reduce(x1, x2)
    end;
procedure sub(x1, x2, y1, y2 : integer);
var lc, y11 : integer;
        call sum(x1, x2, -y1, y2)
    end;
procedure mult(x1, x2, y1, y2 : integer);
var gc, y22, y11 : integer;
        call gcm(x1, y2, gc);
        x1 := x1 div gc;
        y22 := y2 div gc;
        call gcm(x2, y1, gc);
        x2 := x2 div gc;
        y11 := y1 div gc;
        x1 := x1 * y11;
        x2 := x2 * y22;
        call reduce(x1, x2)
    end;
procedure divide(x1, x2, y1, y2 : integer);
        call mult(x1, x2, y2, y1)
    end;
var unusedarray : array[100] of char;
procedure printfinal(a, b : integer);
        if a = 0 then
            writeln('Final Result =', a)
        else if b = 1 then
            writeln('Final Result =', a)
        else
            writeln('Final Result =', a, '/', b)
    end;
procedure printtemp(a, b : integer);
        if a = 0 then
            writeln('Temporary Result =', a)
        else if b = 1 then
            writeln('Temporary Result =', a)
        else
            writeln('Temporary Result =', a, '/', b)
    end;
var x1, x2, y1, y2 : integer;
var com : char;
    endflag : boolean;
    writeln('   *** Calculator -- h for help ***');
    x1 := 0;
    x2 := 1;
    endflag := false;
    while notendflag do begin
        writeln(' Please input command :');
        readln(com,y1);
        y2 := 1;
        if (com = 'c') or (com = 'C') then
                x1 := y1;
                x2 := y2
            end
        else if com = '+' then
            call sum(x1, x2, y1, y2)
        else if com = '-' then
            call sub(x1, x2, y1, y2)
        else if com = '*' then
            call mult(x1, x2, y1, y2)
        else if com = '/' then
            call divide(x1, x2, y1, y2)
        else if (com = 'o') or (com = 'O') then
            endflag := true
        else
                writeln;
                writeln('Calculator Usage:');
                writeln('  c number : clear & set it');
                writeln('  + number : add it');
                writeln('  - number : subtract it');
                writeln('  * number : multiply it');
                writeln('  / number : divide by it');
                writeln('  o        : off(terminate execution)');
                writeln
            end;
        if endflag then
            call printfinal(x1, x2)
        else
            call printtemp(x1, x2)
    end
end.


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: gga_exc *)

$include "gga_c_tca.mpl"

msinc := x -> my_piecewise3(x = 0, 1, sin(x)/x):
revtca_aa := Pi*(9*Pi/4)^(1/3):

revtca_fD := (rs, z, s) -> 1 - z^4*(1 - msinc(revtca_aa*s/rs)^2):

f := (rs, z, xt, xs0, xs1) ->
  f_tcs(rs, z, xt)*revtca_fD(rs, z, X2S*2^(1/3)*xt):


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: gga_exc *)

hcth_a_beta  :=  0.0042:
hcth_a_gamma :=  6:
hcth_a_c0    :=  1.09878:
hcth_a_c1    := -2.51173:
hcth_a_c2    :=  0.0156233:

hcth_a_aux := x -> 1 + hcth_a_gamma*hcth_a_beta*x*arcsinh(x):

hcth_a_f := x -> hcth_a_c0 + hcth_a_beta/X_FACTOR_C*x^2*(hcth_a_c1/hcth_a_aux(x)
     + hcth_a_c2/(hcth_a_beta*hcth_a_aux(x)^2)):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(hcth_a_f, rs, z, xs0, xs1):


(*
 Copyright (C) 2017 M.A.L. Marques

 This Source Code Form is subject to the terms of the Mozilla Public
 License, v. 2.0. If a copy of the MPL was not distributed with this
 file, You can obtain one at http://mozilla.org/MPL/2.0/.
*)

(* type: lda_exc *)

$define xc_dimensions_1d

eta0 := -log(sqrt(2*Pi)) - 3/4:
eta1 := 0.359933:
eps0 := -Pi^2/360:
eps1 := 0.00714:

kappa := 0.3083:

c0 := kappa*eta0:
c1 := 4*kappa*eta0 + kappa*sqrt(kappa)*eta1:
c2 := 5*eps0 + eps1/kappa:
c3 := eps1:

t := rs -> (sqrt(1 + 4*kappa*rs) - 1)/(2*kappa*rs):

f := (rs, z) ->
  t(rs)^2*(c0*(1 - t(rs))^3 + c1*t(rs)*(1 - t(rs))^2 + c2*t(rs)^2*(1 - t(rs)) + c3*t(rs)^3):


read "../ComputeIdentifiableFunctions.mpl":

cases := [
    [
        [a * x + a * y, [x, y], [a]], 1
    ],
    [
        [(a + b) * (x + y) - (b + c) * (y + z) + 3 * (a + c) * (x + z), [x, y, z], [a, b, c]], 3
    ]
];

num_passed := 0:
num_failed := 0:

for case in cases do
    input := case[1]:
    correct := case[2]:
    passed := true:
    result := DecomposePolynomial(op(input), 0):
    if nops(result[1]) <> correct then
        passed := false:
    end if:
    orig_poly := 0:
    for i from 1 to nops(result[1]) do
        orig_poly := orig_poly + result[1][i] * result[2][i]:
    end do:
    if simplify(orig_poly - input[1]) <> 0 then
        passed := false:
    end if:
    if passed = true then
        printf("PASSED");
        num_passed := num_passed + 1:
    else
        printf("FAILED");
        num_failed := num_failed + 1:
        print(result);
    end if:
end do:

printf("Passed: %a, failed %a \n", num_passed, num_failed);