(*
 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/.
*)

# Minimum and maximum functions that I can differentiate
m_min := (x1, x2) -> x1 + (x2 - x1)*Heaviside(x1 - x2):
m_max := (x1, x2) -> x1 + (x2 - x1)*Heaviside(x2 - x1):
m_abs := (x) -> m_max(x, -x):

# a series of useful definitions

M_C         := 137.0359996287515: (* speed of light *)

RS_FACTOR   := (3/(4*Pi))^(1/3):
X2S         := 1/(2*(6*Pi^2)^(1/3)):
X2S_2D      := 1/(2*(4*Pi)^(1/2)):

X_FACTOR_C    := 3/8*(3/Pi)^(1/3)*4^(2/3):
X_FACTOR_2D_C := 8/(3*sqrt(Pi)):
K_FACTOR_C    := 3/10*(6*Pi^2)^(2/3):

MU_GE       := 10/81:
MU_PBE      := 0.06672455060314922*(Pi^2)/3:
KAPPA_PBE   := 0.8040:

# generic conversion functions
n_total    := rs -> (RS_FACTOR/rs)^3:
n_spin     := (rs, z) -> (1 + z)*n_total(rs)/2:
sigma_spin := (rs, z, xs) -> xs^2*n_spin(rs, z)^(8/3):
t_total    := (z, ts0, ts1) ->
  (ts0*((1 + z)/2)^(5/3) + ts1*((1 - z)/2)^(5/3)):
u_total    := (z, us0, us1) -> t_total(z, us0, us1):

# useful formulas that enter several functionals follow

# von Weizsäcker term
t_vw := (z, xt, us0, us1) -> (xt^2 - u_total(z, us0, us1))/8:

# See Eq. (9) of Perdew1992_13244
f_zeta    := z -> ((1 + z)^(4/3) + (1 - z)^(4/3) - 2)/(2^(4/3) - 2):
f_zeta_2d := z -> 1/2*((1 + z)^(3/2) + (1 - z)^(3/2)):

# used in several correlation functionals
mphi := z -> ((1 + z)^(2/3) + (1 - z)^(2/3))/2:
tt   := (rs, z, xt) -> xt/(4*2^(1/3)*mphi(z)*sqrt(rs)):

# in the paper it is beta_a = 0.066725
beta_Hu_Langreth := rs -> 0.066724550603149220*(1 + 0.1*rs)/(1 + 0.1778*rs):

# This is the Stoll decomposition in our language
lda_stoll_par  := (lda_func, rs, z, spin) ->
  lda_func(rs*(2/(1 + z))^(1/3), spin)*(1 + z)/2:

lda_stoll_perp := (lda_func, rs, z) ->
  + lda_func(rs, z)
  - lda_stoll_par(lda_func, rs,  z,  1)
  - lda_stoll_par(lda_func, rs, -z, -1):

gga_stoll_par  := (gga_func, rs, z, xs, spin) ->
 + gga_func(rs*(2/(1 + z))^(1/3), spin, xs, xs*(1 + spin)/2, xs*(1 - spin)/2)
 * (1 + z)/2:

# Curvature of the Fermi hole (without the current term)
Fermi_D := (xs, ts) -> 1 - xs^2/(8*ts):

# correction to Fermi_D in JCP 127, 214103 (2007); doi: http://dx.doi.org/10.1063/1.2800011
Fermi_D_a := 1e-4:
Fermi_D_corrected := (xs, ts) -> (1 - xs^2/(8*ts)) * (1 - exp(-ts^2/a^2)):

# Becke function used in several correlation functionals
b88_R_F := (f_x, rs, z, xs) ->
  1/(2*X_FACTOR_C*n_spin(rs, z)^(1/3)*f_x(xs)):

b88_zss := (css, f_x, rs, z, xs) ->
  2*css*b88_R_F(f_x, rs, z, xs):
b88_zab := (cab, f_x, rs, z, xs0, xs1) ->
  cab*(b88_R_F(f_x, rs, z, xs0) + b88_R_F(f_x, rs, -z, xs1)):

# Power series often used in mggas
mgga_w := t -> (K_FACTOR_C - t)/(K_FACTOR_C + t):
mgga_series_w := (a, n, t) -> add(a[i]*mgga_w(t)^(i-1), i=1..n):

# Used in screened functionals
kF := (rs, z) -> (3*Pi^2*(1 + z))^(1/3) * RS_FACTOR/rs:
nu := (rs, z) -> params_a_omega/kF(rs, z):


(*
    不变量化简的算法如下：
    +	对于每个不变量，
        + 尝试使用其它不变量来进行表示，为了防止循环替代，以及出于化简的目的，只允许表示之后项数变少的替换。
        + 先尝试按照乘法规则进行化简，因式分解之后，删去能够成为不变量的因子。
        + 再尝试按照加法规则进行化简，展开之后，删去能够成为不变量的项。
    +	将无法化简的不变量整体替换回其表达式形式。
    +	消除不变量的系数。
    +	调整不变量的阶数为正整数。
    +	对于能够调整次数的不变量，调整其次数，例如把a[1]^3变成a[1]，把a[1]^4变成a[1]^2。

    重复执行上述算法，直到不能再化简为止。
*)

$ifndef _INVSIMPLIFY_
$define _INVSIMPLIFY_

$include "InvOrder.mpl"

# 化简不变量,不改变不变量的顺序。
simplifyInvariants:=proc(iinvs)
    local x,nx;
    x:=iinvs;
    while true do
        nx:=simplifyInvs(x);
        if (x=nx) then
            break;
        end if;
        x:=nx;
    end do;
    return x;
end proc:

# 内部化简函数
simplifyInvs:=proc(iinvs)
    local invs,tmp,ttmp,i,j,n,vars,vset,vv,v1,v2;
    invs:=iinvs;
    n:=numelems(invs);
    vars:=[seq(_Delta[i],i=1..n)];
    vset:={vars[]};
    # 尝试将不变量进行整体代换并进行化简
    for i from 1 to n do
        # 尝试把每个不变量用其它不变量进行表示
        tmp:=invs[i];
        for j from 1 to n do
            if (i<>j) then
                # 替换时用简单替换复杂的，不用复杂的替换简单的。
                try
                    ttmp:=myAlgsubs(invs[j]=vars[j],tmp);
                    if ( nops(expand(ttmp)) <= nops(expand(tmp)) ) then
                        tmp:=ttmp;
                    end if;
                catch:
                end try;
            end if;
        end do;
        invs[i]:=spAdd(spMul(tmp));
        if type(invs[i],numeric) then
            invs[i]:=0;
        end if:
    end do;
    vv:=[seq(vars[i]=invs[i],i=1..n)];
    # 将不能化简掉的整体代回原表达式
    while true do
        (v1,v2):=selectremove(e->(indets(rhs(e),name) intersect vset <> {}),vv);
        if (v1=[]) then
            break;
        end if;
        v1:=subs(v2[],v1);
        vv:=[v1[],v2[]];
    end do;
    vv:={vv[]};# 为了按照Delta排序
    vv:=rhs~([vv[]]);# 返回list才能保持顺序不变
    vv:=simpleSimplify~(vv);# 消去整体的倍数
    vv:=invOrd~(vv);# 调整阶数为正整数
    vv:=rmOrd~(vv);# 降次
    vv:=simplify(vv);# 默认化简
    return vv;
end proc:

# 自定义algsubs，解决algsubs对于分式替换的不足
myAlgsubs:=proc(_s::seq(equation),v)
    local s;
    s:=dealsubs~(_s);
    return algsubs(s,numer(v))/algsubs(s,denom(v));
end proc:

# 处理替换等式
dealsubs:=proc(e)
    local l,r;
    l:=lhs(e);
    r:=rhs(e);
    if type(numer(l),numeric) then
        return denom(l)=numer(l)/r;
    elif not type(denom(l),numeric) then
        return numer(l)=denom(l)*r;
    else
        return e;
    end if;
end proc:

# 调整不变量的阶数为正整数
invOrd:=proc(v)
    local ord;
    if type(v,numeric) then
        return v;
    end if;
    ord:=findInvariantsOrder(v);
    if type(ord,fraction) then
        return v^denom(ord);
    elif (ord<0) then
        return v^(-1);
    else
        return v;
    end if;
end proc:

# 不变量降次
rmOrd:=proc(_v)
    local v,ks,k;
    v:=expand(_v);
    if type(v,`*`) then
        v:=remove(type,v,numeric);
        ks:=map(getOrd,[op(v)]);
        k:=myGcd(ks);
        # 保证偶次不能变奇次
        if type(k,even) then
            k:=k/2;
        end if;
        v:=map(setOrd,v,k);
        return v;
    elif type(v,`^`) then
        if type(op(2,v),even) then
            return op(1,v)^2;
        else
            return op(1,v);
        end if;
    else
        return v;
    end if;
end proc:

# 获取次数
getOrd:=proc(e)
    if type(e,`^`) then
        return op(2,e);
    else
        return 1;
    end if;
end proc:

# 设置次数
setOrd:=proc(e,k)
    if type(e,`^`) then
        return subsop(2=op(2,e)/k,e);
    else
        return e^(1/k);
    end if;
end proc:

(*
    * 若不变量
    *     D[i]=f(D[j1],D[j2],...,D[jn])+g(a[1],...,a[m]), j1,j2,...,jn!=i
    * 则化简为
    *     D[i]=g(a[1],...,a[m])
*)
spAdd:=proc(ee)
    local e,r;
    e:=expand(ee);
    if type(e,`+`) then
        r:=remove(isInv,e);
        if (r=NULL) then
            r:=0;
        end if;
        return r;
    else
        return e;
    end if;
end proc:

(*
    * 若不变量
    *     D[i]=f(D[j1],D[j2],...,D[jn])*g(a[1],...,a[m]), j1,j2,...,jn!=i
    * 则化简为
    *     D[i]=g(a[1],...,a[m])
*)
spMul:=proc(ee)
    local e,r;
    e:=factor(ee);
    if type(e,`*`) then
        r:=remove(isInv,e);
        if (r=NULL) then
            r:=0;
        end if;
        return r;
    elif type(e,`^`) then
        r:=remove(isInv,op(1,e));
        if (r=NULL) then
            r:=0;
        end if;
        return r^op(2,e);
    else
        return e;
    end if;
end proc:

(*
    * 不变量的简单化简
    * 消去分子分母中的倍数
*)
simpleSimplify:=proc(ee)
    local n,d;
    n:=rmK(numer(ee));
    d:=rmK(denom(ee));
    return simplify(expand(n/d));
end proc:

# 删除多项式的倍数
rmK:=proc(_e)
    local e,r;
    if (_e=0) then
        return 0;
    end if:
    e:=expand(_e);
    if type(e,`+`) then
        # 消除多项式中各项系数的倍数
        r:=e/myGcd(map(x->select(type,x,numeric),[op(e)]));
    elif type(e,`*`) then
        # 消除单项多项式的系数
        r:=remove(type,e,numeric);
    else
        # 不处理无系数单项多项式
        r:=e;
    end if;
    if (r=NULL) or type(r,numeric) then
        r:=1;
    end if;
    return r;
end proc:

# 多个数的gcd
myGcd:=proc(ks)
    local k,i,n;
    if (ks=[]) then
        return 1;
    end if;
    k:=ks[1];
    n:=numelems(ks);
    for i from 2 to n do
        k:=gcd(k,ks[i]);
    end do;
    return k;
end proc:

# 是否是不变量
isInv:=proc(e)
    return andmap(type,indets(e,name),specindex(_Delta));
end proc:

$endif


(*
 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 *)

c     :=  0.7168:
alpha :=  2.804:
d     := 28.23705740248932030511071641312341561894: (* POW(CBRT(4/3) * 2*M_PI/3, 4) *)

csi  := s -> (3/2 * LambertW(s^(3/2) / (2*sqrt(6))))^(2/3):
fb   := s -> Pi/3 * s/(csi(s) * (d + csi(s)^2)^(1/4)):
flaa := s -> (1 + c*s^2)/(1 + c*s^2/fb(s)):
XX   := s -> 1 - alpha*s^2/(1 + alpha*s^2):

f    := x ->  XX(X2S*x) + (1 - XX(X2S*x))*flaa(X2S*x):


var t1 : int := 0;
var t2 : int := 1;
var t3 : int := t1 + t2;
var nTimes : int := 0;
print "nth term? ";
read nTimes;
var x : int;
for x in 2..nTimes-1 do
  t1:=t2;
  t2:=t3;
  t3:=t1+t2;
end for;
print t3;
print "\n";


######################################################################
# proper_nonempty_subsets(A) is the set of all proper nonempty subsets of A

`is_element/proper_nonempty_subsets` := (A::set) -> proc(B)
 type(B,set) and B minus A = {} and nops(B) > 0 and nops(B) < nops(A);
end;

`is_equal/proper_nonempty_subsets` := (A::set) -> (B,C) -> evalb(B = C):

`is_leq/proper_nonempty_subsets` := (A::set) -> (B,C) -> evalb(B minus C = {}):

`random_element/proper_nonempty_subsets` := (A::set) -> proc()
 local n,r,B;

 n := nops(A);

 if n < 2 then return FAIL; fi;

 r := rand(2);
 B := {};

 while nops(B) = 0 or nops(B) = n do
  B := select(a -> (r() = 1),A);
 od;

 return B;
end;

`list_elements/proper_nonempty_subsets` := (A::set) ->
 sort(map(sort,[op(combinat[powerset](A) minus {{},A})])):

`count_elements/proper_nonempty_subsets` := (A::set) -> 2^nops(A) - 2;


(*
 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 *)
(* prefix:
  gga_x_pbeint_params *params;

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

mu := s -> params_a_muGE + (params_a_muPBE - params_a_muGE)* \
   params_a_alpha*s^2/(1 + params_a_alpha * s^2):

(* this is the gga_x_pbe expression *)
f0 := s -> 1 + params_a_kappa * (1 - params_a_kappa/(params_a_kappa + mu(s)*s^2)):
f  := x -> f0(X2S * x):


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

`is_element/stasheff_trees` := (A::set) -> proc(RTT)
 local R,TT,r,rf,TT1,T,T1,i;
 global reason;

 if not(type(RTT,list) and nops(RTT) = 2) then
  reason := [convert(procname,string),"RTT cannot be split as [R,TT]",RTT];
  return false;
 fi;

 R,TT := op(RTT);

 if not(`is_element/ord`(A)(R)) then
  reason := [convert(procname,string),"R is not an ordering",R,reason];
  return false;
 fi;

 if not(`is_element/full_trees`(A)(TT)) then
  reason := [convert(procname,string),"TT is not a full tree",TT,reason];
  return false;
 fi;

 r := table();
 for i from 1 to nops(R) do r[R[i]] := i; od;
 rf := (a) -> r[a];

 for T in TT do
  T1 := map(rf,T);
  if nops(T1) <> (max(T1) - min(T1) + 1) then
   reason := [convert(procname,string),"T is not an R-interval",T,R,T1];
   return false;
  fi;
 od;

 return true;
end;

`is_equal/stasheff_trees` := (A::set) -> proc(RTT1,RTT2)
 local R1,TT1,R2,TT2;

 R1,TT1 := op(RTT1);
 R2,TT2 := op(RTT2);
 return `is_equal/ord`(A)(R1,R2) and `is_equal/trees`(A)(TT1,TT2);
end:

`is_leq/stasheff_trees` := (A::set) -> proc(RTT1,RTT2)
 local R1,TT1,R2,TT2;

 R1,TT1 := op(RTT1);
 R2,TT2 := op(RTT2);
 return `is_equal/ord`(A)(R1,R2) and `is_leq/trees`(A)(TT1,TT2);
end:

`random_element/stasheff_trees` := (A::set) -> proc()
 local n,R,TT;

 n := nops(A);

 if n = 0 then return FAIL; fi;

 R := `random_element/ord`(A)();
 TT := `random_element/standard_stasheff_trees`(n)();
 TT := map(U -> map(u -> R[u],U),TT);

 return([R,TT]);
end;

`list_elements/stasheff_trees` := proc(A::set)
 local n,RR,R,TTT0,TT0,TT,XX;

 n := nops(A);

 RR := `list_elements/ord`(A);
 TTT0 := `list_elements/standard_stasheff_trees`(n);

 XX := NULL;
 for R in RR do
  for TT0 in TTT0 do
   TT := map(U -> map(u -> R[u],U),TT0);
   XX := XX,[R,TT];
  od;
 od;
 return([XX]);
end;

`count_elements/stasheff_trees` := proc(A::set)
 local n,m;
 n := nops(A);
 m := `count_elements/standard_stasheff_trees`(n);
 return n! * m;
end;


    {   Plan.mpl    }

    {   Aggregate production planning for 6 months   }

    {   COPYRIGHT (C) 1987-1989,  Maximal Software   }

TITLE
    Plan_for_x_years ;

DATA
    NrOfYears = 5?;
    Dec = 12;

INDEX
    i = 1..NrOfYears ;
    j = 1..Dec ;

DATA
    Demand[j] := 1000 (90,81,102,100,140,141,180,170,140,110,90,90);

DECISION
    Invt[i,j]
    Prod[i,j]
    Work[i,j]
    OvrTm[i,j]
    Hired[i,j] -> Hir
    Fired[i,j] -> Fir

MODEL

     MIN   ProductionCost -> ProdCost  =

           SUM(i,j:     8.80 Invt
                    +  64.33 Prod
                    +  17600 Work
                    +    160 OvrTm
                    +   8800 Hired
                    +  52800 Fired) ;

SUBJECT TO

  ProdInvt[i=1,j=1] -> PrIn :  Invt  =  20000         + Prod - Demand ;
  ProdInvt[i>1,j=1] -> PrIn :  Invt  =  Invt[i-1,Dec] + Prod - Demand ;
  ProdInvt[i,j>1]   -> PrIn :  Invt  =  Invt[j-1]     + Prod - Demand ;

  HiredFired[i=1,j=1] -> HiFi :  Work - 45             =  Hired - Fired ;
  HiredFired[i>1,j=1] -> HiFi :  Work - Work[i-1,Dec]  =  Hired - Fired ;
  HiredFired[i,j>1]   -> HiFi :  Work - Work[j-1]      =  Hired - Fired ;

  ProdHours[i,j] -> PrHo  : 170 Work + OvrTm  >  0.07 Prod ;
  OvrTmWork[i,j]  -> OvWo  : OvrTm  <  50% * 170 Work ;

BOUNDS

    MaxInvt   :  Invt[j<Dec]  <  90000 ;
    CloseInvt :  Invt[j=Dec]  =  20000 ;

    MaxWork   :  Work  <  60 ;
    MaxProd   :  Prod  <  170000 ;
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: lda_exc *)

$define xc_dimensions_2d

amgb_aa := [ -0.1925,     0.117331,    0.0234188 ]:
amgb_bb := [  0.0863136, -3.394e-2,   -0.037093  ]:
amgb_cc := [  0.0572384, -7.66765e-3,  0.0163618 ]:
amgb_ee := [  1.0022,     0.4133,      1.424301  ]:
amgb_ff := [ -0.02069,    0,         0       ]:
amgb_gg := [  0.33997,    6.68467e-2,  0       ]:
amgb_hh := [  1.747e-2,   7.799e-4,    1.163099  ]:

amgb_ax = -4/(3*Pi*sqrt(2)):
amgb_beta := 1.3386:

amgb_dd := [seq(-amgb_aa[i]*amgb_hh[i], i=1..3)]:

amgb_alpha := (i, rs) -> amgb_aa[i]
  + (amgb_bb[i]*rs + amgb_cc[i]*rs^2 + amgb_dd[i]*rs^3)
  * log(1 + 1/(amgb_ee[i]*rs + amgb_ff[i]*rs^1.5 + amgb_gg[i]*rs^2 + amgb_hh[i]*rs^3)):

amgb_ex6 := (rs, z) -> -4*sqrt(2)/(3*Pi*rs)
  * (f_zeta_2d(z) - 1 - 3/8*z^2 - 3/128*z^4):

f_amgb := (rs, z) ->
  amgb_alpha(1, rs) + amgb_alpha(2, rs)*z^2 + amgb_alpha(3, rs)*z^4 + (exp(-amgb_beta*rs) - 1)*amgb_ex6(rs, z):

f := (rs, z) -> f_amgb(rs, z):


# An n-simplex in R^d is represented as a length (n+1) list of
# length d lists of real numbers.

`is_element/simplices` := (d::posint) -> (n::nonnegint) -> proc(a)
 global reason;
 local i,A,indep;

 if not (type(a,list) and nops(a) = n+1) then
  reason := ["is_element/simplices","a is not a list of length n+1",a,n];
  return false;
 fi;

 for i from 1 to n+1 do
  if not `is_element/R`(d)(a[i]) then
   reason := ["is_element/simplices","a[i] is not in R^d",a,i,d];
   return false;
  fi;
 od;

 A := Matrix([seq(a[i] -~ a[n+1],i=1..n)]);
 indep := evalb(NullSpace(Transpose(A)) = {});
 if not indep then
  reason := ["is_element/simplices","a is not affinely independent",a];
  return false;
 fi;

 return true;
end:

`is_equal/simplices` := (d::posint) -> (n::nonnegint) -> proc(a,b)
 return evalb(simplify(a -~ b) = [[0$d]$(n+1)]);
end:

`is_leq/simplices` := NULL;
`list_elements/simplices` := NULL;
`count_elements/simplices` := NULL;

`random_element/simplices` := (d::posint) -> (n::nonnegint) -> proc(m := 100)
 local indep,a,A,i,j;

 if n > d then
  error "n cannot be bigger than d";
 fi;

 indep := false;
 while not(indep) do
  a := [seq([seq(rand(-m..m)(),j=1..d)],i = 1..n+1)];
  A := Matrix([seq(a[i] -~ a[n+1],i=1..n)]);
  indep := evalb(NullSpace(Transpose(A)) = {});
 od:

 return a;
end:

`barycentre/simplex` := (d::posint)  -> proc(a)
 local n,u,i;

 n := nops(a) - 1;
 u := a[n+1];
 for i from 1 to n do u := u +~ a[i]; od;
 u := u /~ (n+1);
 return u;
end:

`radius/simplex` := (d::posint)  -> proc(a)
 local u,r,i;

 u := `barycentre/simplex`(d)(a);
 r := max(map(v -> add((v[i]-u[i])^2,i=1..d),a));
 return sqrt(r);
end:

# The primal matrix has the vertex vectors as its columns,
# but with an extra row of 1's at the bottom.

`primal_matrix/simplex` := (d::posint)  -> proc(a)
 local n,u,i;

 n := nops(a) - 1;
 return Transpose(Matrix([seq([op(a[i]),1],i=1..n+1)]));
end:

# For a d-simplex in R^d, the dual matrix is the inverse
# of the primal matrix.

`dual_matrix/simplex` := (d::posint)  -> proc(a)
 if nops(a) <> d+1 then return FAIL; fi;

 return 1/`primal_matrix/simplex`(d)(a);
end:

# With two arguments, this returns true iff the intersection
# of the simplices spanned by a and b is the simplex spanned
# by some subset c of a intersect b.  With a third argument c_,
# we require in addition that c = c_.

`intersect_nicely/simplices` := (d::posint) -> proc(a,b,c_)
 local c,aa,bb,cc,ab,n,m,p,q,e,W_cand,W_new,W_inc,W,WA,WB,A,B,r,C,w,z,i,k;

 c := {op(a)} intersect {op(b)};
 if nargs > 2 and c <> {op(c_)} then
  return false;
 fi;

 aa := [seq([op(z),1,1],z in {op(a)} minus c)];
 bb := [seq([op(-~z),-1,1],z in {op(b)} minus c)];
 cc := [seq([op(z),1,0],z in c)];
 ab := [op(aa),op(bb)];
 n := nops(aa);
 m := nops(bb);
 p := nops(cc);
 e := Vector([0$d,0,1]);
 W_cand := combinat[choose](n+m,min(d+2-p,n+m));
 W_cand := {seq({op(W)},W in W_cand)};
 W_cand := select(
  W -> W <> {} and min(op(W)) <= n and max(op(W)) > n,
  W_cand
 );

 while W_cand <> {} do
  W_new := NULL;
  W_inc := NULL;
  for W in W_cand do
   q := nops(W);
   A := Transpose(Matrix([seq(ab[w],w in W),
                          op(cc)]));
   B := ReducedRowEchelonForm(<A|e>);
   if Equal(SubMatrix(B,1..d+2,1..p+q),
            <IdentityMatrix(p+q),Matrix(d+2-p-q,p+q)>) then
    r := [seq(B[i,p+q+1],i=1..p+q)];
    if (p+q=d+2 or B[p+q+1,p+q+1] = 0) then
     if min(seq(r[k],k=1..q)) >= 0 then
      return false;
     fi;
    else
     W_inc := W_inc,W;
    fi;
   else
    WA,WB := selectremove(w -> w <= n,W);
    if nops(WA) > 1 then
     W_new := W_new,seq({op(W)} minus {w},w in WA);
    fi;
    if nops(WB) > 1 then
     W_new := W_new,seq({op(W)} minus {w},w in WB);
    fi;
   fi;
  od;
  W_cand := {W_new};
  for W in W_inc do
   W_cand := remove(U -> U minus W = {},W_cand);
  od:
 od;
 return true;
end:


input := FileTools:-Text:-ReadFile("AoC-2021-3-input.txt" ):
bins := map(b->[seq(ifelse(b[i]="0",0,1), i=1..length(b))],
            StringTools:-Split(StringTools:-Trim(input)) ):

mostcommon := proc(L)
    map(b->ifelse(b>=nops(L)/2, 1, 0),
        [seq(add(L[j][i], j=1..nops(L)), i=1..nops(L[1]))] );
end proc:
leastcommon := proc(L) map(b->ifelse(b=0, 1, 0), mostcommon(L)); end proc:
bin2dec := proc(L) add(L[-i]*2^(i-1), i=1..nops(L)); end proc:

bin2dec(mostcommon(bins)) * bin2dec(leastcommon(bins)); # part 1 answer

o2gen_bins := bins:
for i to nops(bins[1]) while nops(o2gen_bins)<>1 do
   mc := mostcommon(o2gen_bins);
   o2gen_bins := select(r->r[i]=mc[i], o2gen_bins);
end do:

co2scrub_bins := bins:
for i to nops(bins[1]) while nops(co2scrub_bins)<>1 do
   mc := leastcommon(co2scrub_bins);
   co2scrub_bins := select(r->r[i]=mc[i], co2scrub_bins);
end do:

bin2dec( o2gen_bins[] ) * bin2dec( co2scrub_bins[] ); # part 2 answer


(*
 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_pw86_params *params;

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

$ifdef gga_x_rpw86_params
params_a_aa := 15*0.1234:
params_a_bb := 17.33:
params_a_cc := 0.163:
$endif

pw86_f0 := s -> (1 + params_a_aa*s^2 + params_a_bb*s^4 + params_a_cc*s^6)^(1/15):
pw86_f  := x -> pw86_f0(X2S*x):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(pw86_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: work_gga_c *)
(* prefix:
  gga_x_n12_params *params;

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

omega_x := 2.5:
gamma_x := 0.004:

rss := (rs, z) -> rs * (2/(1 + z))^(1/3):

vx := rs -> 1/(1 + (1/(RS_FACTOR*omega_x))*rs):
ux := x -> gamma_x*x^2/(1 + gamma_x*x^2):

FN12 := (rs, x) ->
  + add(1*params_a_CC_0_[i+1]*ux(x)^i, i=0..3)
  + add(1*params_a_CC_1_[i+1]*ux(x)^i, i=0..3) * vx(rs)
  + add(1*params_a_CC_2_[i+1]*ux(x)^i, i=0..3) * vx(rs)^2
  + add(1*params_a_CC_3_[i+1]*ux(x)^i, i=0..3) * vx(rs)^3:

f_n12 := (rs, z, xt, xs0, xs1) -> -X_FACTOR_C*RS_FACTOR*(
  + (1 + z)*FN12(rss(rs,  z), xs0)/(2*rss(rs,  z))
  + (1 - z)*FN12(rss(rs, -z), xs1)/(2*rss(rs, -z))
):

f  := (rs, z, xt, xs0, xs1) -> f_n12(rs, z, xt, 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/.
*)

tpss_csi2 := (z, xt, xs0, xs1) ->
  (1 - z^2)*(t_total(z, xs0^2, xs1^2) - xt^2)/(2*(3*Pi^2)^(1/3))^2:

tpss_C0 := (cc, z, xt, xs0, xs1) ->
  + add(cc[i]*z^(2*(i-1)), i=1..4)
  / (1 + tpss_csi2(z, xt, xs0, xs1)*((1 + z)^(-4/3) + (1 - z)^(-4/3))/2)^4:

tpss_aux := (z, xt, ts0, ts1) ->
  xt^2/(8*t_total(z, ts0, ts1)):

tpss_perp := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  (1 + tpss_C0(params_a_C0_c, z, xt, xs0, xs1)*tpss_aux(z, xt, ts0, ts1)^2)
  * f_gga(rs, z, xt, xs0, xs1):

tpss_par  := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  - (1 + tpss_C0(params_a_C0_c, z, xt, xs0, xs1))*tpss_aux(z, xt, ts0, ts1)^2*(
    + m_max(gga_stoll_par(f_gga, rs,  z, xs0,  1), f_gga(rs, z, xt, xs0, xs1))
    + m_max(gga_stoll_par(f_gga, rs, -z, xs1, -1), f_gga(rs, z, xt, xs0, xs1))
  ):

f_tpss0 := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  + tpss_par (f_gga, rs, z, xt, xs0, xs1, ts0, ts1)
  + tpss_perp(f_gga, rs, z, xt, xs0, xs1, ts0, ts1):

f_tpss := (f_gga, rs, z, xt, xs0, xs1, ts0, ts1) ->
  + f_tpss0(f_gga, rs, z, xt, xs0, xs1, ts0, ts1)
  * (1 + params_a_d*f_tpss0(f_gga, rs, z, xt, xs0, xs1, ts0, ts1)*tpss_aux(z, xt, ts0, ts1)^3)
:


is_left_unit := (A::set) -> proc(m,e) local a;
 `and`(seq(evalb(m(e,a)=a),a in A)); end:

is_right_unit := (A::set) -> proc(m,e) local a;
 `and`(seq(evalb(m(a,e)=a),a in A)); end:

is_left_absorbing := (A::set) -> proc(m,z) local a;
 `and`(seq(evalb(m(z,a)=z),a in A)); end:

is_right_absorbing := (A::set) -> proc(m,z) local a;
 `and`(seq(evalb(m(a,z)=z),a in A)); end:

is_idempotent := (A::set) -> proc(m) local a;
 `and`(seq(evalb(m(a,a)=a),a in A)); end:

is_commutative := (A::set) -> proc(m) local a,b;
 `and`(seq(seq(evalb(m(a,b) = m(b,a)),b in A),a in A)); end:

is_associative := (A::set) -> proc(m) local a,b,c;
 `and`(seq(seq(seq(evalb(m(a,m(b,c))=m(m(a,b),c)),c in A),b in A),a in A)); end:

is_left_distributive := (A::set) -> proc(m,p) local a,b,c;
 `and`(seq(seq(seq(evalb(m(a,p(b,c))=p(m(a,b),m(a,c))),c in A),b in A),a in A)); end:

is_right_distributive := (A::set) -> proc(m,p) local a,b,c;
 `and`(seq(seq(seq(evalb(m(p(a,b),c)=p(m(a,c),m(b,c))),c in A),b in A),a in A)); end:

is_monoid := (A::set) -> proc(m,e)
 is_left_unit(A)(m,e) and is_right_unit(A)(m,e) and is_associative(A)(m); end:

is_semiring := (A::set) -> (m,p,e,z) ->
 is_monoid(A)(m,e) and
 is_monoid(A)(p,z) and
 is_left_absorbing(A)(m,z) and
 is_right_absorbing(A)(m,z) and
 is_left_distributive(A)(m,p) and
 is_right_distributive(A)(m,p);


(*
 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: gga_exc *)
(* prefix:
  gga_k_vt84f_params *params;

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

(* Equation (5) *)
vt84f_f0_orig := s -> 1 - params_a_mu*s^2*exp(-params_a_alpha*s^2)/(1+params_a_mu*s^2) + (1-exp(-params_a_alpha*s^4)) * (s^(-2) - 1) + 5*s^2/3:
(* Since there's a term that looks hairy at small s, do a series expansion up to s^4 *)
vt84f_f0_series := s -> eval(convert(taylor(vt84f_f0_orig(st), st = 0, 5), polynom), st=s):
(* Glue the functions together *)
vt84f_f0 := s-> my_piecewise3(s <= sqrt(DBL_EPSILON), vt84f_f0_series(s), vt84f_f0_orig(m_max(s, sqrt(DBL_EPSILON)))):

(* Convert from x to s *)
vt84f_f := x -> vt84f_f0(X2S*x):

f := (rs, z, xt, xs0, xs1) ->
  gga_kinetic(vt84f_f, rs, z, xs0, xs1):


#######################################################################
# This file is part of the crlibm library, and is distributed under
# the  LGPL.
# To use:
# restart; read "log-de.mpl";
#TODO output scripts for the Gappa proof out for Paterson/Stockmayer
Digits := 100:

interface(quiet=true):

read "common-procedures.mpl":
read "double-extended.mpl":
mkdir("TEMPLOG"):

log2h,log2l := hiloExt(log(2)):

L := 7: # number of bits used to address the table

MAXINDEX    := round(2^L * (sqrt(2)-1)):

for i from 0 to MAXINDEX-1 do
    center[i] := 1 + i*2^(-L): # center[i] in [1, 2[
    # We want it to fit on 11 bits of mantissa
    r[i] :=  round(evalf(  (1/center[i]) * 2^(11)) ) / 2^(11) ;

od:
for i from MAXINDEX to 2^L do
    # y has been divided by two, center[i] in [0.5, 1[
    center[i]:=(1 + i*2^(-L)) / 2:
    # We want it to fit on 11 bits of mantissa,
    r[i] :=  round(evalf(  (1/center[i]) * 2^(10)) ) / 2^(10) ;
od:

# Note that we go up to 2^L although the case 2^L is wrapped to zero
# in the C code. It could be important for zmax (but it turns out not).

for i from 0 to 2^L do
    (logirh[i], logirl[i]) := hiloExt(-log(r[i])):
od:

#Computation of ZMax.
for i from 0 to MAXINDEX-1 do
    t_x := center[i] + 2^(-L-1) :
    zmax[i] := (t_x*r[i]-1) :
    t_x := center[i] - 2^(-L-1) :
    zmin[i] := (t_x*r[i]-1) :
    zabsmax[i] := max(abs(zmin[i]), abs(zmax[i])):
od:
for i from MAXINDEX to 2^L do
    t_x := center[i] + 2^(-L-2) :
    zmax[i] := (t_x*r[i]-1) :
    t_x := center[i] - 2^(-L-2) :
    zmin[i] := (t_x*r[i]-1) :
    zabsmax[i] := max(abs(zmin[i]), abs(zmax[i])):
od:

zmaxmax:=0:
zminmin:=0:
for i from 0 to 2^L do
    if zmax[i] > zmaxmax then zmaxmax := zmax[i]: fi:
    if zmin[i] < zminmin then zminmin := zmin[i]: fi:
od:
printf("zminmin = -2^(%2f)   zmaxmax = 2^(%2f)\n", log2(-zminmin), log2(zmaxmax) ) :

PolyDegreeQuick:=7:

#Keep -zmaxmax..zmaxmax to keep c1=1, which is useful in the proof

if(1+1=3) then # The polynomial used to be computed here,
polyQuick:= polyExact2Ext(x  * numapprox[minimax](  log(1+x)/x,  x=-zmaxmax..zmaxmax,  [PolyDegreeQuick-1,0], 1 ,  'deltaApprox'), 0):

epsilonApproxQuick := numapprox[infnorm]( 1-polyQuick/log(1+x), x=zminmin..zmaxmax):
deltaApproxQuick := numapprox[infnorm]( polyQuick-log(1+x), x=zminmin..zmaxmax):
else
# magical polynomial given by Sylvain's tool
polyQuick := x * (1 + (x * ((-0.50000000000000000000000000000000000000000000000000000000000000e0) + (x * (0.33333333333333342585191871876304503530263900756835937500000000e0 + (x * ((-0.24999999998423708125194764306797878816723823547363281250000000e0) + (x * (0.19999999996748479835773082413652446120977401733398437500000000e0 + (x * ((-0.16666957260954737285452154083031928166747093200683593750000000e0) + (x * 0.14286056338555042088955815415829420089721679687500000000000000e0)))))))))))):

# validated infinite norms given by Christoph's tool
epsilonApproxQuick := 2^(-64.119667587221):
deltaApproxQuick := 2^(-72.230387592107):
fi:
printf(" rel approximation error for the quick phase is 2^(%2f)\n", log2(epsilonApproxQuick) ) :
printf(" abs approximation error for the quick phase is 2^(%2f)\n", log2(deltaApproxQuick) ) :

# For the Paterson/Stockmayer method
polyQuick0:= x  * numapprox[minimax](  log(1+x)/x,  x=-zmaxmax..zmaxmax,  [PolyDegreeQuick-1,0], 1 ,  'deltaApprox'):

## Création des nouveaux coefficients
polyQuick0:= x  * numapprox[minimax](  log(1+x)/x,  x=-zmaxmax..zmaxmax,  [PolyDegreeQuick-1,0], 1 ,  'deltaApprox'):

## Création des nouveaux coefficients
a7 := convert(coeff(polyQuick0,x,7),rational):
a6 := convert(coeff(polyQuick0,x,6)/a7,rational):
a5 := convert(coeff(polyQuick0,x,5)/a7,rational):
a4 := convert(coeff(polyQuick0,x,4)/a7,rational):

a3 := convert(coeff(polyQuick0,x,3),rational):
a2 := convert(coeff(polyQuick0,x,2),rational):
a1 := convert(coeff(polyQuick0,x,1),rational):
a0 := convert(coeff(polyQuick0,x,0),rational):

alpha0 := a5 - 1:
alpha1 := a6:
alpha2 := a4 - alpha0 * a6:

##
a7_hi,a7_lo         := hiloExt(a7):
a3_hi,a3_lo         := hiloExt(a3):
a2_hi,a2_lo         := hiloExt(a2):
a0_hi,a0_lo         := hiloExt(a0):

c_hi,c_lo         := hiloExt(alpha0):
alpha_hi,alpha_lo := hiloExt(alpha1):
beta_hi,beta_lo   := hiloExt(alpha2):

#coef_c := c_hi + c_lo:
#coef_alpha := alpha_hi + alpha_lo:
#coef_beta := beta_hi + beta_lo:
#coef_c7 := a7_hi + a7_lo:
#coef_c3 := a3_hi + a3_lo:
#coef_c2 := a2_hi + a2_lo:
#coef_c0 := a0_hi + a0_lo:

coef_c := c_hi:
coef_alpha := alpha_hi:
coef_beta := beta_hi:
coef_c7 := a7_hi:
coef_c3 := a3_hi:
coef_c2 := a2_hi:
coef_c0 := a0_hi:

polyQuickPat := ((x^2 + coef_c)*(x + coef_alpha) + (x + coef_beta)) * (coef_c7*x^4) + ((coef_c3 * x + coef_c2)*x^2 + (x)):

epsilonApproxQuickPat := numapprox[infnorm]( 1-polyQuickPat/log(1+x), x=zminmin..zmaxmax):
printf("   approximation rel error for Paterson/Stockmayer in the quick phase is 2^(%2f)\n", log2(epsilonApproxQuickPat) ) :
deltaApproxQuickPat := numapprox[infnorm]( polyQuickPat-log(1+x), x=zminmin..zmaxmax):
printf("   approximation abs error for Paterson/Stockmayer in the quick phase is 2^(%2f)\n", log2(deltaApproxQuickPat) ) :

PolyDegreeAccurate:=14:

printf("Computing the polynomial for accurate phase (this may take some time...)\n"):
pe:= x  * numapprox[minimax](  log(1+x)/x,  x=-zmaxmax..zmaxmax,  [PolyDegreeAccurate-1,0], 1 ,  'deltaApprox'):

MaxDegreeDDE:=8:  #

polyAccurate := polyExact2Ext(pe, MaxDegreeDDE):
deltaApproxAccurate := numapprox[infnorm](polyAccurate-log(1+x), x=-zmaxmax..zmaxmax):
epsilonApproxAccurate := numapprox[infnorm]( 1-polyAccurate/log(1+x), x=-zmaxmax..zmaxmax):
printf("   approximation error for the accurate phase is 2^(%2f)\n", log2(epsilonApproxAccurate) ) :

filename:="TEMPLOG/log-de.h":
fd:=fopen(filename, WRITE, TEXT):

fprintf(fd, "/*File generated by maple/log-de.mpl*/\n\n"):
# some constants
fprintf(fd, "#define L        %d\n", L):
fprintf(fd, "#define MAXINDEX %d\n", MAXINDEX):
fprintf(fd, "#define INDEXMASK %d\n", 2^L-1):
fprintf(fd, "static const double two64 = %1.25e ;\n", evalf(2^64)):

fprintf(fd, "#if 1\n#define ESTRIN\n#else\n#define PATERSON\n#endif\n"):

fprintf(fd, "#if defined(CRLIBM_TYPECPU_X86) || defined(CRLIBM_TYPECPU_AMD64)\n\n"):

fprintf(fd, "#ifdef PATERSON\n"):
  #  polynomial for quick phase
  fprintf(fd,"static const long double c7 = %1.50e;\n",coef_c7):
  fprintf(fd,"static const long double c3 = %1.50e;\n",coef_c3):
  fprintf(fd,"static const long double c2 = %1.50e;\n",coef_c2):
  fprintf(fd,"static const long double ps_alpha = %1.50e;\n",coef_alpha):
  fprintf(fd,"static const long double ps_beta = %1.50e;\n",coef_beta):
  fprintf(fd,"static const long double ps_c = %1.50e;\n",coef_c):
fprintf(fd, "#endif/* PATERSON*/\n\n"):

fprintf(fd, "#ifdef ESTRIN\n"):
 fprintf(fd, "  /* Coefficients are read directly from the array thanks to the following macros */ \n"):
  for i from PolyDegreeQuick to 2 by -1 do
    fprintf(fd, "#define c%d  c[%d]\n", i, PolyDegreeQuick-i):
  od:
   fprintf(fd, "static const double c[%d] =  {\n",PolyDegreeQuick):
   for i from PolyDegreeQuick to 2 by -1 do
     fprintf(fd, "   /* c%d  = */ %1.50eL, \n", i, coeff(polyQuick,x,i)):
   od:
  fprintf(fd, "}; \n \n"):
fprintf(fd, "#endif/* ESTRIN */\n\n"):

  for i from PolyDegreeAccurate to 1 by -1 do
    fprintf(fd, "#define c%dh  ch[%d]\n", i, PolyDegreeAccurate-i):
  od:

  for i from MaxDegreeDDE-1 to 1 by -1 do
    fprintf(fd, "#define c%dl  cl[%d]\n", i, MaxDegreeDDE-1-i):
  od:
  fprintf(fd, "#define PREFETCH_POLY_ACCURATE \n"):
  fprintf(fd, "\n#else /* not(defined(CRLIBM_TYPECPU_X86) || defined(CRLIBM_TYPECPU_AMD64)),\n   assuming Itanium, otherwise we shouldn't be there */ \n\n"):
  fprintf(fd, "#define PREFETCH_POLY_QUICK "):
  for i from PolyDegreeQuick to 2 by -1 do
    fprintf(fd, "c%d=c[%d]; ", i, PolyDegreeQuick-i):
  od:
  fprintf(fd, "\n#define PREFETCH_POLY_ACCURATE "):
  for i from PolyDegreeAccurate to 1 by -1 do
    fprintf(fd, "c%dh=ch[%d]; ", i, PolyDegreeAccurate-i):
    if i mod 4 =0 then  fprintf(fd, "\\\n        "): fi:
  od:
  fprintf(fd, "\\\n        "):
  for i from MaxDegreeDDE-1 to 1 by -1 do
    fprintf(fd, "c%dl=cl[%d]; ", i, MaxDegreeDDE-1-i):
  od:

  fprintf(fd, "\n#endif /* defined(CRLIBM_TYPECPU_X86) || defined(CRLIBM_TYPECPU_AMD64) */ \n\n"):

  # Various constants
  fprintf(fd, "static const long double log2H  = %1.50eL ;\n", log2h):
  fprintf(fd, "static const long double log2L  = %1.50eL ;\n", log2l):

  # The polynomials
  #  polynomial for quick phase
#  for i from PolyDegreeQuick to 1 by -1 do
#    fprintf(fd, "static const long double c%d =    %1.50eL ;\n", i, coeff(polyQuick,x,i)):
#  od:

  #  polynomial for accurate phase
  fprintf(fd, "static const long double ch[%d] =  {\n",PolyDegreeAccurate):
   for i from PolyDegreeAccurate to 1 by -1 do
     (ch, cl) := hiloExt(coeff(polyAccurate,x,i)):
     fprintf(fd, "   /* ch%d  = */ %1.50eL, \n", i, ch):
   od:
  fprintf(fd, "}; \n \n"):

  fprintf(fd, "static const long double cl[%d] =  {\n", MaxDegreeDDE):
  for i from MaxDegreeDDE-1 to 1 by -1 do
     (ch, cl) := hiloExt(coeff(polyAccurate,x,i)):
     fprintf(fd, "   /* cl%d  = */ %1.50eL, \n", i, cl):
   od:
  fprintf(fd, "}; \n \n"):

  # The tables

  fprintf(fd, "typedef struct rri_tag {float r; long double logirh;  long double logirl; } rri ;  \n"):
  fprintf(fd, "static const rri argredtable[%d] = {\n", 2^L):
  for i from 0 to 2^L-1 do
      fprintf(fd, "  { \n"):
      fprintf(fd, "    %1.50eL,   /* r[%d] */ \n", r[i], i):
      fprintf(fd, "    %1.50eL, /* logirh[%d] */ \n", logirh[i], i):
      fprintf(fd, "    %1.50eL, /* logirl[%d] */ \n", logirl[i], i):
      fprintf(fd, "  } "):
      if(i<2^L-1) then  fprintf(fd, ", \n"): fi
  od:
fprintf(fd, "}; \n \n"):

fclose(fd):

printf("\n************ DONE TEMPLOG/log-de.h ************\n");

filename:="TEMPLOG/polynomials.sed":
fd:=fopen(filename, WRITE, TEXT):
for i from PolyDegreeAccurate to 1 by -1 do
    (ch, cl) := hiloExt(coeff(polyAccurate,x,i)):
    fprintf(fd, " s/_c%dh/%1.40e/g\n", i, ch):
    if(i<MaxDegreeDDE) then
        fprintf(fd, " s/_c%dl/%1.40e/g\n", i, cl):
    fi:
od:
for i from PolyDegreeQuick to 1 by -1 do
    fprintf(fd, " s/_c%d/%1.40e/g\n", i, coeff(polyQuick,x,i)):
od:
fprintf(fd, " s/_deltaApproxQuick/%1.40e/g\n", deltaApproxQuick):
fprintf(fd, " s/_epsilonApproxQuick/%1.40e/g\n", epsilonApproxQuick):
fprintf(fd, " s/_deltaApproxAccurate/%1.40e/g\n", deltaApproxAccurate):
fprintf(fd, " s/_epsilonApproxAccurate/%1.40e/g\n", epsilonApproxAccurate):
fprintf(fd, " s/_log2h/%1.40e/g\n", log2h):
fprintf(fd, " s/_log2l/%1.40e/g\n", log2l):
fclose(fd):

printf("\n************ DONE TEMPLOG/polynomials.sed ************\n");

for j from 0 to 2^L-1 do
    filename:=cat("TEMPLOG/log-de_",j,".sed"):
    fd:=fopen(filename, WRITE, TEXT):
    fprintf(fd, " s/_rval/%1.40e/g\n",     r[j]):
    fprintf(fd, " s/_logirh/%1.40e/g\n", logirh[j]):
    fprintf(fd, " s/_logirl/%1.40e/g\n", logirl[j]):
    fprintf(fd, " s/_zabsmax/%1.40e/g\n", zabsmax[j]):
    fclose(fd):
  od:

printf("\n************ DONE TEMPLOG/log-de*.sed ************\n");

# A shell script to use them
filename:="../gappa/log-de/run-log-de-proof.sh":
fd:=fopen(filename, WRITE, TEXT):
fprintf(fd, "#!/bin/sh\n"):
fprintf(fd, "# You probably need to edit the path to the gappa executable\n"):
fprintf(fd, "GAPPA=~/local/src/gappa/src/gappa\n"):
fprintf(fd, "CRLIBMDIR=../..\n"):

fprintf(fd, "echo Accurate phase, case E=0, index=0: 1>&2\n"):
fprintf(fd, "sed  -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_0.sed $CRLIBMDIR/gappa/log-de/log-de-acc-index0-E0.gappa | $GAPPA \n"):

fprintf(fd, "echo Accurate phase, case E!=0, index=0 1>&2\n"):
fprintf(fd, "sed  -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_0.sed $CRLIBMDIR/gappa/log-de/log-de-acc-index0-E1N.gappa | $GAPPA \n"):

fprintf(fd, "for num in `seq 1 %d`; do\n", 2^L-1):
fprintf(fd, "  echo Accurate phase, case E=0, index=$num 1>&2\n"):
fprintf(fd, "  sed -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_$num.sed $CRLIBMDIR/gappa/log-de/log-de-acc-index1N-E0.gappa | $GAPPA \n"):
fprintf(fd, "  echo 1>&2\n"):
fprintf(fd, "done\n"):

fprintf(fd, "for num in `seq 1 %d`; do\n", 2^L-1):
fprintf(fd, "  echo Accurate phase, case E!=0, index = $num 1>&2 \n"):
fprintf(fd, "  sed -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_$num.sed $CRLIBMDIR/gappa/log-de/log-de-acc-index1N-E1N.gappa | $GAPPA \n"):
fprintf(fd, "  echo 1>&2\n"):
fprintf(fd, "done\n\n"):

fprintf(fd, "echo Quick phase, case E=0, index=0  1>&2\n"):
fprintf(fd, "sed  -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_0.sed $CRLIBMDIR/gappa/log-de/log-de-index0-E0.gappa | $GAPPA \n"):
fprintf(fd, "  echo 1>&2\n"):

fprintf(fd, "echo Quick phase, case E!=0, index=0 1>&2 \n"):
fprintf(fd, "sed  -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_0.sed $CRLIBMDIR/gappa/log-de/log-de-index0-E1N.gappa | $GAPPA \n"):
fprintf(fd, "  echo 1>&2\n"):

fprintf(fd, "for num in `seq 1 %d`; do\n", 2^L-1):
fprintf(fd, "  echo Quick phase, for all E,  index=$num 1>&2\n"):
fprintf(fd, "  sed  -f $CRLIBMDIR/maple/TEMPLOG/polynomials.sed  -f $CRLIBMDIR/maple/TEMPLOG/log-de_$num.sed $CRLIBMDIR/gappa/log-de/log-de-index1N-E0N.gappa | $GAPPA \n"):
fprintf(fd, "  echo 1>&2\n"):
fprintf(fd, "done\n"):

fclose(fd):

printf("\n************ DONE TEMPLOG/run-log-de-proof.sh ************\n"):
printf("Now you should run \n"):
printf(" sh ../../gappa/log-de/run-log-de-proof.sh  2> ../../maple/TEMPLOG/Gappa.out\n"):
printf("  (You probably need to edit the path to the gappa executable within run-log-de-proof.sh)\n"):
printf("Then look at TEMPLOG/Gappa.out. It shouldn't contain 'some enclosures were not satisfied'.\n If it does, report it !\n"):

printf("----DONE---\n") :


(*
 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 *)

f0 := x -> 1 + 0.0055*x^2/(1 + 0.0253*x*arcsinh(x)):
f1 := x -> -0.072*x/(1 + 2*4^(1/3)*x):

f := x -> f0(x) + f1(x):


(*
 Copyright (C) 2017 M.A.L. Marques
               2019 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: gga_exc *)
(* prefix:
  gga_x_ev93_params *params;

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

ev93_f0 := s -> (1 + params_a_a1*s^2 + params_a_a2*s^4 + params_a_a3*s^6)/(1 + params_a_b1*s^2 + params_a_b2*s^4 + params_a_b3*s^6):
ev93_f  := x -> ev93_f0(X2S*x):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(ev93_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: gga_exc *)

$define gga_x_rpw86_params
$include "gga_x_pw86.mpl"

lv_alpha := 0.02178:
lv_beta  := 1.15:
lv_muLV   := 0.8491/9:

lv_f0 := s ->
   + (1 + lv_muLV*s^2)/(1 + lv_alpha*s^6)
   + lv_alpha*s^6*pw86_f0(s)/(lv_beta + lv_alpha*s^6):

lv_f  := x -> lv_f0(X2S*x):

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


(*
 Copyright (C) 2017 M.A.L. Marques
 Copyright (C) 2018 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_x_ms_params *params;

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

ms_fa := a -> (1 - a^2)^3 / (1 + a^3 + params_a_b*a^6):
ms_f0 := (p, c) -> 1 + params_a_kappa*(1 - params_a_kappa/(params_a_kappa + MU_GE*p + c)):

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

ms_f := (x, u, t) -> ms_f0(X2S^2*x^2, 0) + \
  ms_fa(ms_alpha(t,x))*(ms_f0(X2S^2*x^2, params_a_c) - ms_f0(X2S^2*x^2, 0)):

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


(*
 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 *)

mbeta  :=  0.0042:
mgamma :=  6:
c0    :=  1.09878:
c1    := -2.51173:
c2    :=  0.0156233:

f_aux := x -> 1 + mgamma*mbeta*x*arcsinh(x):

f := x -> c0 + mbeta/X_FACTOR_C*x^2*(c1/f_aux(x) + c2/(mbeta*f_aux(x)^2)):


(*
 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 *)

mbeta := 0.018641:
mcsi  := 8: (* for harmonic potentials *)

f := x -> 1 + mbeta/X_FACTOR_2D_C*x^2/(1 + mcsi*mbeta*x*arcsinh(x)):


# Taken from
# N. Tuncer, T. Le
# "Structural and practical identifiability analysis of outbreak models"
# https://doi.org/10.1016/j.mbs.2018.02.004
# Equation (2.2) with cumulative incidence observations
read "../ComputeIdentifiableFunctions.mpl";

# Prevalence observations
model := [
  diff(S(t), t) = b * S(t) * In(t) / N,
  diff(E(t), t) = b * S(t) * In(t) / N - nu * E(t),
  diff(In(t), t) = nu * E(t) - a * In(t),
  y(t) = In(t),
  y2(t) = N
]:

me := MultiExperimentIdentifiableFunctions(model, simplified_generators=true):
printf("The bound for the number of experiments is %a, this means that the fields of single-experiment and multi-experiment identifiable functions coincide, and they are equal to: %a\n", me[1], me[3]):

# Cummulative incidence observations
# using change of variables Ninv := 1 / N to simplify the computation
model := [
  diff(S(t), t) = b * S(t) * In(t) * Ninv,
  diff(E(t), t) = b * S(t) * In(t) * Ninv - nu * E(t),
  diff(In(t), t) = nu * E(t) - a * In(t),
  diff(Cu(t), t) = nu * E(t),
  y(t) = Cu(t),
  y2(t) = Ninv
]:

me := MultiExperimentIdentifiableFunctions(model, simplified_generators=true, infolevel=1):
printf("The bound for the number of experiments is %a, this means that the field of multi-experiment identifiable functions is the same, %a\n", me[1], me[3]):


(*
 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_vxc *)
(* prefix:
  gga_x_lb_params *params;

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

lb_f0 := (rs, z, x) -> -my_piecewise3(x < 300,
         params_a_beta*x^2/(1 + 3*params_a_beta*x*arcsinh(params_a_gamma*x)),
         x/(3*log(2*params_a_gamma*x))):

lb_f := (rs, z, x) -> (params_a_alpha*(4/3)*LDA_X_FACTOR + lb_f0(rs, z, x))*n_spin(rs, z)^(1/3):

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


######################################################################
# prime_simplex_boundary(A) is the set of maps x : A -> [0,1] with
# min = 0 and max = 1.

`is_element/prime_simplex_boundary` := (A::set) -> proc(x)
 local a,u,v,w;
 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;
 w := 1;

 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 := max(u,v);
  w := min(u,w);
 od;

 if simplify(v - 1) <> 0 then
  reason := [convert(procname,string),"max(x[a] : a in A) <> 1",v];
  return false;
 fi;

 if simplify(w) <> 0 then
  reason := [convert(procname,string),"min(x[a] : a in A) <> 0",w];
  return false;
 fi;

 return true;
end;

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

`is_equal/prime_simplex_boundary` := (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/prime_simplex_boundary` := NULL;

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

`random_element/prime_simplex_boundary` := (A::set) -> proc(d::posint := 5)
 local x,a,r1,r2,u,v;

 if nops(A) < 2 then return FAIL; fi;

 r1 := rand(0..d);
 r2 := rand(1..d);
 x := table();
 u := 0;
 v := 0;

 while u = v do
  u := 0;
  v := infinity;
  for a in A do
   x[a] := r1()/r2();
   u := max(u,x[a]);
   v := min(v,x[a]);
  od;
 od;

 for a in A do x[a] := (x[a]-v)/(u-v); od;

 return eval(x);
end;

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

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

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

`phi/proper_nonempty_subsets/prime_simplex_boundary` := (A::set) -> proc(U)
 local x,a;

 x := table();
 for a in A do x[a] := 0; od;
 for a in U do x[a] := 1; 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: lda_exc *)
(* prefix:
  lda_c_pw_params *params;

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

$ifdef lda_c_pw_params
params_a_pp     := [1,  1,  1]:
params_a_a      := [0.031091, 0.015545, 0.016887]:
params_a_alpha1 := [0.21370,  0.20548,  0.11125]:
params_a_beta1  := [7.5957, 14.1189, 10.357]:
params_a_beta2  := [3.5876, 6.1977, 3.6231]:
params_a_beta3  := [1.6382, 3.3662,  0.88026]:
params_a_beta4  := [0.49294, 0.62517, 0.49671]:
params_a_fz20   := 1.709921:
$endif

$ifdef lda_c_pw_modified_params
params_a_a      := [0.0310907, 0.01554535, 0.0168869]:
params_a_fz20   := 1.709920934161365617563962776245:
$endif

(* Equation (10) *)
g_aux := (k, rs) -> params_a_beta1[k]*sqrt(rs) + params_a_beta2[k]*rs
  + params_a_beta3[k]*rs^1.5 + params_a_beta4[k]*rs^(params_a_pp[k] + 1):
g     := (k, rs) -> -2*params_a_a[k]*(1 + params_a_alpha1[k]*rs)
  * log(1 +  1/(2*params_a_a[k]*g_aux(k, rs))):

(* Equation (8) *)
(* Attention, the function g parametrizes -alpha *)
f_pw := (rs, zeta) ->
  g(1, rs) + zeta^4*f_zeta(zeta)*(g(2, rs) - g(1, rs) + g(3, rs)/params_a_fz20)
  - f_zeta(zeta)*g(3, rs)/params_a_fz20:

f := (rs, zeta) -> f_pw(rs, zeta):


(*
 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 *)

thakkar_f0 := x -> 1 + 0.0055*x^2/(1 + 0.0253*x*arcsinh(x)):
thakkar_f1 := x -> -0.072*x/(1 + 2*4^(1/3)*x):

thakkar_f := x -> thakkar_f0(x) + thakkar_f1(x):

f := (rs, zeta, xt, xs0, xs1) -> gga_kinetic(thakkar_f, rs, zeta, xs0, xs1):


is_numerical_poly := proc(g,u)
 local m,h;

 if not(type(g,polynom(rational,u))) then
  return false;
 fi;

 m := degree(g,u);
 h := g;
 while m >= 0 do
  if not(type(subs(u=0,h),integer)) then
   return(false);
  fi;
  h := expand(subs(u=u+1,h)-h);
  m := m-1;
 od:
 return(true);
end:

`b/numerical_poly` := (k::nonnegint,u) -> expand(binomial(u,k));

`alpha/numerical_poly` := proc(i::nonnegint,j::nonnegint,k::nonnegint)
 if i <= k and j <= k and k <= i+j then
  return k!/((k-i)!*(k-j)!*(i+j-k)!);
 else
  return 0;
 fi;
end:

`beta/numerical_poly` := proc(i::nonnegint,j::nonnegint,k::nonnegint)
 local m,n;

 add(add(
  (-1)^(m+n)*binomial(i,m)*binomial(j,n)*binomial((i-m)*(j-n),k),
   n=0..j),m=0..i);

end:

`Delta/numerical_poly` := proc(f,u)
 subs(u = u+1,f) - f;
end:

`gamma/numerical_poly` := proc(p,n)
 local N;
 N := floor(n/(p-1));
 N + padic_val(N!,p);
end:

`Gamma/numerical_poly` := proc(n::posint)
 local g,i,p;
 g := 1;
 i := 1;
 p := ithprime(i);
 while p <= 2*n do
  g := g * p^`gamma/numerical_poly`(p,n);
  i := i+1;
  p := ithprime(i);
 od;
 return(g);
end:

`Gamma_alt/numerical_poly` := proc(n::posint)
 local k;

 if modp(n,2) <> 0 then return FAIL; fi;

 return mul(2*denom(bernoulli(2*k)/(2*k)),k=1..n/2);
end:

# There is a canonical basis for the ring of stably numerical
# polynomials, as discussed in the document ImJ.tex.
# The first few basis elements are as follows:

`f/stably_numerical_poly` := table([
  0 = ((u) -> 1),
  1 = ((u) -> (u+1)/2),
  2 = ((u) -> (u^2-1)/24),
  3 = ((u) -> (u^3+u^2-u-1)/48),
  4 = ((u) -> (u^4+70*u^2-71)/5760),
  5 = ((u) -> (u^5+u^4+70*u^3+70*u^2-71*u-71)/11520)
]);

`f_witness/stably_numerical_poly` := table([
 "max_deg" = 5,
 "u_shift" = table([0 = 0,1 = 1,2 = 3,3 = 4,4 = 7,5 = 8]),
 "eval_points"  = [1,-1,7,11,13,17,23,37],
 "split_matrix" =
 [[0, 1, 0, 0, 0, 0, 0, 0],
  [1, -1, 0, 0, 0, 0, 0, 0],
  [-2497, 1127, 5994, -13853, 10734, -1511, 2, 4],
  [-628, 283, 1513, -3505, 2720, -385, 1, 1],
  [-4976, 2245, 11943, -27574, 21348, -2996, 2, 8],
  [-4334, 1955, 10406, -24026, 18599, -2608, 1, 7]]
]):

`find_split_matrix/stably_numerical_poly` := proc()
 local f,W,d,A,m,B,eqs,sol,i,j;

 f := `f/stably_numerical_poly`;
 W := `f_witness/stably_numerical_poly`;
 d := W["max_deg"];

 A := Transpose(Matrix(
  [seq(map(f[i],W["eval_points"]),i=0..d)]));

 m := nops(W["eval_points"]);

 B := Matrix([seq([seq(b[i,j],j=1..m)],i=0..d)]):

 eqs := {op(map(r -> r = 0,map(op,convert(B.A - IdentityMatrix(d+1),listlist))))}:
 sol := isolve(eqs);

 if sol = NULL then return FAIL; fi;

 B := subs(sol,B);
 B := subs(map(u -> u=0,indets(B)),B);

 return B;
end:

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

`check_witness/stably_numerical_poly` := proc()
 global Z;
 local f,W,d,s,i,j,M,A,B,p;

 f := `f/stably_numerical_poly`;
 W := `f_witness/stably_numerical_poly`;
 d := W["max_deg"];

 _ASSERT(type(d,posint),"max_deg is a positive integer");

 for i from 0 to d do
  s := W["u_shift"][i];
  _ASSERT(is_numerical_poly(u^s*f[i](u),u),
          sprintf("f_%d(u) is stably numerical",i));
 od:

 for i from 0 to d do
  M[i] := 1/coeff(f[i](u),u,i);
  _ASSERT(type(M[i],posint),sprintf("Leading coefficient of f_%d(u) is egyptian",i));
  _ASSERT(
   `and`(seq(-1/(2*M[i]) < coeff(f[j](u),u,i) and
             coeff(f[j](u),u,i) <= 1/(2*M[i]),j=i+1..d)),
   sprintf("Coefficient bounds for f_%d(u)",i));
 od:

 _ASSERT(type(W["eval_points"],list(integer)),"eval_points is a list of integers");

 for p in W["eval_points"] do
  _ASSERT(p = 1 or p = -1 or (p > d and isprime(p)),
          sprintf("evaluation point %d is +/- 1 or prime and greater than max_deg",p));
 od:

 A := Transpose(Matrix(
  [seq(map(f[i],W["eval_points"]),i=0..d)]));

 B := Matrix(W["split_matrix"]);
 Z := [A,B];

 _ASSERT(Equal(B.A,IdentityMatrix(d+1)),"split_matrix splits");

end:

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

check_numerical_poly := proc()
 local u,v,i,j,k,n,ok,err;

 _ASSERT(
  `b/numerical_poly`(0,u) = 1,
  "b_0(u) = 1"
 );

 _ASSERT(
  `b/numerical_poly`(1,u) = u,
  "b_1(u) = u"
 );

 ok := true;
 for k from 0 to 10 do
  err :=
   `b/numerical_poly`(k,u+v) -
    add(`b/numerical_poly`(i,u) * `b/numerical_poly`(k-i,v),i=0..k);

  err := expand(err);
  if err <> 0 then ok := false; break; fi;
 od:
 _ASSERT(ok,"Formula for b_k(u+v)");

 ok := true;
 for k from 0 to 10 do
  err :=
   `b/numerical_poly`(k,u*v) -
    add(add(
     `beta/numerical_poly`(i,j,k) *
      `b/numerical_poly`(i,u) *
       `b/numerical_poly`(j,v),
    j=0..k),i=0..k);

  err := expand(err);
  if err <> 0 then ok := false; break; fi;
 od:
 _ASSERT(ok,"Formula for b_k(uv)");

 ok := true;
 for i from 0 to 10 do
  for j from 0 to 10 do
   err := `b/numerical_poly`(i,u) * `b/numerical_poly`(j,u) -
    add(
     `alpha/numerical_poly`(i,j,k) * `b/numerical_poly`(k,u),
      k = 0 .. i+j);
   err := expand(err);

   if err <> 0 then ok := false; break; fi;
  od:

  if not(ok) then break; fi;
 od:
 _ASSERT(ok,"Formula for b_i(u) b_j(u)");

 _ASSERT(`Delta/numerical_poly`(`b/numerical_poly`(0,u),u) = 0,"Delta(b_0) = 0");

 _ASSERT(
  `and`(seq(
   expand(`Delta/numerical_poly`(`b/numerical_poly`(i+1,u),u) - `b/numerical_poly`(i,u))=0,
    i=0..10)),
   "Delta(b_{i+1}(u)) = b_i(u)"
 );

 _ASSERT(
  `and`(seq(`Gamma_alt/numerical_poly`(2*n) =
            `Gamma/numerical_poly`(2*n),n=1..10)),
  "Gamma in terms of Bernoulli numbers"
 );
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 *)

c09x_mu    := 0.0617:
c09x_kappa := 1.245:
c09x_alpha := 0.0483:

c09x_f0 := s -> 1 + c09x_mu*s^2*exp(-c09x_alpha*s^2) + c09x_kappa*(1 - exp(-1/2*c09x_alpha*s^2)):
c09x_f  := x -> c09x_f0(X2S*x):

f := (rs, z, xt, xs0, xs1) -> gga_exchange(c09x_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: work_gga_c *)

$define gga_c_pbe_params
$include "gga_c_pbe.mpl"

$include "lda_c_2d_amgb.mpl"

rs2D_factor := 1.704:
q2d_dd := 1e6:

q2d_rs2D := (rs, xt) -> rs2D_factor*rs*sqrt(X2S*xt)/RS_FACTOR:

fac := t -> t^4*(1 + t^2)/(q2d_dd + t^6):

f_q2d := (rs, z, xt, xs0, xs1) ->
  (1 - fac(tt(rs, z, xt)))*f_pbe(rs, z, xt, xs0, xs1) + fac(tt(rs, z, xt))*f_amgb(q2d_rs2D(rs, xt), z):

f := (rs, z, xt, xs0, xs1) -> f_q2d(rs, z, xt, 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 *)
(* prefix:
  lda_c_pz_params *params;

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

$ifdef lda_c_pz_params
params_a_gamma := [-0.1423, -0.0843]:
params_a_beta1 := [ 1.0529,  1.3981]:
params_a_beta2 := [ 0.3334,  0.2611]:
params_a_a     := [ 0.0311,  0.01555]:
params_a_b     := [-0.048,  -0.0269]:
params_a_c     := [ 0.0020,  0.0007]:
params_a_d     := [-0.0116, -0.0048]:
$endif

(* Equation C3 *)
ec_low  := (i, rs) -> params_a_gamma[i] / \
        (1 + params_a_beta1[i]*sqrt(rs) + params_a_beta2[i]*rs):

(* Equation [1].C5 *)
ec_high := (i, rs) -> params_a_a[i]*log(rs) + params_a_b[i] \
        + params_a_c[i]*rs*log(rs) + params_a_d[i]*rs:

ec := (i, x) -> my_piecewise3(x >= 1, ec_low(i, x), ec_high(i, x)):

f_pz := (rs, zeta) -> \
 ec(1, rs) + (ec(2, rs) - ec(1, rs))*f_zeta(zeta):

f := (rs, zeta) -> f_pz(rs, zeta):


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

# Complex numbers

`is_element/CC` := (x) -> type(x,constant):

`is_equal/CC` := (x,y) -> evalb(simplify(y-x) = 0):

`is_leq/CC` := NULL;

`is_leq_lex/CC` := proc(x,y)
 local z;
 z := simplify(y - x);
 if is(Re(z) > 0) then
  return true;
 elif is(Re(z) < 0) then
  return false;
 elif is(Im(z) > 0) then
  return true;
 elif is(Im(z) < 0) then
  return false;
 fi;
 return true;
end:

`random_element/CC` := proc()
 rand(-720..720)()/(360) + rand(-720..720)()/(360) * I;
end:

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

######################################################################
# C(N) is the vector space CC^N

`is_element/C` := (N::posint) -> (x) -> type(x,[constant$N]);

`is_equal/C` := (N::posint) -> (x,y) -> evalb(simplify(x -~ y) = [0$N]);

`is_leq/C` := NULL;

`is_leq_lex/C` := (N::posint) -> proc(x,y)
 local i,z;
 for i from 1 to n do
  z := simplify(y[i] - x[i]);
  if is(Re(z) > 0) then
   return true;
  elif is(Re(z) < 0) then
   return false;
  elif is(Im(z) > 0) then
   return true;
  elif is(Im(z) < 0) then
   return false;
  fi;
 od;
 return true;
end:

`is_zero/C` := (N::posint) -> (x) -> evalb(simplify(x) = [0$N]);

`norm_2/C` := (N::posint) -> proc(x) local i; sqrt(add(abs(x[i])^2,i=1..N)); end:

`dot/C` := (N::posint) -> proc(x,y) local i; add(x[i]*conjugate(y[i]),i=1..N); end:

`d_2/C` := (N::posint) -> (x,y) -> `norm_2/C`(N)(x -~ y);

`random_element/C` := (N::posint) -> proc() local i; [seq(`random_element/CC`(),i=1..N)] end;

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


#@ Not autoload

# This gives a two-parameter family of embeddings of the trefoil in R^3

trefoil0 := proc(t,a,b)
 [(1 + a * cos(3 * t)) * cos(2 * t),
  (1 + a * cos(3 * t)) * sin(2 * t),
  b * sin(3 * t)]
end:

# This is a particular embedding from the above family for which the
# speed is just sqrt(8)*(1 + 2/3 * cos(3*t)).  For a typical element
# of the above family, the speed is a much more complicated function.

trefoil := (t) -> trefoil0(t,2/3,2/9*sqrt(7));

Trefoil := table():

Trefoil["x"] := trefoil(t,2/3,2*sqrt(7)/9);
Trefoil["t"] := t;
Trefoil["v"] := combine(simplify(expand(map(diff,Trefoil["x"],t)))) assuming t > 0;
Trefoil["speed"] := combine(simplify(factor(expand(`norm_2/R`(3)(Trefoil["v"]))))) assuming t > 0;
Trefoil["s"] := int(Trefoil["speed"],t);
Trefoil["v_hat"] := combine(factor(expand(Trefoil["v"] /~ Trefoil["speed"]))) assuming t > 0;
Trefoil["T"] := Trefoil["v_hat"];
Trefoil["a"] := map(diff,Trefoil["v"],t);
Trefoil["v_hat_dot"] := combine(factor(expand(map(diff,Trefoil["v_hat"],t)))) assuming t > 0;
Trefoil["curvature"] := combine(simplify(factor(expand(`norm_2/R`(3)(Trefoil["v_hat_dot"]))))) assuming t > 0;
Trefoil["radius_of_curvature"] := simplify(1/Trefoil["curvature"]);
Trefoil["N"] := factor(combine(factor(expand(rationalize(Trefoil["v_hat_dot"] /~ Trefoil["curvature"]))))) assuming t > 0;
Trefoil["B"] := factor(combine(factor(expand(`cross_product`(Trefoil["T"],Trefoil["N"]))))) assuming t > 0;


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:


######################################################################
# 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):


(* 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)):