######################################################################
# pair_subsets(A) is the set of all subsets B of A with |B| = 2

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

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

`is_leq/pair_subsets` := NULL;

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

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

 r := rand(1..nops(A));
 B := {};

 while nops(B) < 2 do
  B := [A[r()],A[r()]];
  B := {op(B)};
 od;

 return B;
end;

`list_elements/pair_subsets` := proc(A::set)
 local i,j;
 return [seq(seq({A[i],A[j]},j=i+1..nops(A)),i=1..nops(A)-1)];
end:

`count_elements/pair_subsets` := (A::set) -> nops(A) * (nops(A) - 1)/2;


make_boys_complex := proc()
 local T,U,F,p,f,i,L,w,n,P,vb,vn;
 global boys_complex,boys_complex_alt;

 T := table([
  "vertices" = [1,2,3,4,5,6],
  "edges"  = [[1,2],[1,3],[1,5],[1,6],[2,3],[2,4],[2,6],[3,4],[3,5],[4,5],[4,6],[5,6]],
  "faces"  = [[1,2,3],[1,2,6],[1,5,3],[1,5,6],[4,2,3],[4,2,6],[4,5,3],[4,5,6]],
  "embedding" = table(),
  "embedding_dim" = 3
 ]);

 T["max_simplices"] := T["faces"];

 for i from 1 to 6 do
  T["embedding"][i]   :=    boys_corners[i];
 od:

 T := eval(`triangular_subdivision/simplicial_complex`(T)):
 T := eval(`condense/simplicial_complex`(T)):
 `normalise_embedding/simplicial_complex`(T):
 `star_subdivide/simplicial_complex`(T,{7,8,11}):
 `star_subdivide/simplicial_complex`(T,{16,17,18}):
 `normalise_embedding/simplicial_complex`(T):
 for p from 1 to 4 do
  T := eval(`triangular_subdivision/simplicial_complex`(T)):
  T := eval(`condense/simplicial_complex`(T)):
  `normalise_embedding/simplicial_complex`(T):
 od:
 F := select(f -> min(op(f)) <= 6,T["max_simplices"]):
 for f in F do
  `star_subdivide/simplicial_complex`(T,{op(f)} minus {min(op(f))});
 od:
 `normalise_embedding/simplicial_complex`(T):
 for p from 1 to 3 do
  for i from 1 to 6 do
   L := `link/simplicial_complex`(T,i);
   w := max(op(L["vertices"]));
   w := `square_refine/simplicial_complex`(T,i,w);
  od:
  `normalise_embedding/simplicial_complex`(T):
 od:

 n := nops(T["vertices"]);
 P := eval(T["embedding"]):
 vb := table():
 vn := table():
 for i from 1 to n do
  vb[i] := evalf(boys_embedding(P[i]));
  vn[i] := evalf(boys_normal(P[i]));
 od:

 T["boys_embedding"] := eval(vb);
 T["boys_normal"] := eval(vn);

 `set_javascript/simplicial_complex`(T);

 boys_complex := eval(T):

 U := table();
 U["vertices"] := boys_complex["vertices"];
 U["embedding"] := eval(boys_complex["boys_embedding"]);
 U["normal"]    := eval(boys_complex["boys_normal"]);
 U["max_simplices"] := boys_complex["max_simplices"];
 `set_javascript/simplicial_complex`(U);

 boys_complex_alt := eval(U);

 return eval(T);
end:

save_boys_complex := proc()
 local js_file,T;
 global boys_complex;

 if not(type(boys_complex,table)) then
  make_boys_complex();
 fi;

 save(boys_complex,boys_complex_alt,cat(data_dir,"/boys_complex.m"));

 js_file := cat(data_dir,"/boys_cover_complex.js");
 fprintf(js_file,"%s",boys_complex["javascript"]);
 fclose(js_file);

 js_file := cat(data_dir,"/boys_complex_alt.js");
 fprintf(js_file,"%s",boys_complex_alt["javascript"]);
 fclose(js_file);

end:


`basis/ass_operad` := (A::set) -> map(u -> bar(op(u)),`list_elements/ord`(A));

`vec/ass_operad` := (A::set) -> proc(u)
 local n,ub,uc,T,B,i;
 global `vec_table/ass_operad`;
 n := nops(A);
 if u = 0 then
  return [0$(n!)];
 elif type(u,`+`) then
  return map(`vec/ass_operad`(A),u);
 else
  if type(u,specfunc(bar)) then
   ub := u;
   uc := 1;
  elif type(u,`*`) then
   ub,uc := selectremove(type,u,specfunc(bar));
   ub := map(op,bar(ub));
  else
   return FAIL;
  fi;
  if not(type(`vec_table/ass_operad`[A],table)) then
   T := table():
   B := `basis/ass_operad`(A);
   for i from 1 to n! do
    T[B[i]] := [0$(i-1),1,0$(n!-i)];
   od:
   `vec_table/ass_operad`[A] := eval(T);
  fi;
  return uc *~ `vec_table/ass_operad`[A][ub];
 fi;
end:


# This file contains code related to the following situation.
# We have P0 in ICP_N(A) restricting to Q0 in ICP_N(B),
# where B = A \ {a}.  We also have Q1 in ICP_N(B) refining Q0.
# We let U denote the poset of elements M in ICP_N(A) such that
# the restriction of M to B is Q1, and M refines P0.
# The claim is that |U| is contractible.

`random_element/PQ` := (N::posint) -> (A::set,a) -> proc()
 local B,P,Q0,Q;
 B := A minus {a};
 P := `random_element/ICP`(N)(A)():
 Q0 := `res/ICP`(N)(A,B)(P):
 Q := NULL:
 while Q = NULL or not(`is_leq/ICP`(N)(B)(Q0,Q)) do
  Q := `random_element/ICP`(N)(B)():
 od:
 return [P,Q];
end:

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

`analyse/PQ` := (N::posint) -> (A::set,a) -> proc(PQ)
 local B,P,Q,T,Pt,Qt,Pr,Qr,Ps,Qs,F,U,m,sigma,Y,Z,zeta,B0,F0,FR0,U0,UR0,
  i,j,k,n,b,e;
 B := A minus {a};
 P,Q := op(PQ);
 T := table():
 T["N"] := N;
 T["A"] := A;
 T["B"] := B;
 T["a"] := a;
 T["P"] := P;
 T["Q"] := Q;
 Pt := `totalise/ICP/ord`(N)(A)(P);
 Qt := `totalise/ICP/ord`(N)(B)(Q);
 T["P_tot"] := Pt;
 T["Q_tot"] := Qt;
 Pr := table():
 Qr := table():
 Ps := table():
 Qs := table():
 for i from 1 to N do
  Pr[i]  := `rank_table/preord`(A)(P[i]);
  Qr[i]  := `rank_table/preord`(B)(Q[i]);
  Ps[i] := `strictify/preord`(A)(P[i]);
  Qs[i] := `strictify/preord`(B)(Q[i]);
 od:
 T["P_rank_table"] := eval(Pr);
 T["Q_rank_table"] := eval(Qr);
 T["P_strict"] := Ps;
 T["Q_strict"] := Qs;
 F := table():
 U := table():
 m := table():
 sigma := table():
 Y := table():
 Z := table():
 zeta := table():
 for b in B do
  F[b] :=
   {seq(seq(`f_alt/fibre_sphere/ICP`(N)(A)(a,b,Q)([i,e]),e in {-1,1}),i=1..N)};
  U[b] := select(M -> `is_leq/ICP`(N)(A)(P,M),F[b]):
  k := 1;
  while member([a,b],P[k]) and member([b,a],P[k]) do
   k := k+1;
  od:
  m[b] := k;
  if member([a,b],P[k]) then
   sigma[b] := -1;
   Y[b] := select(z -> member([a,z],Ps[k]) and member([z,b],Qs[k]),B);
   Z[b] := {seq(op(select(z -> member([a,z],Ps[k]) and
                               member([z,b],Qs[n]),B)),n = k .. N)};
   if Z[b] = {} then
    zeta[b] := b;
   else
    i := 1;
    while i < nops(Qt) and not(member(Qt[i],Z[b])) do i := i+1; od;
    zeta[b] := Qt[i];
   fi;
  else
   sigma[b] := +1;
   Y[b] := select(z -> member([z,a],Ps[k]) and member([b,z],Qs[k]),B);
   Z[b] := {seq(op(select(z -> member([z,a],Ps[k]) and
                               member([b,z],Qs[n]),B)),n = k .. N)};
   if Z[b] = {} then
    zeta[b] := b;
   else
    i := nops(Qt);
    while i > 1 and not(member(Qt[i],Z[b])) do i := i-1; od;
    zeta[b] := Qt[i];
   fi;
  fi;
 od:
 B0 := select(b -> Z[b] = {},B);
 T["B0"] := B0;
 T["F"] := eval(F);
 T["U"] := eval(U);
 T["m"] := eval(m);
 T["sigma"] := eval(sigma);
 T["Y"] := eval(Y);
 T["Z"] := eval(Z);
 T["zeta"] := eval(zeta);
 T["FF"] := {seq(op(F[b]),b in B)};
 T["UU"] := select(M -> `is_leq/ICP`(N)(A)(P,M),T["FF"]);
 T["nF"] := nops(T["FF"]);
 T["nU"] := nops(T["FF"]);
 F0,FR0 := op(`skeleton/partord/from_comparator`(T["FF"])(`is_leq/ICP`(N)(A)));
 U0,UR0 := op(`skeleton/partord/from_comparator`(T["UU"])(`is_leq/ICP`(N)(A)));
 T["FF_skel"] := [F0,FR0];
 T["UU_skel"] := [U0,UR0];
 T["FF_hasse"] := `hasse_diagram/partord`(F0)(FR0);
 T["UU_hasse"] := `hasse_diagram/partord`(U0)(UR0);

 return eval(T):
end:

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

`describe/PQ` := proc(T)
 cat(`describe/ICP`(T["N"])(T["A"])(T["P"]),"\n",
     `describe/ICP`(T["N"])(T["B"])(T["Q"]));
end:

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

`check/prop_part_is_sphere/PQ` := proc(T)
 global reason;
 local N,A,B,B0,P,Q,U,m,Y,Z,zeta,sigma,b,c,V,i,e;

 N := T["N"];
 A := T["A"];
 B := T["B"];
 B0 := T["B0"];
 P := T["P"];
 Q := T["Q"];
 U := T["U"];
 m := T["m"];
 Y := T["Y"];
 Z := T["Z"];
 zeta  := T["zeta"];
 sigma := T["sigma"];

 for b in B do
  V :=
   {seq(seq(`f_alt/fibre_sphere/ICP`(N)(A)(a,b,Q)([i,e]),e in {-1,1}),i=1..m[b]-1)};
  if Y[b] = {} then
   V := {op(V),`f_alt/fibre_sphere/ICP`(N)(A)(a,b,Q)([m[b],sigma[b]])};
  fi;
  if U[b] <> V then
   reason := ["UV",b,U[b],V];
   return false;
  fi;
  if Z[b] <> {} then
   c := zeta[b];
   if Z[b] intersect B0 <> {c} then
    reason := ["ZB",b,c,Z[b],B0];
    return false;
   fi;
   if not(m[c] = m[b] and sigma[c] = sigma[b]) then
    reason := ["m",b,c,m[b],m[c],sigma[b],sigma[c]];
    return false;
   fi;
   if U[b] minus U[c] <> {} then
    reason := ["UU",b,c,U[b],U[c]];
    return false;
   fi;
  fi;
 od;
 return true;
end:

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

`check/cor_Ub_union/PQ` := proc(T)
 global reason;
 local N,A,B,B0,P,Q,U,UU0,UU1,b;

 N := T["N"];
 A := T["A"];
 B := T["B"];
 B0 := T["B0"];
 P := T["P"];
 Q := T["Q"];
 U := T["U"];

 UU0 := {seq(op(U[b]),b in B0)};
 UU1 := {seq(op(U[b]),b in B)};

 if not(T["UU"] = UU0 and UU0 = UU1) then
  reason := [T["UU"],UU0,UU1];
  return false;
 fi;

 return true;
end:

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

`check/lem_mk/PQ` := proc(T)
 global reason;
 local N,A,B,B0,P,Qs,m,sigma,k,bc,b,c;

 N := T["N"];
 A := T["A"];
 B := T["B"];
 B0 := T["B0"];
 P := T["P"];
 Qs := T["Q_strict"];
 m := T["m"];
 sigma := T["sigma"];

 for k from 1 to N do
  for bc in Qs[k] do
   b,c := op(bc);
   if member(b,B0) and member(c,B0) then
    if m[b] < k or m[c] < k then return false; fi;
    if m[b] = k and sigma[b] <>  1 then return false; fi;
    if m[c] = k and sigma[c] <> -1 then return false; fi;
   fi;
  od;
 od;

 return true;
end:

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

`check/lem_buc/PQ` := proc(T)
 global reason;
 local N,A,B,B0,Qs,Qt,m,sigma,zeta,
  n,n0,I0,ib,ic,b,c,k,ju,u,i;

 N := T["N"];
 A := T["A"];
 B := T["B"];
 B0 := T["B0"];
 Qs := T["Q_strict"];
 Qt := T["Q_tot"];
 m := T["m"];
 sigma := T["sigma"];
 zeta  := T["zeta"];

 n := nops(B);
 I0 := select(i -> member(Qt[i],B0),[seq(i,i=1..n)]);
 n0 := nops(I0);

 for ib from 1 to n0-1 do
  ic := ib+1;
  b := Qt[I0[ib]];
  c := Qt[I0[ic]];
  k := 1;
  while k < N and not(member([b,c],Qs[k])) do k := k+1; od;

  for ju from I0[ib]+1 to I0[ic]-1 do
   u := Qt[ju];
   if sigma[u] = -1 then
    if zeta[u] <> b then
     return false;
    fi;
    if not member([u,c],Qs[k]) then
     return false;
    fi;
    if not (m[b] > k) then
     return false;
    fi;
   else
    if zeta[u] <> c then
     return false;
    fi;
    if not member([b,u],Qs[k]) then
     return false;
    fi;
    if not (m[c] > k) then
     return false;
    fi;
   fi;
  od;
 od;
 return true;
end:

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

`check/lem_buvc/PQ` := proc(T)
 global reason;
 local N,A,B,B0,Qs,Qt,m,sigma,zeta,
  n,n0,I0,ib,ic,b,c,k,ju,u,jv,v,i;

 N := T["N"];
 A := T["A"];
 B := T["B"];
 B0 := T["B0"];
 Qs := T["Q_strict"];
 Qt := T["Q_tot"];
 m := T["m"];
 sigma := T["sigma"];
 zeta  := T["zeta"];

 n := nops(B);
 I0 := select(i -> member(Qt[i],B0),[seq(i,i=1..n)]);
 n0 := nops(I0);

 for ib from 1 to n0-1 do
  ic := ib+1;
  b := Qt[I0[ib]];
  c := Qt[I0[ic]];
  k := 1;
  while k < N and not(member([b,c],Qs[k])) do k := k+1; od;

  for ju from I0[ib] to I0[ic]-1 do
   for jv from ju+1 to I0[ic] do
    u := Qt[ju];
    v := Qt[jv];
    if sigma[u] = b and sigma[v] = c then
     if not(member([u,v],Qs[k])) then
      return false;
     fi;
     if not(k <= m[b] and k <= m[c]) then
      return false;
     fi;
     if m[b] = k and u <> b then
      return false;
     fi;
     if m[c] = k and v <> c then
      return false;
     fi;
    fi;
   od;
  od;
 od;
 return true;
end:

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

`check/prop_U_step/PQ` := proc(T)
 global reason;
 local N,A,B,B0,Qs,Qt,U,
  n,n0,I0,ib,ic,b,c,r,V,V0,V1,M0,i;

 N := T["N"];
 A := T["A"];
 B := T["B"];
 B0 := T["B0"];
 Qs := T["Q_strict"];
 Qt := T["Q_tot"];
 U := T["U"];

 n := nops(B);
 I0 := select(i -> member(Qt[i],B0),[seq(i,i=1..n)]);
 n0 := nops(I0);

 for ib from 1 to n0-1 do
  ic := ib+1;
  b := Qt[I0[ib]];
  c := Qt[I0[ic]];
  V := U[b] intersect U[c];
  r := min(op(map(`rank/ICP`(N)(A),V)));
  V0 := select(M -> `rank/ICP`(N)(A)(M) = r,V);
  if nops(V0) <> 1 then return false; fi;
  M0 := V0[1];
  V1 := remove(M -> `is_leq/ICP`(N)(A)(M0,M),V);
  if V1 <> {} then return false; fi;
 od;
 return true;
end:


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

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

(* type: gga_exc *)

$include "scaling.mpl"

(* parameters *)
wpbeh_A :=  1.0161144:
wpbeh_B := -0.37170836:
wpbeh_C := -0.077215461:
wpbeh_D :=  0.57786348:
wpbeh_E := -0.051955731:

(*
 Note that kF has a 6 and not a 3 as it should in principle
 be. This is because the HSE formula, if one would take the papers
 seriously, does not fulfill the spin sum-rule. This is probably
 an oversight from them. So, we have to choose, either a 6 or a 3.

 Nwchem seems to have the factor of 6, but VASP and espresso have
 a 3. This would amount to rescaling omega by a factor of
 cbrt(2). We follow the quantum chemistry community and put the 6.
*)

(* Cutoff criterion below which to use polynomial expansion *)
EGscut     := 0.08:
wcutoff    := 14:
expfcutoff := 700:

(* first let us calculate H(s) *)
wpbeh_Ha1 := 0.00979681:
wpbeh_Ha2 := 0.0410834:
wpbeh_Ha3 := 0.187440:
wpbeh_Ha4 := 0.00120824:
wpbeh_Ha5 := 0.0347188:
wpbeh_H := s ->
  + (wpbeh_Ha1*s^2 + wpbeh_Ha2*s^4)
  / (1 + wpbeh_Ha3*s^4 + wpbeh_Ha4*s^5 + wpbeh_Ha5*s^6):

(*
  Now we calculate F(s). We use the parameters that were in the original code,
  but these constants are:

  wpbeh_Fc1 := 4*wpbeh_A^2/(9*wpbeh_C) + (wpbeh_B - wpbeh_A*wpbeh_D)/wpbeh_C:
  wpbeh_Fc2 := -4/(3*36*wpbeh_C):
*)
wpbeh_Fc1 := 6.4753871:
wpbeh_Fc2 := 0.47965830:
wpbeh_F := s ->
  wpbeh_Fc1*wpbeh_H(s) + wpbeh_Fc2:

(* several auxiliary variables *)
eb1  := w -> my_piecewise3(w < wcutoff, 1.455915450052607, 2):
aux1 := s -> wpbeh_D + s^2*wpbeh_H(s):
aux2 := s -> 9*wpbeh_H(s)*s^2/(4*wpbeh_A):
aux3 := (w, s) -> aux1(s) + w^2:
aux4 := (w, s) -> s^2*wpbeh_H(s) + eb1(w)*w^2:
aux5 := (w, s) -> 9*aux4(w, s)/(4*wpbeh_A):
aux6 := (w, s) -> wpbeh_D + aux4(w, s):

(* and now G(s) *)
Ga := s ->
  + sqrt(Pi)*(
    + 15*wpbeh_E
    + 6*wpbeh_C*(1 + wpbeh_F(s)*s^2)*aux1(s)
    + 4*wpbeh_B*aux1(s)^2
    + 8*wpbeh_A*aux1(s)^3)
  / (16*aux1(s)^(7/2))
  - (3*Pi/4)*sqrt(wpbeh_A)*exp(aux2(s))*(1 - erf(sqrt(aux2(s)))):
Gb := s ->
  15*sqrt(Pi)*s^2/(16*aux1(s)^(7/2)):

wpbeh_EGa1 := -0.02628417880:
wpbeh_EGa2 := -0.07117647788:
wpbeh_EGa3 :=  0.08534541323:
wpbeh_EG := s -> my_piecewise3(s > EGscut,
  -(3*Pi/4 + Ga(s))/Gb(s),
  wpbeh_EGa1 + wpbeh_EGa2*s^2 + wpbeh_EGa3*s^4
):

term2 := s-> (
  + aux1(s)^2*wpbeh_B
  + aux1(s)*wpbeh_C
  + 2*wpbeh_E
  + aux1(s)*s^2*wpbeh_C*wpbeh_F(s)
  + 2*s^2*wpbeh_EG(s)
)/(2*aux1(s)^3):

term3 := (w, s) -> -w*(
  + 4*aux3(w, s)^2*wpbeh_B
  + 6*aux3(w, s)*wpbeh_C
  + 15*wpbeh_E
  + 6*aux3(w, s)*s^2*wpbeh_C*wpbeh_F(s)
  + 15*s^2*wpbeh_EG(s)
)/(8*aux1(s)*aux3(w, s)^(5/2)):

term4 := (w, s) -> -w^3*(
  + aux3(w, s)*wpbeh_C
  + 5*wpbeh_E
  + aux3(w, s)*s^2*wpbeh_C*wpbeh_F(s)
  + 5*s^2*wpbeh_EG(s)
)/(2*aux1(s)^2*aux3(w, s)^(5/2)):

term5 := (w, s) -> -w^5*(
  + wpbeh_E
  + s^2*wpbeh_EG(s)
)/(aux1(s)^3*aux3(w, s)^(5/2)):

t10 := (w, s) ->
  1/2*wpbeh_A*log(aux4(w, s)/aux6(w, s)):

(* Use simple gaussian approximation for large w *)
term1_largew := (w, s) ->
  -1/2*wpbeh_A*(-xc_E1_scaled(aux5(w, s)) + log(aux6(w, s)) - log(aux4(w, s))):

(* For everything else use the full blown expression *)
ea1 := -1.128223946706117:
ea2 :=  1.452736265762971:
ea3 := -1.243162299390327:
ea4 :=  0.971824836115601:
ea5 := -0.568861079687373:
ea6 :=  0.246880514820192:
ea7 := -0.065032363850763:
ea8 :=  0.008401793031216:

np1 := w ->
  - 1.5*ea1*sqrt(wpbeh_A)*w
  + 27*ea3*w^3/(8*sqrt(wpbeh_A))
  - 243*ea5*w^5/(32*(wpbeh_A)^(3/2))
  + 2187*ea7*w^7/(128*(wpbeh_A)^(5/2)):

np2 := w ->
  - wpbeh_A
  + 9*ea2*w^2/4.0
  - 81*ea4*w^4/(16*wpbeh_A)
  + 729*ea6*w^6/(64*wpbeh_A^2)
  - 6561*ea8*w^8/(256*wpbeh_A^3):

t1 := (w, s) ->
  1/2*(np1(w)*Pi*xc_erfcx(sqrt(aux5(w, s))) - np2(w)*xc_E1_scaled(aux5(w, s))):

f2 := (w, s) ->
  1/2*ea1*sqrt(Pi)*wpbeh_A/sqrt(aux6(w, s)):
f3 := (w, s) ->
  1/2*ea2*wpbeh_A/aux6(w, s):
f4 := (w, s) ->
  ea3*sqrt(Pi)*(-9/(8*sqrt(aux4(w, s))) + 0.25*wpbeh_A/aux6(w, s)^(3/2)):
f5 := (w, s) ->
  (ea4/128)*(-144/aux4(w, s) + 64*wpbeh_A/aux6(w, s)^2):
f6 := (w, s) ->
  ea5*(3*sqrt(Pi)*(3*aux6(w, s)^(5/2)*(9*aux4(w, s) - 2*wpbeh_A)
    + 4*aux4(w, s)^(3/2)*wpbeh_A^2))/(32*aux6(w, s)^(5/2)*aux4(w, s)^(3/2)*wpbeh_A):
f7 := (w, s) ->
  ea6*((32*wpbeh_A/aux6(w, s)^3 + (-36 + 81*s^2*wpbeh_H(s)/wpbeh_A)/aux4(w, s)^2))/32:
f8 := (w, s) ->
  ea7*(-3*sqrt(Pi)*(-40*aux4(w, s)^(5/2)*wpbeh_A^3
    + 9*aux6(w, s)^(7/2)*(27*aux4(w, s)^2 - 6*aux4(w, s)*wpbeh_A + 4*wpbeh_A^2)))
  /(128*aux6(w, s)^(7/2)*aux4(w, s)^(5/2)*wpbeh_A^2):
f9 := (w, s) -> (
  + 324*ea6*eb1(w)*aux6(w, s)^4*aux4(w, s)*wpbeh_A
  + ea8*(384*aux4(w, s)^3*wpbeh_A^3
    + aux6(w, s)^4*(-729*aux4(w, s)^2 + 324*aux4(w, s)*wpbeh_A - 288*wpbeh_A^2))
  )/(128*aux6(w, s)^4*aux4(w, s)^3*wpbeh_A^2):

t2t9 := (w, s) ->
  + f2(w, s)*w + f3(w, s)*w^2 + f4(w, s)*w^3 + f5(w, s)*w^4
  + f6(w, s)*w^5 + f7(w, s)*w^6 + f8(w, s)*w^7 + f9(w, s)*w^8:

term1 := (w, s) -> my_piecewise3(
  w > wcutoff, term1_largew(w, s),
  t1(m_min(w, wcutoff), s) + t2t9(m_min(w, wcutoff), s) + t10(m_min(w, wcutoff), s)
):

f_wpbeh0 := (w, s) -> - 8/9 *(
  term1(w, s) + term2(s) + term3(w, s) + term4(w, s) + term5(w, s)
):

f_wpbeh := (rs, z, x) ->
  f_wpbeh0(nu(rs, z), m_max(1e-15, s_scaling_2(X2S*x))):

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


kernelopts(printbytes=false);
with(RigidMotionsParameterSpaceDecompostion);
LaunchComputeSamplePoints([a,b,c], "__REPLACE__", "N2");
done


# This file is about Singer systems of endomorphisms of the additive formal
# group.  Such a system has groups G(i,j) (for 0 <= i <= j <= n say),
# all of which are equal to the standard additive formal group.  There
# are morphisms G(j,k) -> G(i,l) whenever i <= j <= k <= l, with the
# evident functoriality condition.  The horizontal maps are linear
# and the vertical maps are short isogenies.  Every equal-length
# L-shaped subdiagram is like G -> G/a <- G//a for some a.

aa := proc(i::nonnegint,k::nonnegint)
 if i > k then return FAIL; fi;
 return v[k] * mul(v[t]^(2^(k-t-1)),t=i..k-1);
end:

bb := proc(i::nonnegint,k::nonnegint)
 if i > k then return FAIL; fi;
 return v[i-1]^(2^(k-i));
end:

# G(i,k) to G(i-1,k)
pp := (i,k) -> (x) -> bb(i,k) * x:

# G(i,k) to G(i,k+1)
qq := (i,k) -> (x) -> aa(i,k) * x + x^2:

# G(j,k) to G(i,k)
ppp := proc(i,j,k)
 local x,y,z;

 if i > j then
  return FAIL;
 elif i = j then
  return (x -> x);
 else
  y := ppp(i+1,j,k)(x);
  z := collect(modp(expand(pp(i+1,k)(y)),2),x);
  return unapply(z,x);
 fi;
end:

# G(j,k) to G(i,k)
ppp1 := proc(i,j,k) local x; unapply(mul(v[m]^(2^(k-m-1)),m=i..j-1) * x,x); end:

# G(i,k) to G(i,l)
qqq := proc(i,k,l)
 local x,y,z;

 if k > l then
  return FAIL;
 elif l = k then
  return (x -> x);
 else
  y := qqq(i,k,l-1)(x);
  z := collect(modp(expand(qq(i,l-1)(y)),2),x);
  return unapply(z,x);
 fi;
end:

W0V := (k) -> mul(V[i],i=0..k-1):

WW := proc(k,l,m)
  local J,P;
  J := [seq(j,j=k..l-1)];
  P := combinat[choose](J,l-k-m);
  return add(mul(V[u[t]]^(2^(k+m+t-1-u[t])),t=1..l-k-m),u in P);
end:

WWW := (j,k,l,m) -> WW(k,l,m) * W0V(j)^(2^(k+m-j) - 2^(l-j)):

WWWW := (i,j,k,l,m) -> WW(k,l,m) * W0V(j)^(2^(k+m-j)) / W0V(i)^(2^(l-i)):

# G(i,k) to G(i,l)
qqq1 := proc(j,k,l)
 local x;
 return unapply(sort(collect(expand(add(WWW(j,k,l,i) * x^(2^i),i=0..l-k)),x)),x):
end:

# G(j,k) to G(i,l)
ff := proc(i,j,k,l)
 local x;
 return unapply(sort(collect(expand(add(WWWW(i,j,k,l,m) * x^(2^m),m=0..l-k)),x)),x):
end:

vV_rule := {seq(v[i]=V[i]/W0V(i),i=0..100)}:


# 以代表元为核心，进行合并、化简以及补全的工作

$ifndef _COMBINE_
$define _COMBINE_

$include "RepSol.mpl"
$include "Utils.mpl"

RepsHolder:=module()
    option object;
    export reps;
end module:

# 重新建立代表元
buildReps:=proc(_sols)
    RepsHolder:-reps:=table();
    addReps(_sols);
    # 按照不变量方程进行排序输出
    return getReps();
end proc:

# 获取排序后的reps
getReps:=proc()
    return sort([entries(eval(RepsHolder:-reps),nolist)],
            key=(x->[x:-osol[1]:-ieqCode,getRep(x:-osol[1])]));
end proc:

# 增加代表元
addReps:=proc(_sols)
    local inds;
    inds:=formReps(_sols);
    return map(x->RepsHolder:-reps[x],inds);
end proc:

# 建立代表元变量
# 同时将条件按复杂度排序
# 现在是按照方程个数排序的
formReps:=proc(_sols)
    local sols,r,ss,rep,inds;
    sols:=select(x->(x:-stateCode=5),_sols);# 只取求解成功的
    inds,sols:=collectObj(sols,x->getRep(x),output=[ind,val]);# 按代表元分类
    for ss in sols do
        rep:=getRep(ss[1]);
        if assigned(RepsHolder:-reps[rep]) then
            r:=RepsHolder:-reps[rep];
        else
            r:=Object(RepSol);
            RepsHolder:-reps[rep]:=r;
        end if ;
        map[2](RepSol:-appendSol,r,ss);
        uniqueAndSort(r);
        # conRefine(r);
    end do;
    return inds;
end proc:

# 删除某个rep
rmRep:=proc(r::RepSol)
    local rep;
    rep:=getRep(r:-osol[1]);
    if assigned(RepsHolder:-reps[rep]) then
        RepsHolder:-reps[rep]:=evaln(RepsHolder:-reps[rep]);
    end if;
    return NULL;
end proc:

# 修改rep
updateRep:=proc(r::RepSol)
    RepsHolder:-reps[getRep(r:-osol[1])]:=r;
end proc:

$endif


input := FileTools:-Text:-ReadFile("AoC-2021-18-input.txt" ):

find5nested := proc(input::string,$)
local c, i, count;
    count := 0;
    for i from 1 to length(input) do
        if input[i] = "[" then count += 1; if count=5 then return i; end if;
        elif input[i] = "]" then count -= 1;
        end if;
    end do;
    return 0;
end proc:

PRINT := s->printf(cat(s,"\n"),_rest):

sfreduce := proc(inp::string,$)
local n, pin, regnums, input:=inp, oldinput;

    while oldinput <> input do
        oldinput := input;
    #check
        pin := parse(input);
        if not nops(pin) = 2 then
        error "bad input", input;
        end if;

        PRINT("reducing %s", input);

        n := find5nested(input);
        if n > 0 then
            input := ( sfexplode(input, n) );
            next;
        end if;

        regnums := indets(pin, integer);
        if max(regnums) >= 10 then
            input := ( sfsplit(input) );
            next;
        end if;
    end do;

    return input;

end proc:

sfexplode := proc(input::string, pos::posint:=find5nested(input), $)
local mid, toreplace, toreplacestr;
local lh := input[1..pos-1];
local rh := input[pos..-1]; # starting at the fifth [
local m,n := StringTools:-FirstFromLeft("]", rh);
local toexplode := rh[1..n];
    rh := rh[n+1..-1];
    toexplode := parse(toexplode); # get a list with ints
# righthand element
    n := StringTools:-FirstFromRight(",", lh); # any number will be followed by a ,

    PRINT("exploding %a at position %d", toexplode, pos);

    if n <> 0 then
        if lh[n-1] = "]" then
            while lh[n-1] = "]" do n -= 1 end do;
            mid := lh[n..-1];
            lh := lh[1..n-1]; # number still in lh
            n := max(StringTools:-FirstFromRight(",", lh),StringTools:-FirstFromRight("[", lh));
        else
            mid := lh[n..-1]; # number still in lh
            lh := lh[1..n-1];
            n := StringTools:-FirstFromRight("[", lh);
        end if;
        toreplace := lh[n+1..-1];
        lh := lh[1..n];
        toreplacestr := parse(toreplace) + toexplode[1];
        lh := cat(lh, toreplacestr, mid);
        end if;

    if toreplace = "" then
      error "bug"
    end if;

# lefthand element
    n := StringTools:-FirstFromLeft(",", rh); # any number will be proceded by a ,
    if n <> 0 then
        if rh[n+1] = "[" then
            while rh[n+1] = "[" do n += 1 end do;
            mid := rh[1..n];
            rh := rh[n+1..-1]; # number still in rh
            n := min(subs(0=NULL,[StringTools:-FirstFromLeft(",", rh), StringTools:-FirstFromLeft("]", rh)]));
        else
        mid := rh[1..n];
        rh := rh[n+1..-1]; # number still in rh
        n := StringTools:-FirstFromLeft("]", rh);
    end if;
        toreplace := rh[1..n-1];
        rh := rh[n..-1];
        toreplacestr := parse(toreplace) + toexplode[2];
        rh := cat(mid, toreplacestr, rh);
    end if;

    if toreplace = "" then
      error "bug"
    end if;

    return cat(lh,0,rh);

end proc:

sfsplit := proc(input::string, $)
local i,n,regnum,dig,diglocs;
    # find leftmost - this is slow
    # a better would be to just sweep to find a two digit number
    dig := map(d->cat("",d), [select(d->d>9,indets(parse(input), 'posint'))[]]);
    diglocs := map(d->StringTools:-Search(d, input), dig);
    i := min[index](diglocs);
    regnum := parse(dig[i]);
    n := diglocs[i];

    PRINT("splitting %d at position %d", regnum, n);
    if n > 0 then
        return cat(input[1..n-1], "[", floor(regnum/2), ",",
                   ceil(regnum/2) ,"]", input[n+length(rs)..-1]);
    else
        error "%1 is not in %2", regnum, input;
    end if;
end proc:

sfnorm := proc(input::{list,integer,string},$)
    if type(input, string) then return thisproc(parse(input)); end if;
    if type(input, integer) then return input; end if;
    if nops(input) <> 2 then error "bad sf number", input; end if;
    return thisproc(input[1])*3 + thisproc(input[2])*2;
end proc:

sfadd := proc(s1, s2)
   return cat("[",s1,",",s2,"]");
end proc:

# unit tests
sfexplode( "[[[[[9,8],1],2],3],4]")="[[[[0,9],2],3],4]";
sfexplode( "[7,[6,[5,[4,[3,2]]]]]") = "[7,[6,[5,[7,0]]]]";
sfexplode("[[6,[5,[4,[3,2]]]],1]") = "[[6,[5,[7,0]]],3]";
sfexplode("[[3,[2,[1,[7,3]]]],[6,[5,[4,[3,2]]]]]") = "[[3,[2,[8,0]]],[9,[5,[4,[3,2]]]]]";
sfexplode("[[3,[2,[8,0]]],[9,[5,[4,[3,2]]]]]")="[[3,[2,[8,0]]],[9,[5,[7,0]]]]";
sfadd("[[[[4,3],4],4],[7,[[8,4],9]]]", "[1,1]");
sfexplode(%);
sfexplode(%);
sfsplit(%);
sfsplit(%);
sfexplode(%)= "[[[[0,7],4],[[7,8],[6,0]]],[8,1]]";
sfreduce("[[[[[4,3],4],4],[7,[[8,4],9]]],[1,1]]") = "[[[[0,7],4],[[7,8],[6,0]]],[8,1]]";
sfsplit( "[[[[5,11],[13,0]],[[15,14],[14,0]]],[[2,[11,10]],[[0,8],[8,0]]]]") = "[[[[5,[5,6]],[13,0]],[[15,14],[14,0]]],[[2,[11,10]],[[0,8],[8,0]]]]";

PRINT := 'PRINT':
homework := StringTools:-Split(input,"\n"): nops(homework);

sofar := homework[1];
for i from 2 to nops(homework) do
    sofar := sfreduce(sfadd(sofar, homework[i]));
end do:
answer1 := sfnorm(sofar);
answer2 := max([seq(seq(ifelse(i<>j,sfnorm( sfreduce(sfadd(homework[i],homework[j])) ),NULL), j=1..nops(homework)),i=1..nops(homework))]);


 flavor 1
 func &ciori32 (
  var %i i32, var %j i32, var %k i32
  ) i32 {
   if (cior i32 ( cior i32(dread i32 %i, dread i32 %j), dread i32 %k)) {
     return (constval i32 1)
   }
   return (
     cior i32(dread i32 %i, dread i32 %j))}

 func &candi64 (
  var %i i64, var %j i64, var %k i64
  ) i32 {
   if (cand i32 (cand i32(dread i32 %i, dread i32 %j), dread i32 %k)) {
     return (constval i32 1)
   }
   return (
     cand i64(dread i64 %i, dread i64 %j))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


local Simplify_DConstrain := (can_simp, do_simp) -> module()
    uses Domain;

    export ModuleApply := proc(vs0 :: DomBound, sh :: DomShape, $)
        local vs := vs0, ctx;
        if _Env_HakaruSolve=false then
           return sh end if;
        vs  := Domain:-Bound:-varsOf(vs,"set");
        ctx := Domain:-Bound:-toConstraints(vs0, 'bound_types');
        subsindets(sh, DomConstrain
                  ,x->do_simpl_constraints(vs0, vs, ctx, x));
    end proc;

    local do_simpl_constraints := proc(vs0, vars, ctx_vs, x, $)
        local ctx1, ctx, ss, td, rest, d, in_vs;
        ss, ctx := selectremove(q->depends(q,indets(vars,Name)), x);
        td, rest := selectremove(can_simp(vs0), ss);
        ctx1 := { op(ctx), op(ctx_vs), op(rest) };
        d := map(x->do_simp(vs0,ctx1,x), td);
        DConstrain(op(d), op(ctx), op(rest));
    end proc;
end module;

constraints_about_vars := module()
  export SimplName  := "Make constraints abouts vars";
  export SimplOrder := 6;
  export ModuleApply := Simplify_DConstrain(can_make_about, try_make_about);

  local can_make_about := proc(vs)
    local vars := Domain:-Bound:-varsOf(vs,"set");
    c -> c::relation and (not(lhs(c) in vars) and not(rhs(c) in vars) and has(c,{ln,exp}));
  end proc;
  local try_make_about := proc(dbnd, ctx1, q0, $)
      local vars_q, vars, q_s, q_r, q := q0;
      vars := Domain:-Bound:-varsOf(dbnd,"set");
      vars_q := indets(q, name) intersect vars;
      if nops(vars_q)=0 then return q end if;

      vars_q := op(1,vars_q);
      q := KB:-try_improve_exp(q, vars_q, ctx1);
      q_r := `if`(has(q,{ln,exp}),q0,q);
      q_s := 'solve({q},[op(vars_q)], 'useassumptions'=true) assuming (op(ctx1))';
      q_s := eval(q_s);
      if q_s::list then
        if nops(q_s)=0 then return q_r end if;
        q_s := map(s->remove(c->c in ctx1 or `and`(c::relation,lhs(c)::name,lhs(c)=rhs(c)), s), q_s);
        q_s := remove(x->x=[],q_s);
        if nops(q_s)=0 then return q_r end if;
        userinfo(3, 'constraints_about_vars'
                ,printf("Found a solution to %a (with solve):\n\t%a\n", q0, op(1,q_s)));
        op(op(1,q_s)); # pick the first solution arbitrarily!
      else
        q_r
      end if;
  end proc;
end module;

clamp_extraneous_constraints := module()
  export SimplName  := "clamp_extraneous_constraints";
  export SimplOrder := 6 - 1/10;
  export ModuleApply := Simplify_DConstrain(can, `try`);

  local can := proc(vs)
    local vars := Domain:-Bound:-varsOf(vs,"set");
    c-> c::relation and
        (ormap(s->s(c)::Name and not(c in vars),[lhs,rhs]) and has(c, vars));
  end proc;

  local `try` := proc(dbnd, ctx1, q0, $)
    local bnd, b_ty, b_rel, b_var, b_bnd, b_bnd_vs, vars, extremum, q := q0;
    if has(q, {ln,exp}) then
      vars := Domain:-Bound:-varsOf(dbnd, "set");
      bnd := Domain:-Improve:-classify_relation(q0, x -> type(x, Name) and not (x in vars));
      if bnd=FAIL then return q0 end if;
      b_ty, b_rel, b_var, b_bnd := op(bnd):
      b_bnd_vs := indets(b_bnd, satisfies(x -> x in vars));
      if b_bnd_vs <> {} then
        b_ty := `if`(b_ty=B_LO, 'minimize', 'maximize');
        extremum := b_ty(b_bnd, op(b_bnd_vs)) assuming(op(ctx1));
        if not (ext :: SymbolicInfinity or has(extremum, {maximize,minimize})) then
          q := q, b_rel(b_var,extremum);
        end if;
      end if;
    end if;
    q
  end proc;
end module;

# Pushes constraints down, or pulls them up, when there are such constraints.
local do_ctx_dir := dir -> proc(vs :: DomBound, sh :: DomShape, $)
    local ctx := `if`(nops(vs)=2,op(2,vs),{});
    ctx := remove(x->x::`::`,ctx);
    if ctx <> {} then
        dir(ctx)(sh);
    else
        sh;
    end if;
end proc;

push_ctx_down := module()
  uses Domain;
  export ModuleApply := do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain, x->if nops(x)<>0 then DConstrain(op(x), op(ctx)) else DConstrain() end if));
  export SimplName  := "Push context down";
  export SimplOrder := 1;
end module;

pull_ctx_out := module()
  export ModuleApply :=
    do_ctx_dir(ctx->sh->subsindets(sh, DomConstrain
              ,x->remove(c->c in ctx or (is(c) assuming op(ctx)), x)));
  export SimplName  := "Pull context out";
  export SimplOrder := 20;
end module;

# Turns constraints(relations) into bounds
classify_DConstrains := module()
  uses Domain;

  export SimplName  := "Classify constraints";
  export SimplOrder := 8;

  export ModuleApply := proc(dbnds::DomBound,dsh::DomShape,$)
    subsindets(dsh, DomConstrain, x->classify_Rels([op(x)], dbnds));
  end proc;

  # Split relations into those we can incorporate
  # into bounds and others; this process also includes
  # some intermediate computations about the new bound:
  #  [ DInto(var), orig, upd_bound, bound_kind, numVars ]
  #    var         :=   variable to be modified
  #    orig        :=   the original relation
  #    upd_bound   :=   how to modify (a function)
  #    bound_kind  :=   {LO/HI}
  #    numVars     :=   how many variables are mentioned by the bound
  local classify_Rel := proc(r0,dbnd,$)
    local ret, vars, mk_k, bnd_k, i, var_k, q, cl, lhs_r, rhs_r, r := r0;
    ret := [ DConstrain, r0 ];
    vars := Domain:-Bound:-varsOf(dbnd,"set");

    # extract a representation of the relation, and check that it is a bound
    cl := Domain:-Improve:-classify_relation(r, vars);
    if cl=FAIL or not (op(1,cl) in {B_LO,B_HI}) then return ret; end if;
    bnd_k,mk_k,lhs_r,rhs_r := op(cl);

    i := Domain:-Bound:-varIx_mb(dbnd, lhs_r);
    if i >= 0 then
      var_k := op([1,i,3], dbnd);
      q := Domain:-ExtBound[var_k]:-RecogBound(mk_k,rhs_r);
      if q <> NULL then
        ret := [ DInto(lhs_r), r0, q, bnd_k, countVs(vars minus {lhs_r},r0) ];
      end if;
    end if;
    ret;
  end proc;

  # Classifies a set of relations as potential bounds. The process
  # is as follows:
  #  - Classify each relation individually (see classify_Rel)
  #  - "Categorize" by the classification
  #  - Split relations which will be DConstrains, and those where we found
  #      more than one LO/HI bound or more than 2 bounds total.
  #  - Sort the relations which are to become bounds by the number of variables
  #      mentioned in the bound
  #  - Rebuild the continuations producing each new bound (see make_DInto)
  #  - Rebuild the leftover relations as a DConstrain.
  #  - Squash together ("foldr (.) id fs z") the continuations and leftover relations.
  local classify_Rels := proc(rs0,dbnd,$)
    local cs1, cs2, cs, rs := rs0;
    rs := map(r->classify_Rel(r,dbnd), rs);
    rs := [ListTools[Categorize]( ((a,b) -> op(1,a)=op(1,b) ), rs )];
    cs1, rs := selectremove(x->op([1,1],x)=DConstrain, rs);
    rs, cs2 := selectremove(x->nops(x)=1 or (nops(x)=2 and op([1,4],x)<>op([2,4],x)), rs);
    rs := sort(rs, key=solOrder);
    rs := map(r->make_DInto(r,dbnd),rs);
    cs := DConstrain(map(c->map(q->op(2,q),c)[], [op(cs1),op(cs2)])[]);
    foldr((f,g)->f@g,x->x,op(rs))(cs);
  end proc;

  # Rebuild a classified (by classify_Rel) relation; this
  # takes a list of such classifications, all of whose variable should
  # be identical, and for which the different bound kinds are all distinct.
  # None of this is checked!
  # (since there are 2 bound kinds, this list is at most length 2)
  local make_DInto := proc(r::list([specfunc(DInto),anything,anything,identical(B_LO,B_HI),nonnegint]), dbnd, $)
    local var_nm, var_ty;
    var_nm := op([1,1,1], r);
    var_ty := Domain:-Bound:-get(dbnd, var_nm)[1];
    var_ty := foldr( ((q,x)->op(3,q)(x)), var_ty, op(r) );
    (ctx -> DInto(var_nm, var_ty, ctx))
  end proc;
  local flip_rel := table([`=`=`=`,`<>`=`<>`,`<=`=`>=`,`<`=`>`,`>=`=`<=`,`>`=`<`]);
  local countVs := ((vs,c)-> nops(indets(c, DomBoundVar) intersect {op(vs)} ));
  local solOrder := (x->`+`(map(z->op(5,z),x)[]));
end module;

# todo; this should actually solve for a variable, then substitute
# that variable in. In most cases, it would probably be enough to
# leave that as it is; it would simplify later.
singular_pts := module()
  export SimplName  := "Single_pts";
  export SimplOrder := 14;

  local can_remove := ((xs,vs_ty) ->
     nops(xs)>0 and
     andmap(x ->
     x :: `=` and
     ormap(s->s(x)::vs_ty,[lhs,rhs]) and
     not(is(x)), xs));

  export ModuleApply := proc(bnds_ :: DomBound, sh_ :: DomShape, $)
    local bnds := bnds_, sh := sh_, vs, todo, sh1, vs_ty;
    vs := applyop(bl -> select(b->op(3,b)=`Int`, bl), 1, bnds);
    vs := Domain:-Bound:-varsOf(vs,"set");
    vs_ty := 'satisfies(x->x in vs)';
    todo := indets(sh, specfunc(`DConstrain`));
    todo := select(x->can_remove(x,vs_ty), todo);
    subs([seq(t=DSum(),t=todo)], sh);
  end proc;
end module;


program whilest;
var n, i, sum : integer;
begin
    readln(n);
    i := n;
    sum := 0;
    while i > 0 do begin
        sum := sum + i;
        i := i - 1
    end;
    writeln('Summention of 1 - ', n, '  is ', sum)
end.


# This file contains code related to the following situation.
# We have P0 in ICP_N(A) restricting to Q0 in ICP_N(B),
# where B = A \ {a}.  We also have Q1 in ICP_N(B) refining Q0.
# We let U denote the poset of elements M in ICP_N(A) such that
# the restriction of M to B is Q1, and M refines P0.
# The claim is that |U| is contractible.

`random_element/PQQ` := (N::posint) -> (A::set,a) -> proc()
 local B,P0,Q0,Q1;
 B := A minus {a};
 P0 := `random_element/ICP`(N)(A)():
 Q0 := `res/ICP`(N)(A,B)(P0):
 Q1 := NULL:
 while Q1 = NULL or not(`is_leq/ICP`(N)(B)(Q0,Q1)) do
  Q1 := `random_element/ICP`(N)(B)():
 od:
 return [P0,Q0,Q1];
end:

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

`analyse/PQQ` := (N::posint) -> (A::set,a) -> proc(PQQ)
 local B,P0,Q0,Q1,P0r,Q0r,Q1r,L1,n1,T,M,RR,SS,US,PN,PS,U,nU,U0,UR0,
  Q1B,AQ1B,RT,Bm,Bo,Bp,Bmr,Bpr,NB,NU,VV,b,i,j,k,l,beta,kk,ee;
 B := A minus {a};
 P0,Q0,Q1 := op(PQQ);
 T := table():
 T["N"] := N;
 T["A"] := A;
 T["B"] := B;
 T["a"] := a;
 T["P0"] := P0;
 T["Q0"] := Q0;
 T["Q1"] := Q1;
 T["P0_tot"] := `totalise/ICP/ord`(N)(A)(P0);
 T["Q0_tot"] := `totalise/ICP/ord`(N)(B)(Q0);
 T["Q1_tot"] := `totalise/ICP/ord`(N)(B)(Q1);
 P0r := table():
 Q0r := table():
 Q1r := table():
 for i from 1 to N do
  P0r[i] := `rank_table/preord`(A)(P0[i]);
  Q0r[i] := `rank_table/preord`(B)(Q0[i]);
  Q1r[i] := `rank_table/preord`(B)(Q1[i]);
 od:
 T["P0_rank_table"] := eval(P0r);
 T["Q0_rank_table"] := eval(Q0r);
 T["Q1_rank_table"] := eval(Q1r);
 RR := table():
 SS := table():
 US := table():
 for b in B do
  RR[b] := `list_elements/ICP`(N)({a,b}):
  SS[b] := map(`f/fibre_sphere/ICP`(N)(A)(a,b,Q1),RR[b]):
  US[b] := select(M -> `is_leq/ICP`(N)(A)(P0,M),SS[b]):
  PN[b] := evalb(nops(US[b]) > 0);
  PS[b] := evalb(modp(nops(US[b]),2) = 0);
  k := 1;
  while member([a,b],P0[k]) and member([b,a],P0[k]) do
   k := k+1;
  od:
  kk[b] := k;
  ee[b] := `if`(member([a,b],P0[k]),-1,+1);
 od:
 T["fibre_sphere"] := eval(SS);
 T["upper_fibre_part"] := eval(US);
 T["part_is_empty"] := eval(PE);
 T["part_is_sphere"] := eval(PS);
 T["P0_split_stage"] := eval(kk);
 T["P0_split_direction"] := eval(ee);
 T["fibre"] := {seq(op(SS[b]),b in B)};
 U := {seq(op(US[b]),b in B)};
 nU := nops(U);
 U0,UR0 := op(`skeleton/partord/from_comparator`(U)(`is_leq/ICP`(N)(A)));
 T["upper_fibre"] := U;
 T["U0"] := U0;
 T["upper_fibre_size"] := nU;
 T["upper_fibre_skeleton"] := UR0;
 T["upper_fibre_hasse_diagram"] :=
  `hasse_diagram/partord`(U0)(UR0);
 L1 := T["Q1_tot"];
 n1 := nops(L1);
 T["part_list"] := [seq(US[L1[i]],i=1..n1)];
 T["part_is_nonempty_list"] := [seq(PN[L1[i]],i=1..n1)];
 T["part_is_sphere_list"] := [seq(PS[L1[i]],i=1..n1)];
 T["left_nested_list"] :=
  [FAIL,seq(evalb({op(US[L1[i]])} minus {op(US[L1[i-1]])} = {}),i=2..n1)];
 T["right_nested_list"] :=
  [seq(evalb({op(US[L1[i]])} minus {op(US[L1[i+1]])} = {}),i=1..n1-1),FAIL];
 T["part_skeleton"] := [
  seq(select(i -> member(U[i],US[L1[j]]),U0),j=1..n1)
 ];
 Q1B := table():
 AQ1B := table():
 RT := table():
 Bm := table():
 Bo := table():
 Bp := table():
 Bmr := table():
 Bpr := table():
 NU  := table():
 for i from 1 to N do
  Q1B[i] := `block_partition/equiv`(B)(Q1[i] union `op/autorel`(B)(Q1[i]));
  AQ1B[i] := select(u -> member([u[1],a],P0[i]) or member([a,u[1]],P0[i]),Q1B[i]);
  for beta in AQ1B[i] do
   RT[i,beta] := `rank_table/preord`(beta)(Q1[i]);
   NB[i,beta] := max(0,seq(RT[i,beta][b]+1,b in beta));
   Bm[i,beta] := select(b -> not(member([a,b],P0[i])),beta);
   Bo[i,beta] := select(b -> member([a,b],P0[i]) and member([b,a],P0[i]),beta);
   Bp[i,beta] := select(b -> not(member([b,a],P0[i])),beta);
   Bmr[i,beta] := max(0,seq(RT[i,beta][b]+1,b in Bm[i,beta]));
   Bpr[i,beta] := min(NB[i,beta],seq(RT[i,beta][b],b in Bp[i,beta]));
   NU[i,beta] := Bpr[i,beta] - Bmr[i,beta] + 1;
   VV[i,beta] := {seq([i,beta,l-0.5],l=Bmr[i,beta]..Bpr[i,beta])};
  od:
 od:
 Q1B[N+1] := {seq({b},b in B)};
 AQ1B[N+1] := {};
 T["Q1_comparability_blocks"] := eval(Q1B):
 T["admissible_blocks"] := eval(AQ1B);
 T["admissible_tree"] := [seq(seq([i,beta],beta in AQ1B[i]),i=1..N)];
 T["Q1_rank_table"] := eval(RT);
 T["lower_set"]  := eval(Bm);
 T["middle_set"] := eval(Bo);
 T["upper_set"]  := eval(Bp);
 T["lower_rank"] := eval(Bmr);
 T["upper_rank"] := eval(Bpr);
 T["block_quotient_size"] := eval(NB);
 T["num_U"]      := eval(NU);
 T["V"] := {seq(seq(op(VV[i,beta]),beta in AQ1B[i]),i=1..N)};
 return eval(T):
end:

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

`f/PQQ/U/V` := (T) -> proc(M)
 local a,b,j,k,beta,beta0,gamma,rt,r;
 k := 1:
 beta := T["B"]:
 a := T["a"]:
 for j from 2 to T["N"] do
  beta0 := select(b -> member([a,b],M[j]) or member([b,a],M[j]),beta);
  if beta0 <> {} then
   beta := beta0;
   k := j;
  else
   break;
  fi;
 od:
 gamma := select(b -> not(member([a,b],M[k])),beta);
 rt := eval(T["Q1_rank_table"][k,beta]):
 r := max(-1,seq(rt[b],b in gamma)) + 0.5;
 return [k,beta,r];
end:

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

`g/PQQ/V/U` := (T) -> proc(x)
 local i,k,N,a,b,B,MT,QQ,MM,M,beta,r,b0,L,U,rt;
 k,beta,r := op(x);
 N := T["N"];
 a := T["a"];
 B := T["B"];
 MT := table():
 for i from 1 to N do
  QQ := T["Q1"][i];
  MM := QQ union {[a,a]};
  if i < k then
   b0 := beta[1];
   L := select(b -> member([b,b0],QQ),B);
   U := select(b -> member([b0,b],QQ),B);
   MM := {op(MM),seq([b,a],b in L),seq([a,b],b in U)};
  elif i = k then
   rt := T["Q1_rank_table"][k,beta];
   L := select(b -> rt[b] < r,beta);
   U := select(b -> rt[b] > r,beta);
   MM := {op(MM),seq([b,a],b in L),seq([a,b],b in U)};
  fi;
  MT[i] := MM;
 od:
 M := [seq(MT[i],i=1..N)];
 return M;
end:

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

`is_leq/PQQ/V` := (T) -> proc(x0,x1)
 local k0,k1,beta0,beta1,r0,r1,r2,b0;
 k0,beta0,r0 := op(x0);
 k1,beta1,r1 := op(x1);
 if k0 < k1 then return false; fi;
 if k0 = k1 then
  return evalb(beta0 = beta1 and r0 = r1);
 fi;
 b0 := beta0[1];
 if not(member(b0,beta1)) then return false; fi;
 r2 := T["Q1_rank_table"][k1,beta1][b0];
 if not(r1 = r2 - 0.5 or r1 = r2 + 0.5) then
  return false;
 fi;
 return true;
end:

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

`rho/PQQ` := (T) -> (j,e) -> proc(x)
 local k,beta,gamma,beta1,b0,QQ,rt,r1;
 k,beta,gamma := op(x);
 if j >= k then return FAIL; fi;
 b0 := beta[1];
 QQ := T["Q1"][j];
 beta1 := select(b -> member([b,b0],QQ) or member([b0,b],QQ),T["B"]);
 rt := T["Q1_rank_table"][j,beta1];
 r1 := rt[beta[1]] + 0.5 * e;
 return [j,beta1,r1];
end:

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

`describe/PQQ` := proc(T)
 cat(`describe/ICP`(T["N"])(T["A"])(T["P0"]),"\n",
     `describe/ICP`(T["N"])(T["B"])(T["Q0"]),"\n",
     `describe/ICP`(T["N"])(T["B"])(T["Q1"]),"\n");
end:

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

`check_UV/PQQ` := proc(T)
 local N,A,U,V,ff,gg,M,M0,M1,x,x0,x1,cU,cV;
 N := T["N"];
 A := T["A"];
 U := T["upper_fibre"]:
 V := T["V"]:
 ff := table():
 gg := table():
 for M in U do
  x := `f/PQQ/U/V`(T)(M);
  if not(member(x,V)) then return false; fi;
  M1 := `g/PQQ/V/U`(T)(x);
  if M <> M1 then return false; fi;
  ff[M] := x;
 od:
 for x in V do
  M := `g/PQQ/V/U`(T)(x);
  if not(member(M,U)) then return false; fi;
  x1 := `f/PQQ/U/V`(T)(M);
  if x <> x1 then return false; fi;
  gg[x] := M;
 od:
 for x0 in V do
  for x1 in V do
   M0 := gg[x0];
   M1 := gg[x1];
   cU := `is_leq/ICP`(N)(A)(M0,M1);
   cV := `is_leq/PQQ/V`(T)(x0,x1);
   if cU <> cV then return false; fi;
  od;
 od;
 return true;
end:

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

`check_rho/PQQ` := proc(T)
 global reason;
 local VV,i,j,k,x,y,z,C,y1,y2,y3,y4,y5,y6;
 VV := table():
 for k from 1 to T["N"] do
  VV[k] := select(x -> x[1] = k,T["V"]):
 od:
 for k from 2 to T["N"] do
  for j from 1 to k-1 do
   for x in VV[k] do
    y := `rho/PQQ`(T)(j,-1)(x);
    z := `rho/PQQ`(T)(j,+1)(x);
    C := select(w -> `is_leq/PQQ/V`(T)(x,w),VV[j]);
    if (y = z) or (C <> {y,z}) then
     return false;
    fi;
   od;
  od;
 od;
 for k from 3 to T["N"] do
  for j from 2 to k-1 do
   for i from 1 to j-1 do
    for x in VV[k] do
     y1 := `rho/PQQ`(T)(i,-1)(x);
     y2 := `rho/PQQ`(T)(i,+1)(x);
     y3 := `rho/PQQ`(T)(i,-1)(`rho/PQQ`(T)(j,-1)(x));
     y4 := `rho/PQQ`(T)(i,-1)(`rho/PQQ`(T)(j,+1)(x));
     y5 := `rho/PQQ`(T)(i,+1)(`rho/PQQ`(T)(j,-1)(x));
     y6 := `rho/PQQ`(T)(i,+1)(`rho/PQQ`(T)(j,+1)(x));
     if not(y3 = y1 and y4 = y1 and y5 = y2 and y6 = y2) then
      reason := [i,j,k,x,y1,y2,y3,y4,y5,y6];
      return false;
     fi;
    od;
   od;
  od;
 od;

 return true;
end:

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

`check_UL/PQQ` := proc(T)
 global reason;
 local N,A,B,a,b,Q,kk,k,L,U,S,i,e;
 N := T["N"];
 a := T["a"];
 A := T["A"];
 B := T["B"];
 Q := T["Q1"];
 kk := T["P0_split_stage"];
 for b in B do
  k := kk[b];
  L := {seq(seq(`f_alt/fibre_sphere/ICP`(N)(A)(a,b,Q)([i,e]),e in {-1,1}),i=1..k-1)};
  U := {seq(seq(`f_alt/fibre_sphere/ICP`(N)(A)(a,b,Q)([i,e]),e in {-1,1}),i=k+1..N)};
  S := {op(T["upper_fibre_part"][b])};
  if not((U intersect S = {}) and (L minus S = {})) then
   return false;
  fi;
 od:
 return true;
end:

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

`check_is_sphere/PQQ` := proc(T)
 global reason;
 local N,A,B,a,b,P0,Q0,Q1,kk,k,ee,e,C,D,E,F,u;
 N := T["N"];
 a := T["a"];
 A := T["A"];
 B := T["B"];
 P0 := T["P0"];
 Q0 := T["Q0"];
 Q1 := T["Q1"];
 kk := eval(T["P0_split_stage"]);
 ee := eval(T["P0_split_direction"]);
 for b in B do
  k := kk[b];
  e := ee[b];
  if e = -1 then
   C := select(x -> member([x,b],Q0[k]) and member([b,x],Q0[k]),B);
   D := select(x -> member([x,b],Q1[k]) and
                    not(member([b,x],Q1[k])),C);
   E := select(x -> member([a,x],P0[k]) and
                    member([x,b],P0[k]) and
                    not(member([x,a],P0[k])) and
                    not(member([b,x],P0[k])),B);
   F := select(x -> member([x,b],Q1[k]) or member([b,x],Q1[k]),E);
  else
   C := select(x -> member([x,b],Q0[k]) and member([b,x],Q0[k]),B);
   D := select(x -> member([b,x],Q1[k]) and
                    not(member([x,b],Q1[k])),C);
   E := select(x -> member([x,a],P0[k]) and
                    member([b,x],P0[k]) and
                    not(member([a,x],P0[k])) and
                    not(member([x,b],P0[k])),B);
   F := select(x -> member([x,b],Q1[k]) or member([b,x],Q1[k]),E);
  fi;
  u := not(evalb(D = {} and F = {}));
  if u <> T["part_is_sphere"][b] then
   reason := [b,k,e,C,D,E,F]:
   return false;
  fi;
 od:
 return true;
end:

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

`check_sphere_in_ball/PQQ` := proc(T)
 global reason;
 local N,A,B,a,b,P0,Q0,Q1,US,kk,k,ee,e,C,C1,b1;
 N := T["N"];
 a := T["a"];
 A := T["A"];
 B := T["B"];
 P0 := T["P0"];
 Q0 := T["Q0"];
 Q1 := T["Q1"];
 kk := eval(T["P0_split_stage"]);
 ee := eval(T["P0_split_direction"]);
 US := eval(T["upper_fibre_part"]);
 for b in B do
  if T["part_is_sphere"][b] then
   k := kk[b];
   e := ee[b];
   if e = -1 then
    C := select(x -> member([x,b],Q1[k]) and not(member([x,a],P0[k])),B);
    if C = {} then
     reason := [b,k,e,C];
     return false;
    fi;
    # Choose b1 to be Q1[k]-minimal in C
    C1 := C;
    while C1 <> {} do
     b1 := C1[1];
     C1 := select(x -> not(member([b1,x],Q1[k])),C1);
    od:
    if T["part_is_sphere"][b1] or
       ({op(US[b])} minus {op(US[b1])} <> {}) or
       member([b,b1],Q1[k]) then
     reason := [b,k,e,C,b1];
     return false;
    fi;
   else
    C := select(x -> member([b,x],Q1[k]) and not(member([a,x],P0[k])),B);
    if C = {} then
     reason := [b,k,e,C];
     return false;
    fi;
    # Choose b1 to be Q1[k]-maximal in C
    C1 := C;
    while C1 <> {} do
     b1 := C1[1];
     C1 := select(x -> not(member([x,b1],Q1[k])),C1);
    od:
    if T["part_is_sphere"][b1] or
       ({op(US[b])} minus {op(US[b1])} <> {}) or
       member([b1,b],Q1[k]) then
     reason := [b,k,e,C,b1];
     return false;
    fi;
   fi;
  fi;
 od:
 return true;
end:

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

`check_nonempty_interval/PQQ` := proc(T)
 local L,J,i,j,j0,j1;
 L := T["part_is_nonempty_list"];
 if not(`or`(op(L))) then return false; fi;
 J := select(i -> L[i],[seq(i,i=1..nops(L))]);
 j0 := min(op(J));
 j1 := max(op(J));
 return `and`(seq(L[j],j=j0..j1));
end:

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

`check_adjacent_nonempty/PQQ` := proc(T)
 local L,P,i;
 L := T["part_is_nonempty_list"];
 P := T["part_list"];
 for i from 1 to nops(L)-1 do
  if L[i] and L[i+1] and ({op(P[i])} intersect {op(P[i+1])} = {}) then
   return false;
  fi;
 od;
 return true;
end:

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

`check_incomparable_min/PQQ` := proc(T)
 local n,LN,RN,P,i,b,P1;
 n := nops(T["B"]);
 LN := T["left_nested_list"];
 RN := T["right_nested_list"];
 P := T["part_list"];
 for i from 1 to n-1 do
  if not(LN[i+1]) and not(RN[i]) then
   b := T["Q1_tot"][i];
   P1 := `m/fibre_sphere/ICP`(T["N"])(T["A"])(a,b,T["Q1"]):
   if not (member(P1,{op(P[i])}) and member(P1,{op(P[i+1])})) then
    return false;
   fi;
  fi;
 od;
 return true;
end:

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

`check_intersections_nested/PQQ` := proc(T)
 global reason;
 local n,P,PS,i,j,k;
 n := nops(T["B"]);
 P := T["part_list"];
 for i from 1 to n do PS[i] := {op(P[i])}; od:
 for i from 1 to n-2 do
  for j from i+1 to n-1 do
   for k from j+1 to n do
    if (PS[i] intersect PS[k]) minus PS[j] <> {} then
     reason := [i,j,k];
     return false;
    fi;
   od;
  od;
 od;
 return true;
end:


# This is a generic bracket operation.  With more than two arguments,
# it represents an iterated bracket associated like [a,[b,[c,[d,e]]]].
# Multilinearity rules are applied automatically, and the Jacobi
# rule is also used automatically to convert other kinds of iterated
# brackets into the fully right associated form.

bracket := proc()
 local n,m,i,j,u,a,b,c,v,ac,av,x,y;
 n := nargs;
 for i from 1 to n do
  u := seq(args[j],j=1..i-1);
  a := args[i];
  v := seq(args[j],j=i+1..n);
  if type(a,`+`) then
   return map(t -> bracket(u,t,v),a);
  elif type(a,`*`) then
   ac,av := selectremove(type,a,rational);
   if ac <> 1 then
    return ac * bracket(u,av,v);
   fi;
  elif type(a,specfunc(bracket)) then
   if i = n then
    return bracket(u,op(a));
   else
    b := op(1,a);
    c := bracket(op(2..-1,a));
    if nops(c) = 1 then c := op(c); fi;
    return bracket(u,b,c,v) - bracket(u,c,b,v);
   fi;
  fi;
 od;

 if type(args[n],specfunc(bracket)) then
  return bracket(args[1..n-1],op(args[n]));
 fi;

 return 'procname'(args);
end:


N := 3;
A := {1,2,3,4,5,6,7,8};
B := {10,20,30,40};
C := {11,22,33};

check_operad("comm",[],A,B,C);

check_operad("ord",[],A,B,C);

check_operad("nonempty_subsets",[],A,B,C);

check_operad("partitions",[],A,B,C);

check_operad("trees",[],A,B,C);

check_operad("full_trees",[],A,B,C);

check_operad("simplex",[],A,B,C);

check_operad("simplex_interior",[],A,B,C);

check_operad("ord_simplex_interior",[],A,B,C);

check_operad("prime_simplex",[],A,B,C);

check_operad("cubes",[[N]],A,B,C);

check_operad("one_cubes_prime",[],A,B,C);

check_operad("stasheff_trees",[],A,B,C);

check_operad("stasheff_star",[],A,B,C);

# Deferred, because we have not defined `random_element/height_functions`
#check_operad("height_functions",[],A,B,C);
#check_operad("Fbar",[[N]],A,B,C);


`is_element/colour_profiles` := (C::set) -> (n::nonnegint) -> proc(c)
 type(c,list) and nops(c) = n and {op(c)} minus C = {};
end:

`is_equal/colour_profiles` := (C::set) -> (n::nonnegint) -> (c,b) -> evalb(c = b);

`list_elements/colour_profiles` := (C::set) -> proc(n::nonnegint)
 local L,i,x,c;
 L := [[]];
 for i from 1 to n do
  L := [seq(seq([op(c),x],x in C),c in L)];
 od:
 return L;
end:

`count_elements/colour_profiles` := (C::set) -> (n::nonnegint) -> nops(C)^n;

`random_element/colour_profiles` := (C::set) -> (n::nonnegint) -> proc()
 local i;
 [seq(random_element_of(C),i=1..n)];
end:

`o/colour_profiles` := proc() map(op,[args]); end:

`gamma/colour_profiles` := (C::set) -> (L::list(nonnegint)) -> proc(c,d)
 map(op,d);
end:

`circ/colour_profiles` := (C::set) -> (i,m,n) -> proc(c,b)
 [op(1..i-1,c),op(b),op(i+1..m,c)];
end:


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

`is_element/ACP` := (N::posint) -> (A::set) -> proc(Q)
 local procname_,i,U,V;

 global reason;

 procname_ := "is_element/ACP";

 if not (type(Q,list) and nops(Q) = N) then
  reason := [procname_,"Q is not a list of length N",Q,N];
  return false;
 fi;

 for i from 1 to N do
  if not `is_element/preord`(A)(Q[i]) then
   reason := [procname_,"Q[i] is not a preorder on A",Q[i],A,reason];
   return false;
  fi;
 od;

 if not `is_total/preord`(A)(Q[1]) then
  reason := [procname_,"Q[1] is not total",Q[1]];
  return false;
 fi;

 for i from 1 to N-1 do
  U := Q[i] intersect `op/preord`(A)(Q[i]);
  V := Q[i+1] union `op/preord`(A)(Q[i+1]);
  if U <> V then
   reason := [procname_,"Q[i] and Q[i+1] do not match",Q[i],Q[i+1]];
   return false;
  fi;
 od;

 return true;
end:

`is_equal/ACP` := (N::posint) -> (A::set) -> proc(Q1,Q2)
 local procname_;
 global reason;

 procname_ := "is_equal/ACP";

 if Q1 <> Q2 then
  reason := [procname_,"Q1 <> Q2",Q1,Q2];
  return false;
 fi;

 return true;
end:

`is_leq/ACP` := (N::posint) -> (A::set) -> proc(Q1,Q2)
 local i;

 for i from 1 to N do
  if Q2[i] minus Q1[i] <> {} then
   return false;
  fi;
 od;

 return true;
end:

`list_elements/ACP` := (N::posint) -> proc(A::set)
 local W,X,Y,Z,Q,R,S,pi,B;

 if nops(A) = 0 then
  return FAIL;
 fi;

 if N = 1 then
  X := `list_elements/total_preord`(A);
  return map(Q -> [Q],X);
 fi;

 X := `list_elements/ACP`(N-1)(A);
 Y := NULL;

 for Q in X do
  pi := `block_partition/preord`(A)(Q[N-1]);
  Z := [{}];
  for B in pi do
   W := `list_elements/total_preord`(B);
   Z := [seq(seq(R union S,S in W),R in Z)];
  od:
  Y := Y,seq([op(Q),R],R in Z);
 od;
 return [Y];
end:

`count_elements/ACP` := (N::posint) -> proc(A::set)
 local d;
 add(Stirling2(nops(A),d)*d!*N^(d-1),d=1..nops(A));
end:

`random_element/ACP` := (N::posint) -> (A::set) -> proc()
 local i,n,pi,Q,R,S,B,C;

 if nops(A) = 0 then
  return FAIL;
 fi;

 R := `random_element/total_preord`(A)();
 Q := [R];
 for i from 2 to N do
  pi := `block_partition/preord`(A)(R);
  R := {};
  for B in pi do
   S := `random_element/total_preord`(B)();
   R := R union S;
  od;
  Q := [op(Q),R];
 od;

 return Q;
end:

`rank_vector/ACP` := (N::posint) -> (A::set) -> proc(Q)
 local i;
 [seq(`rank/preord`(N)(A)(Q[i]),i=1..N)];
end:

`rank/ACP` := (N::posint) -> (A::set) -> proc(Q)
 local i;
 add(`rank/preord`(N)(A)(Q[i]),i=1..N);
end:

`res/ACP` := (N::posint) -> (A::set,B::set) -> proc(Q)
 return map(`intersect`,Q,`top/autorel`(B));
end:

`is_constant/ACP` := (N::posint) -> (A::set) -> proc(Q)
 return evalb(nops(Q[N]) = nops(A)^2);
end;

`is_separated/ACP` := (N::posint) -> (A::set) -> proc(Q)
 return evalb(Q[N] minus `id/autorel`(A) = {});
end;

`bot/ACP` := (N::posint) -> (A::set) -> [`top/autorel`(A) $ N];

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

`mu/W/ACP` := (N::posint) -> (A::set) -> proc(x)
 local QT,ET,AA,i,a,b;

 QT := table():
 ET := table():
 AA := {seq(seq([a,b],b in A),a in A)};
 ET[0] := AA;

 for i from 1 to N do
  QT[i] := select(ab -> is(x[ab[1]][i] <= x[ab[2]][i]),ET[i-1]);
  ET[i] := QT[i] intersect `op/autorel`(A)(QT[i]);
 od:

 return [seq(QT[i],i=1..N)];
end:

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

 u := [seq(`rank_table/preord`(A)(Q[i]),i=1..N)];
 x := table():
 for a in A do
  x[a] := [seq(u[i][a],i=1..N)];
 od:

 return eval(x);
end;

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

`is_element/realisation/ACP` := (N::posint) -> (A::set) ->
 `is_element/realisation/generic`("ACP",
  eval(`is_element/ACP`(N)(A)),
  eval(`is_leq/ACP`(N)(A))
 );

`is_equal/realisation/ACP` := (N::posint) -> (A::set) ->
 `is_equal/realisation/generic`("ACP",
  eval(`is_equal/ACP`(N)(A))
 );

`sigma/realisation/ACP/W` := (N::posint) -> (A::set) -> proc(u)
 local x,y,m,a,Q,S;

 x := table();
 for a in A do
  x[a] := [0$N];
 od:

 S := map(op,[indices(u)]);
 for Q in S do
  y := `sigma/ACP/W`(N)(A)(Q);
  m := u[Q];
  for a in A do
   x[a] := x[a] +~ (m *~ y[a]);
  od:
 od:

 return eval(x);
end;

`mu_aux/ACP` := (N::posint) -> (A::set) -> proc(x)
 local Q,t,i,ab,a,b,s,y,u;

 Q := `mu/W/ACP`(N)(A)(x);

 if nops(Q[N]) = nops(A)^2 then
  return(table());
 fi;

 t := 1;
 for i from 1 to N do
  for ab in Q[i] minus `op/autorel`(A)(Q[i]) do
   a,b := op(ab);
   t := min(t,x[b][i] - x[a][i]);
  od;
 od;

 s := `sigma/ACP/W`(N)(A)(Q);
 y := table();
 for a in A do
  y[a] := x[a] -~ (t *~ s[a]);
 od;

 u := `mu_aux/ACP`(N)(A)(y);
 if `is_element/RR`(u[Q]) then
  u[Q] := u[Q] + t;
 else
  u[Q] := t;
 fi;

 return eval(u);
end;

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

`rank_vector/ACP` := (N) -> (A) -> proc(Q)
 local i;
 return [seq(`rank/preord`(A)(Q[i])-1,i=1..N)];
end;

`rank/ACP` := (N) -> (A) -> proc(Q)
 return `+`(op(`rank_vector/ACP`(N)(A)(Q)));
end;

`cofunctor/ACP` := (N::posint) -> (A::set,B::set) -> (f) -> proc(Q)
 map(`cofunctor/autorel`(A,B)(f),Q);
end;

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

`is_element/split_spots/ACP` := (N::posint) -> (A::set) -> (Q) -> proc(iCD)
 global reason;
 local procname_,i,B,C,D,B1,E,C1;

 procname_ := "is_element/split_spots/ACP";

 if not(type(iCD,list) and nops(iCD) = 3) then
  reason := [procname_,"iCD is not a list of length 3",iCD];
  return false;
 fi;

 i,C,D := op(iCD);
 if not(type(i,posint) and i <= N) then
  reason := [procname_,"i is not in [1,N]",i,N];
  return false;
 fi;

 if not(type(C,set) and nops(C) > 0 and C minus A = {}) then
  reason := [procname_,"C is not a nonempty subset of A",C,A];
  return false;
 fi;

 if not(type(D,set) and nops(D) > 0 and D minus A = {}) then
  reason := [procname_,"D is not a nonempty subset of A",D,A];
  return false;
 fi;

 if C intersect D <> {} then
  reason := [procname_,"C and D are not disjoint",C,D];
  return false;
 fi;

 B := C union D;

 B1 := select(a -> member([a,B[1]],Q[i]) and member([B[1],a],Q[i]),A);
 if B1 <> B then
  reason := [procname_,"C u D is not an equivalence class for Q[i]",C,D,i,Q[i]];
  return false;
 fi;

 if i < N then
  E := select(ab -> member([ab[2],ab[1]],Q[i+1]),Q[i+1]);
  C1 := map(ab -> ab[1],select(ab -> member(ab[1],C),E));
  if C minus C1 <> {} then
   reason := [procname_,"C is not a union of equivalence classes for Q[i+1]",C,D,i,Q[i+1]];
   return false;
  fi;
 fi;

 return true;
end:

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

`list_elements/split_spots/ACP` := (N::posint) -> (A::set) -> proc(Q)
 local E,L,i,B,m,UU,U,CC,C,a;

 E := [seq(`block_partition/preord`(A)(Q[i]),i=1..N),{seq({a},a in A)}];
 L := NULL;
 for i from 1 to N do
  for B in E[i] do
   UU := select(U -> U minus B = {},E[i+1]);
   m := nops(UU);
   UU := select(U -> nops(U) < m,`list_elements/nonempty_subsets`(UU));
   CC := map(U -> map(op,U),UU);
   L := L,seq([i,C,B minus C],C in CC);
  od:
 od:
 return [L];
end:

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

`split/ACP` := (N::posint) -> (A::set) -> (Q) -> proc(iCD)
 local i,j,C,D,CD,DC,c,d;

 i,C,D := op(iCD);
 CD := {seq(seq([c,d],d in D),c in C)};
 DC := {seq(seq([d,c],d in D),c in C)};
 return([
  seq(Q[j],j=1..i-1),
  Q[i] minus DC,
  seq(Q[j] minus DC minus CD,j=i+1..N)
 ]);
end:

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

`is_element/glue_spots/ACP` := (N::posint) -> (A::set) -> (Q) -> proc(iCDS)
 global reason;
 local procname_,i,C,D,S,Qi,Qis,Ei,C1,D1,E,nC,nD;

 procname_ := "is_element/glue_spots/ACP";

 if not(type(iCDS,list) and nops(iCDS) = 4) then
  reason := [procname_,"iCDS is not a list of length 4",iCDS];
  return false;
 fi;

 i,C,D,S := op(iCDS);
 if not(type(i,posint) and i <= N) then
  reason := [procname_,"i is not in [1,N]",i,N];
  return false;
 fi;

 if not(type(C,set) and nops(C) > 0 and C minus A = {}) then
  reason := [procname_,"C is not a nonempty subset of A",C,A];
  return false;
 fi;

 if not(type(D,set) and nops(D) > 0 and D minus A = {}) then
  reason := [procname_,"D is not a nonempty subset of A",D,A];
  return false;
 fi;

 if C intersect D <> {} then
  reason := [procname_,"C and D are not disjoint",C,D];
  return false;
 fi;

 Qi := Q[i];
 Ei,Qis := selectremove(ab -> member([ab[2],ab[1]],Qi),Qi);

 if not(member([C[1],D[1]],Qis)) then
  reason := [procname_,"not(C < D)",C,D,Qi];
  return false;
 fi;

 C1 := select(a -> member([a,C[1]],Ei),A);
 if C1 <> C then
  reason := [procname_,"C is not an equivalence class",C,C1,Qi];
  return false;
 fi;

 D1 := select(a -> member([a,D[1]],Ei),A);
 if D1 <> D then
  reason := [procname_,"D is not an equivalence class",D,D1,Qi];
  return false;
 fi;

 E := select(a -> member([C[1],a],Qis) and member([a,D[1]],Qis),A);
 if E <> {} then
  reason := [procname_,"C and D are not adjacent",C,D,E,Qi];
  return false;
 fi;

 if i = N then
  if S = {} then
   return true;
  else
   reason := [procname_,"i=N but S <> {}",i,N,S];
   return false;
  fi;
 fi;

 nC := nops(`block_partition/preord`(C)(`res/preord`(A,C)(Q[i+1])));
 nD := nops(`block_partition/preord`(D)(`res/preord`(A,D)(Q[i+1])));

 if not (type(S,set(posint)) and
         nops(S) = nC and
         max(op(S)) <= nC+nD) then
  reason := [procname_,"S is not a subset of size nC in [1,nC+nD]",S,C,D,Q[i+1]];
  return false;
 fi;

 return true;
end:

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

`list_elements/glue_spots/ACP` := (N::posint) -> (A::set) -> proc(Q)
 local L,i,j,Qi,Qis,E,E0,E1,B,U,C,a,b,r0,nn,SS,S;

 L := NULL;
 for i from 1 to N do
  Qi := Q[i];
  Qis := remove(ab -> member([ab[2],ab[1]],Qi),Qi);
  E := `block_partition/preord`(A)(Qi);
  E0 := NULL;
  E1 := table():
  for B in E do
   E0 := E0,B[1];
   E1[B[1]] := B;
  od:
  E0 := {E0}:
  U := table():
  C := table():
  for a in E0 do
   U[a] := select(b -> member([a,b],Qis),E0);
  od:
  for a in E0 do
   C[a] := U[a] minus {seq(op(U[b]),b in U[a])};
  od:
  if i < N then
   r0 := `rank_table/preord`(A)(Q[i+1]);
   for a in E0 do
    nn[a] := 1 + max(seq(r0[b],b in E1[a]));
   od;
  fi;

  for a in E0 do
   for b in C[a] do
    if i < N then
     SS := combinat[choose]({seq(j,j=1..nn[a]+nn[b])},nn[a]);
    else
     SS := {{}};
    fi;
    L := L,seq([i,E1[a],E1[b],S],S in SS);
   od;
  od;
 od:
 return [L];
end:

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

`glue/ACP` := (N::posint) -> (A::set) -> (Q) -> proc(iCDS)
 local i,C,D,S,CD,DC,c,d,P,j,k,rc,rd,nc,nd,ic,id,n,Cn,Dn,BB,x,y;

 i,C,D,S := op(iCDS);
 CD := {seq(seq([c,d],d in D),c in C)};
 DC := {seq(seq([d,c],d in D),c in C)};
 P := table():
 for j from 1 to i-1 do
  P[j] := Q[j];
 od:
 P[i] := Q[i] union DC;
 if i < N then
  rc := `rank_table/preord`(C)(Q[i+1]);
  rd := `rank_table/preord`(D)(Q[i+1]);
  nc := max(seq(rc[c],c in C)) + 1;
  nd := max(seq(rd[d],d in D)) + 1;
  for n from 1 to nc do Cn[n] := select(c -> rc[c] = n-1,C); od;
  for n from 1 to nd do Dn[n] := select(d -> rd[d] = n-1,D); od;
  ic := 0;
  id := 0;
  BB := NULL;
  for j from 1 to nc + nd do
   if member(j,S) then
    ic := ic+1;
    BB := BB,Cn[ic];
   else
    id := id+1;
    BB := BB,Dn[id];
   fi;
  od;
  BB := [BB];
  P[i+1] := Q[i+1] union {seq(seq(seq(seq([x,y],y in BB[k]),x in BB[j]),k=j..nc+nd),j=1..nc+nd)};
 fi;
 for j from i+2 to N do
  P[j] := Q[j];
 od:
 return [seq(P[j],j=1..N)];
end:

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

`describe/ACP` := (N::posint) -> (A::set) -> proc(Q)
 local s,E,i,j,k,r,s0,s1,s2,B,C,m;

 s := "";
 E := {A};
 for i from 1 to N do
  s0 := "";
  for B in E do
   if nops(B) > 1 then
    r := `rank_table/preord`(B)(Q[i] intersect `top/autorel`(B));
    m := max(map(b -> r[b],B));
    s1 := "";
    for j from 0 to m do
     C := select(b -> r[b]=j,B);
     s2 := "";
     for k from 1 to nops(C) do
      s2 := cat(s2,`if`(k>1,"=",""),sprintf("%A",C[k]));
     od:
     s1 := cat(s1,`if`(j>0,"<",""),s2);
    od;
    s0 := cat(s0,`if`(s0="","",","),s1);
   fi;
  od:
  s := cat(s,`if`(s="","",";"),s0);
  E := `block_partition/preord`(A)(Q[i]);
 od;
 s := cat("(",s,")");
end:


kernelopts(assertlevel=2): # be strict on all assertions while testing
with(Hakaru):
with(KB):
with(Summary):
with(NewSLO, simplify_factor_assuming):

module()
  local kb, b, mr, f, bkt;
  kb := empty;
  b, kb := genType(b, HInt(Bound(`>=`,0),Bound(`<=`,size(as)-1)), kb);
  mr, f := summarize(piecewise(b=idx(z,i), idx(t,i), 0),
                     kb, i, summary);
  CodeTools[Test](indets(mr, 'Add(anything)'), {Add(idx(t,i))},
                  label="Simple example from Summary.txt");
  f := simplify_factor_assuming(f, kb);
  bkt := bucket(mr, i=0..size(t)-1);
  CodeTools[Test](eval(f, summary=bkt),
                  sum(piecewise(b=idx(z,i), idx(t,i), 0), i=0..size(t)-1),
                  simplify);
end module:

module()
  local kb, zNew, b, mr, f, bkt;
  kb := empty;
  zNew, kb := genType(zNew, HInt(Bound(`>=`,0),Bound(`<=`,size(as)-1)), kb);
  b, kb := genType(b, HInt(Bound(`>=`,0),Bound(`<=`,size(as)-1)), kb);
  mr, f := summarize(piecewise(b=piecewise(i=docUpdate,zNew,idx(z,i)),
                               idx(t,i)),
                     kb, i, summary);
  CodeTools[Test](indets(mr, 'Add(anything)'), {Add(idx(t,i))},
                  label="First \"summate i\" in offshore under gmm_gibbs.hk");
  f := simplify_factor_assuming(f, kb);
  bkt := bucket(mr, i=0..size(t)-1);
  CodeTools[Test](eval(f, summary=bkt),
                  piecewise(b=zNew,
                            sum(piecewise(i=docUpdate, idx(t,i), 0),
                                i=0..size(t)-1),
                            0) +
                  sum(piecewise(And(b=idx(z,i), Not(i=docUpdate)),
                                idx(t,i),
                                0),
                      i=0..size(t)-1),
                  simplify);
end module:

module()
  local kb, docUpdate, zNew, k, i, mr, f, bkt;
  kb := empty;
  docUpdate, kb := genType(docUpdate, HInt(Bound(`>=`,0),Bound(`<=`,size(z)-1)), kb);
  zNew, kb := genType(zNew, HInt(Bound(`>=`,0),Bound(`<=`,size(topic_prior)-1)), kb);
  k, kb := genType(k, HInt(Bound(`>=`,0),Bound(`<=`,size(topic_prior)-1)), kb);
  i, kb := genType(i, HInt(Bound(`>=`,0),Bound(`<=`,size(word_prior)-1)), kb);
  mr, f := summarize(piecewise(idx(doc,j)=docUpdate,
                               piecewise(k=zNew,
                                         piecewise(i=idx(w,j),1,0),
                                         0),
                               0),
                     kb, j, summary);
  CodeTools[Test](indets(mr, 'Add(anything)'), {Add(1)},
                  label="First \"summate j\" in offshore under naive_bayes_gibbs.hk");
  f := simplify_factor_assuming(f, kb);
  bkt := bucket(mr, j=0..size(w)-1);
  CodeTools[Test](eval(f, summary=bkt),
                  piecewise(k=zNew,
                            sum(piecewise(And(i=idx(w,j),
                                              docUpdate=idx(doc,j)),
                                          1,
                                          0),
                                j=0..size(w)-1),
                            0),
                  simplify);
end module:

module()
  local kb, i18, mr, f, bkt;
  kb := empty;
  i18, kb := genType(i18, HInt(Bound(`>=`,0),Bound(`<=`,word_prior_size-1)), kb);
  mr, f := summarize(piecewise(docUpdate=idx(doc,i13),
                               piecewise(And(i=zNew8, i18=idx(w,i13)), 1, 0),
                               0),
                     kb, i13, summary);
  CodeTools[Test](indets(mr, 'Add(anything)'), {Add(1)},
                  label="Spenser's example from 2017-01-23 email");
  f := simplify_factor_assuming(f, kb);
  bkt := bucket(mr, i13=0..word_prior_size-1);
  CodeTools[Test](eval(f, summary=bkt),
                  piecewise(i=zNew8,
                            sum(piecewise(And(i18=idx(w,i13),
                                              docUpdate=idx(doc,i13)),
                                          1,
                                          0),
                                i13=0..word_prior_size-1), 0),
                  simplify);
end module:


 func &addf32r(
  var %i f32, var %j f32
  ) f32 {
   return (
     add f32(dread f32 %i, dread f32 %j))}

 func &addf32I (
  var %i f32
  ) f32 {
   return (
     add f32(dread f32 %i,
       constval f32 1.234f))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


# Kinematik-Berechnung 3. Arm KAS5
# Beschreibung
#
# Modell m5:
# * Kurbel N7 ist starr mit Körper K2 gekoppelt (über die Achse) (wie m3),
# * Zahnradkopplung zwischen Körpern Z2 und Z3 (Unterschied zu m3)
#
# Setze die Zwangsbedingung (Zahnradkopplung) in die bereits berechneten Zwangsbedingungen für das KAS5m3 ein
#
# Berechnung der Kopplung der Zahnräder am Ellenbogen
# Autor
# Moritz Schappler, schappler@irt.uni-hannover.de, 2016-02
# Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
# Initialisierung
restart:
kin_constraints_exist := true: # Für Speicherung
;
with(LinearAlgebra):
with(StringTools):
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):
# Lese Ergebnisse der Kinematik von KAS5m3 aus.
# Siehe KAS5m3_sym_codegen_kinematic_constraints.mw
# kintmp_qs, kintmp_qt, lpar_qs, lpar_qt, kintmp_subsexp
read  sprintf("../codeexport/KAS5m3/tmp/kinematic_constraints_maple_inert.m", robot_name):
kintmp_qs_KAS5m3 := kintmp_qs:
kintmp_qt_KAS5m3 := kintmp_qt:
lpar_qs_KAS5m3 := lpar_qs:
lpar_qt_KAS5m3 := lpar_qt:
kintmp_subsexp_KAS5m3 := kintmp_subsexp:
# Wende Zwangsbedingungen aus Zahnradkontakt an
# Wandle die verallgemeinerten Koordinaten um. Benutze die Reihenfolge für KAS5m5.
# Funktion zur Ersetzung der Gelenkwinkel (allgemein -> m3)
subs_q_J_m3 := proc(A)
  local A_s, j;
  A_s := A;
  for j from 1 to RowDimension(qJ_s) do
    A_s := subs({qJ_s(j,1) = qJs_KAS5m3(j,1)}, A_s):
  end do:
  return A_s:
end proc:
qJs_KAS5m3:=Matrix(7, 1, [qJs1_m3, qJs2_m3, qJs3_m3, qJs4_m3, qJs5_m3, qJs6_m3, qJs7_m3]):
kintmp_subsexp_KAS5m3 := subs_q_J_m3(kintmp_subsexp_KAS5m3):
kintmp_qs_KAS5m3 := subs_q_J_m3(kintmp_qs_KAS5m3):
lpar_qs_KAS5m3 := subs_q_J_m3(lpar_qs_KAS5m3):
# Funktion zur Ersetzung der verallgemeinerten Koordinaten (m3 -> m5)
subs_q_m3_m5 := proc(A)
  local A_s, j;
  A_s := A;
  for j from 1 to RowDimension(qJ_s) do
    A_s := subs({qJs_KAS5m3(j,1) = qJs_KAS5m3m5subs(j,1)}, A_s):
  end do:
  return A_s:
end proc:
qJs_KAS5m3m5subs:=Matrix(7, 1, [qJs1_m5, qJs2_m5, qJs3_m5, qJs4_m5, qJs4_m5-qJs3_m5+delta18s, qJs5_m5, 0]):
kintmp_subsexp_KAS5m5 := subs_q_m3_m5(kintmp_subsexp_KAS5m3):
kintmp_qs_KAS5m5 := subs_q_m3_m5(kintmp_qs_KAS5m3):
lpar_qs_KAS5m5 := subs_q_m3_m5(lpar_qs_KAS5m3):
# Konvertiere Ergebnisse
# Rückersetzung der markierten Koordinaten gegen die normale Form (qJ_KAS5m5 -> qJ)
subs_q_m5_J := proc(A)
  local A_s, j;
  A_s := A;
  for j from 1 to RowDimension(qJs_KAS5m5) do
    A_s := subs({qJs_KAS5m5(j,1) = qJ_s(j,1)}, A_s):
  end do:
  return A_s:
end proc:
qJs_KAS5m5:=Matrix(5, 1, [qJs1_m5, qJs2_m5, qJs3_m5, qJs4_m5, qJs5_m5]):
kintmp_subsexp := subs_q_m5_J(kintmp_subsexp_KAS5m5):
kintmp_qs := subs_q_m5_J(kintmp_qs_KAS5m5):
lpar_qs := subs_q_m5_J(lpar_qs_KAS5m5):
kintmp_qt := convert_s_t(kintmp_qs):
lpar_qt := convert_s_t(lpar_qs):
# Speichern der Ergebnisse
save kin_constraints_exist, kintmp_qs, kintmp_qt, lpar_qs, lpar_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert", robot_name):
save kin_constraints_exist, kintmp_qs, kintmp_qt, lpar_qs, lpar_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
# Liste der Parameter speichern
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( kintmp_subsexp(..,2) )):
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_maple", robot_name):
MatlabExport(Transpose(kc_symbols), sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_matlab.m", robot_name), 2):
printf("Zwangsbedingungen der Parallelstruktur von KAS5m3 nach KAS5m5 angepasst. %s\n", FormatTime("%Y-%m-%d %H:%M:%S")):


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

`is_element/SCP2` := (N::posint) -> (A::set,B::set) -> proc(QP)
 local i,Q0,Q,P;

 global reason;

 if not(type(QP,list) and nops(QP) = 2) then
  reason := [convert(procname,string),"QP is not a list of length two",reason];
 fi;

 Q,P := op(QP);

 if not `is_element/SCP`(N)(A)(Q) then
  reason := [convert(procname,string),"Q not in SCP(N)(A)",reason];
  return false;
 fi;

 if not `is_element/SCP`(N)(B)(P) then
  reason := [convert(procname,string),"P not in SCP(N)(B)",reason];
  return false;
 fi;

 Q0 := `res/SCP`(N)(A,B)(Q);

 if Q0 <> P and Q0 <> [`top/autorel`(B)$N] then
  reason := [convert(procname,string),"Q and P are incompatible"];
  return false;
 fi;

 return true;
end:

`is_equal/SCP2` := (N::posint) -> (A::set,B::set) -> proc(QP1,QP2)
 return
  `is_equal/SCP`(N)(A)(QP1[1],QP2[1]) and
  `is_equal/SCP`(N)(B)(QP1[2],QP2[2]);
end:

`is_leq/SCP` := (N::posint) -> (A::set) -> proc(Q1,Q2)
 local i;

 for i from 1 to N do
  if Q2[i] minus Q1[i] <> {} then
   return false;
  fi;
 od;

 return true;
end:

`list_elements/SCP2` := (N::posint) -> proc(A::set,B::set)
 local X,Y,Z,n,Q,P;

 X := `list_elements/SCP`(N)(A);
 Y := `list_elements/SCP`(N)(B);
 Z := NULL;

 n := nops(B);

 for Q in X do
  P := `res/SCP`(N)(A,B)(Q);

  if nops(P[N]) = n^2 then
   Z := Z,seq([Q,P],P in Y);
  else
   Z := Z,[Q,P];
  fi;
 od:

 Z := [Z];

 return Z;
end:

`random_element/SCP2` := (N::posint) -> (A::set,B::set) -> proc(p := 0.5)
 local A0,p0,a,Q0,AA,Q,P,i;
 if rand(1..10000)() < evalf(10000 * p) then
  A0 := (A minus B) union {b0};
  p0 := table();
  for a in A do
   p0[a] := `if`(member(a,B),b0,a);
  od;
  Q0 := `random_element/SCP`(N)(A0)();
  AA := `top/autorel`(A);
  Q := [seq(select(xy -> member(map(p0,xy),Q0[i]),AA),i=1..N)];
  P := `random_element/SCP`(N)(B)();
  return [Q,P];
 else
  Q := `random_element/SCP`(N)(A)();
  P := `res/SCP`(N)(A,B)(Q);

  while `is_constant/ACP`(N)(B)(P) do
   Q := `random_element/SCP`(N)(A)();
   P := `res/SCP`(N)(A,B)(Q);
  od;

  return [Q,P];
 fi;
end:


#===============================================================================
IdentifiabilityODE := proc(system_ODEs, params_to_assess, p, output_targets, count_solutions, char)#{p := 0.99, infolevel := 1, method := 2, num_nodes := 6})
#===============================================================================
 local i, j, k, n, m, s, all_params, all_vars, eqs, Q, X, Y, poly, d0, D1,
        sample, all_subs,alpha, beta, Et, x_theta_vars, prolongation_possible,
        eqs_i, JacX, vars, vars_to_add, ord_var, var_index, deg_variety, D2,
        y_hat, u_hat, theta_hat, Et_hat, Q_hat, theta_l, theta_g, gb, v, X_eq, Y_eq,
        poly_d, separant, leader, x_functions, y_functions, u_functions,
        all_symbols_rhs, mu, x_vars, y_vars, u_vars, theta, subst_first_order,
        subst_zero_order, x_eqs, y_eqs, param, other_params, to_add, at_node,
        prime, max_rank, R, tr, e, p_local, xy_ders, polys_to_process, new_to_process, method, start, finish, infolevel,
        num_nodes ,Et_x_vars, out_sian, var, G, P, solutions_table, check:

  #----------------------------------------------
  # 0. Extract inputs, outputs, states, and parameters from the system
  #----------------------------------------------
  method := 2:

  if SearchText(".", convert(system_ODEs, string)) <> 0 then
    LogText(sprintf("WARNING: It looks like your system involves floating-point numbers. This may result into a non-meaninful result, please convert them to rationals (e.g., 0.2 -> 1/5)"), "LogAreaSIAN"):
    WARNING("WARNING: It looks like your system involves floating-point numbers. This may result into a non-meaninful result, please convert them to rationals (e.g., 0.2 -> 1/5)"):
  end if:

  if not (indets(system_ODEs, name) subset indets(system_ODEs)) then
    LogText(sprintf(cat("ERROR: you are using reserved maple symbols: ", convert(indets(system_ODEs, name) minus indets(system_ODEs), string))), output_targets[log]):
    DocumentTools:-SetProperty("GlobalParams1", expression, Error(BadName)):
    DocumentTools:-SetProperty("LocalParams1", expression,  Error(BadName)):
    DocumentTools:-SetProperty("NoIDParams1", expression,  Error(BadName)):
    error (cat("ERROR: you are using reserved maple symbols: ", convert(indets(system_ODEs, name) minus indets(system_ODEs), string))):
    return;
  end if:

  randomize():
  infolevel:=1:
  num_nodes:=1:
  if infolevel > 0 then
    PrintHeader("0. Extracting states, inputs, outputs, and parameters from the system"):
  end if:
  x_functions := map(f -> int(f, t), select( f -> type(int(f, t), function(name)), map(lhs, system_ODEs) )):
  y_functions := select( f -> not type(int(f, t), function(name)), map(lhs, system_ODEs) ):
  all_symbols_rhs := foldl(`union`, op( map(e -> indets(rhs(e)), system_ODEs) )) minus {t}:
  xy_ders := {op(x_functions), op(y_functions), op(select(f -> (f in all_symbols_rhs), map(lhs, system_ODEs)))}:
  u_functions := select( f -> type(f, function), convert(all_symbols_rhs minus xy_ders, list)):
  mu := convert(all_symbols_rhs minus {op(xy_ders), op(u_functions)}, list):

  x_vars := map(FunctionToVariable, x_functions):
  y_vars := map(FunctionToVariable, y_functions):
  u_vars := map(FunctionToVariable, u_functions):
  theta := map(ParamToInner, params_to_assess):
  subst_first_order := {seq(diff(x_functions[i], t) = MakeDerivative(x_vars[i], 1), i = 1 .. nops(x_vars))}:
  subst_zero_order := {
    seq(x_functions[i] = MakeDerivative(x_vars[i], 0), i = 1 .. nops(x_vars)),
    seq(y_functions[i] = MakeDerivative(y_vars[i], 0), i = 1 .. nops(y_vars)),
    seq(u_functions[i] = MakeDerivative(u_vars[i], 0), i = 1 .. nops(u_vars))
  }:
  x_eqs := subs(subst_zero_order, subs(subst_first_order, select(e -> type(int(lhs(e), t), function(name)), system_ODEs))):
  y_eqs := subs(subst_zero_order, select(e -> not type(int(lhs(e), t), function(name)), system_ODEs)):

  # taking into account that fact that Groebner[Basis] is Monte Carlo with probability of error
  # at most 10^(-18) (for Maple 2017)
  p_local := p + nops(params_to_assess) * 10^(-18):
  if p_local >= 1 then
    LogTextSIAN("The probability of success cannot exceed 1 - #params_to_assess 10^{-18}. We reset it to 0.99");
    p_local := 0.99:
  end if:

  if infolevel > 0 then
    LogText(sprintf("\n===== Input info =====\n"), output_targets[log]):
    LogText(sprintf("%s %a\n", `State variables:         `, x_functions), output_targets[log]):
    LogText(sprintf("%s %a\n", `Output variables:        `, y_functions), output_targets[log]):
    LogText(sprintf("%s %a\n", `Input variables:         `, u_functions), output_targets[log]):
    LogText(sprintf("%s %a\n", `Parameters in equations: `, mu), output_targets[log]):
    LogText(sprintf("===================\n\n"), output_targets[log]):
  end if:

  #----------------------------------------------
  # 1. Construct the maximal system.
  #----------------------------------------------

  if infolevel > 0 then
    PrintHeader("1. Constructing the maximal polynomial system"):
  end if:

  # (a) ---------------
  n := nops(x_vars):
  m := nops(y_vars):
  s := nops(mu) + n:
  all_params := [op(mu), op(map(x -> MakeDerivative(x, 0), x_vars ))]:
  all_vars := [ op(x_vars), op(y_vars), op(u_vars) ]:
  eqs := [op(x_eqs), op(y_eqs)]:
  Q := foldl( (f, g) -> lcm(f, g), op( map(f -> denom(rhs(f)), eqs) )):

  # (b,c) ---------------
  X := []:
  X_eq := []:
  for i from 1 to n do
    X := [op(X), []]:
    poly := numer(lhs(x_eqs[i]) - rhs(x_eqs[i])):
    for j from 0 to s + 1 do
      poly_d := Differentiate(poly, all_vars, j):
      leader := MakeDerivative(x_vars[i], j + 1):
      separant := diff(poly_d, leader):
      X[i] := [op(X[i]), poly_d]:
      X_eq := [op(X_eq), leader = -(poly_d - separant * leader) / separant]:
    end do:
  end do:
  # LogExpression(X[1]);

  # (d,e) ---------------
  Y := []:
  Y_eq := []:
  for i from 1 to m do
    Y := [op(Y), []]:
    poly := numer(lhs(y_eqs[i]) - rhs(y_eqs[i])):
    for j from 0 to s + 1 do
      poly_d := Differentiate(poly, all_vars, j):
      leader := MakeDerivative(y_vars[i], j):
      separant := diff(poly_d, leader):
      Y[i] := [op(Y[i]), poly_d]:
      Y_eq := [op(Y_eq), leader = -(poly_d - separant * leader) / separant]:
    end do:
  end do:

  #----------------------------------------------
  # 2. Truncate.
  #----------------------------------------------

  if infolevel > 0 then
    PrintHeader("2. Truncating the polynomial system based on the Jacobian condition"):
  end if:

  # (a) ---------------
  d0 := max(op( map(f -> degree( simplify(Q * rhs(f)) ), eqs) ), degree(Q)):

  # (b) ---------------
  # extra factor nops(theta) + 1 compared to the formula in the paper is to
  # provide probability gaurantee to the local identifiability test
  D1 := floor( (nops(theta) + 1) * 2 * d0 * s * (n + 1) * (1 + 2 * d0 * s) / (1 - p_local) ):
  # prime := nextprime(D1):
  if infolevel > 1 then
    LogText(sprintf("%s %a\n", `Bound D_1 for testing the rank of the Jacobian probabilistically: `, D1), output_targets[log]);
  end if:

  # (c, d) ---------------
  sample := SamplePoint(D1, x_vars, y_vars, u_vars, mu, X_eq, Y_eq, Q):
  all_subs := sample[4]:
  u_hat := sample[2]:
  y_hat := sample[1]:

  # (e) ------------------
  alpha := [seq(1, i = 1..n)]:
  beta := [seq(0, i = 1..m)]:
  Et := [];
  # TODO: improve for arbitrary derivatives
  x_theta_vars := all_params:
  prolongation_possible := [seq(1, i = 1..m)]:

  # (f) ------------------
  while add(prolongation_possible) > 0 do
    for i from 1 to m do
      if prolongation_possible[i] = 1 then
        eqs_i := [op(Et), Y[i][beta[i] + 1]]:
        JacX := VectorCalculus[Jacobian](subs({op(u_hat), op(y_hat)}, eqs_i), x_theta_vars = subs(all_subs, x_theta_vars)):
        if LinearAlgebra[Rank](JacX) = nops(eqs_i) then
          Et := [op(Et), Y[i][beta[i] + 1]]:
          beta[i] := beta[i] + 1:
          # adding necessary X-equations
          polys_to_process := [op(Et), seq(Y[k][beta[k] + 1], k=1..m)]:
          while nops(polys_to_process) <> 0 do
            new_to_process := []:
            vars := {};
            for poly in polys_to_process do
              vars := vars union { op(GetVars(poly, x_vars)) }:
            end do:
            vars_to_add := { op(remove(v -> evalb(v in x_theta_vars), vars)) };
            for v in vars_to_add do
              x_theta_vars := [op(x_theta_vars), v];
              ord_var := GetOrderVar(v);
              var_index := ListTools[Search](ord_var[1], x_vars):
              poly := X[ var_index ][ ord_var[2] ]:
              Et := [op(Et), poly]:
              new_to_process := [op(new_to_process), poly]:
              alpha[ var_index ] := max(alpha[ var_index ], ord_var[2] + 1):
            end do:
            polys_to_process := new_to_process:
          end do:
        else
          prolongation_possible[i] := 0;
        end if:
      end if:
    end do:
  end do:
  # is used for assessing local identifiabilty
  max_rank := nops(Et):

  # (g) --------------
  for i from 1 to m do
    for j from beta[i] + 1 to nops(Y[i]) do
      to_add := true:
      for v in GetVars(Y[i][j], x_vars) do
        if not (v in x_theta_vars) then
          to_add := false:
        end if:
      end do:
      if to_add = true then
        beta[i] := beta[i] + 1:
        Et := [op(Et), Y[i][j]]:
      end if:
    end do:
  end do:

  if infolevel > 1 then
    LogText(sprintf("%s %a\n", `Orders of prolongations of the outputs (beta) = `, beta), output_targets[log]):
    LogText(sprintf("%s %a\n", `Orders of prolongations of the state variables (alpha) = `, alpha), output_targets[log]):
  end if:
  ##############################

  if infolevel > 0 then
    PrintHeader("3. Assessing local identifiability"):
  end if:

  theta_l := []:
  for param in theta do
    other_params := subs(param = NULL, x_theta_vars):
    JacX := VectorCalculus[Jacobian](
        subs( { op(u_hat), param = subs(all_subs, param), op(y_hat) }, Et),
        other_params = subs(all_subs, other_params)
    ):
    if LinearAlgebra[Rank](JacX) <> max_rank then
      theta_l := [op(theta_l), param]:
    end if:
  end do:
  DocumentTools:-SetProperty("LocalLabel" , caption, "Locally Identifiable Paramters");
  if infolevel > 1 then
    LogText(sprintf("%s %a\n", `Locally identifiable paramters: `, map(x -> ParamToOuter(x, all_vars), theta_l)), output_targets[log]);
    LogText(sprintf("%s %a\n", `Nonidentifiable parameter: `, map(x -> ParamToOuter(x, all_vars), [op({op(theta)} minus {op(theta_l)})])), output_targets[log]);
  end if:

  DocumentTools:-SetProperty(output_targets[localparams], expression, map(x -> ParamToOuter(x, all_vars), theta_l), 'refresh'): # local
  DocumentTools:-SetProperty(output_targets[noidparams], expression, map(x -> ParamToOuter(x, all_vars), [op({op(theta)} minus {op(theta_l)})]), 'refresh'): # no id

  #----------------------------------------------
  # 3. Randomize.
  #----------------------------------------------

  if infolevel > 0 then
    PrintHeader("4. Randomizing the truncated system"):
  end if:

  # (a) ------------
  deg_variety := foldl(`*`, op( map(e -> degree(e), Et) )):
  D2 := floor( 6 * nops(theta_l) * deg_variety * (1 + 2 * d0 * max(op(beta))) / (1 - p_local) ):
  if infolevel > 1 then
    LogText(sprintf("%s %a\n", `Bound D_2 for assessing global identifiability: `, D2), output_targets[log]):
  end if:

  # (b, c) ---------
  sample := SamplePoint(D2, x_vars, y_vars, u_vars, mu, X_eq, Y_eq, Q):
  y_hat := sample[1]:
  u_hat := sample[2]:
  theta_hat := sample[3]:
  if infolevel > 1 then
    LogText(sprintf("%s %a\n", `Random sample for the outputs and inputs is generated from `, theta_hat), output_targets[log]):
  end if:

  # (d) ------------
  Et_hat := map(e -> subs([op(y_hat), op(u_hat)], e), Et):
  Et_x_vars := {}:
  for poly in Et_hat do
    Et_x_vars := Et_x_vars union { op(GetVars(poly, x_vars)) }:
  end do:
  if infolevel > 1 then
    LogText(sprintf("%s %a %s %a %s\n", "The polynomial system contains", nops(Et_hat), "equations in ", nops(Et_x_vars) + nops(mu), " variables"), output_targets[log]);
  end if:
  Q_hat := subs(u_hat, Q):

  vars := [
    op(sort([op(Et_x_vars)], (a, b) -> CompareDiffVar(a, b, x_vars))),
    z_aux, w_aux,
    op(sort(mu))
  ]:
  if infolevel > 1 then
    LogText(sprintf("Variable ordering to be used for Groebner basis computation %a\n", vars), output_targets[log]);
  end if:

  #----------------------------------------------
  # 4. Determine.
  #----------------------------------------------

  if infolevel > 0 then
    PrintHeader("5. Assessing global identifiability"):
  end if:
  theta_g := []:
  if method = 1 then
    at_node := proc(var, args_node)
      local gb_loc, fname;
      gb_loc := Groebner[Basis](op(args_node)):
      gb_loc;
    end proc:

    if nops(theta_l) > 1 and num_nodes > 1 then
      Grid[Setup]("local", numnodes = num_nodes):
      Grid[Set](at_node):
      gb := Grid[Seq](
        at_node(theta_l[i], [
          [op(Et_hat), z_aux * Q_hat - 1, (theta_l[i] - subs(theta_hat, theta_l[i])) * w_aux - 1],
          tdeg(vars)
        ]),
        i = 1..nops(theta_l)
      ):
    else
      gb := []:
      for i from 1 to nops(theta_l) do
        gb := [
          op(gb),
          at_node(
            theta_l[i],
            [[op(Et_hat), z_aux * Q_hat - 1, (theta_l[i] - subs(theta_hat, theta_l[i])) * w_aux - 1], tdeg(op(vars))]
           )
        ]:
      end do:
    end if:
    for i from 1 to nops(theta_l) do
      if gb[i] = [1] then
        theta_g := [op(theta_g), theta_l[i]]:
      else
        if infolevel > 1 then
          LogText(sprintf("%s %a %s %a\n", `Groebner basis corresponding to the parameter `, theta_l[i], ` is `, gb[i]), output_targets[log]):
        end if:
      end if:
    end do:
  elif method = 2 then
     LogText(sprintf("%s %a\n", `Computing Groebner Basis with characteristic`, char), output_targets[log]):
    	gb := Groebner[Basis]([op(Et_hat), z_aux * Q_hat - 1], tdeg(op(vars)), characteristic=char);
     for i from 1 to nops(theta_l) do
       if char>0 then
       	check := subs(theta_hat, theta_l[i]) mod char:
       else
       	check := subs(theta_hat, theta_l[i]):
       end if:
       if Groebner[NormalForm](theta_l[i], gb, tdeg(op(vars)), characteristic=char) = check then
         theta_g := [ op(theta_g), theta_l[i] ]:
       end if:
     end do:

    if count_solutions then
     LogParameters("",output_targets[parameters]):
    	for var in theta_g do
 		LogText(sprintf("%s %a, %s %a\n",`The number of solutions for`, var, `is`, 1), output_targets[log]):
		LogParameters(sprintf("%s %a, %s %a\n",`Parameter`, ParamToOuter(var, all_vars), `number of solutions:`, 1), output_targets[parameters]):
		solutions_table[var]:=1:
    	end do:

    	for var in select(p -> not p in theta_g, theta_l) do
		G := Groebner[Walk](gb, tdeg(op(vars)), lexdeg([op({op(vars)} minus {var})], [var]), characteristic=char):
		P := select(x->evalb(indets(x)={var}), G):
		solutions_table[var]:=degree(P[1], [op(indets(P))]):
		LogText(sprintf("%s %a, %s %a\n",`The number of solutions for`, var, `is`, degree(P[1], [op(indets(P))])), output_targets[log]):
		LogParameters(sprintf("%s %a, %s %a\n",`Parameter`, ParamToOuter(var, all_vars), `number of solutions:`, degree(P[1], [op(indets(P))])),  output_targets[parameters])
    	end do:
     fi:
    	DocumentTools:-SetProperty(output_targets[globalparams], value,  [op(map(x -> ParamToOuter(x, all_vars), theta_g))], 'refresh'): # global
    	DocumentTools:-SetProperty(output_targets[localparams], value,  [op(map(x -> ParamToOuter(x, all_vars), select(p -> not p in theta_g, theta_l)))], 'refresh'): # global
  else
    LogText(sprintf(`No such method`), output_targets[log]):
    LogText(sprintf("%q\n", "Provided method: %d, allowed methods: 1, 2", method), output_targets[log]):
  end if:

  if infolevel > 0 then
    LogText(sprintf("\n=== Summary ===\n"), output_targets[log]):
    LogText(sprintf("%s %a\n", `Globally identifiable parameters:                 `, map(x -> ParamToOuter(x, all_vars), theta_g)), output_targets[log]):
    LogText(sprintf("%s %a\n", `Locally but not globally identifiable parameters: `, map(x -> ParamToOuter(x, all_vars), select(p -> not p in theta_g, theta_l))), output_targets[log]):
    LogText(sprintf("%s %a\n", `Not identifiable parameters:                      `, map(x -> ParamToOuter(x, all_vars), select(p -> not p in theta_l, theta))), output_targets[log]):
    LogText(sprintf("===============\n\n"), output_targets[log]):
  end if:
   DocumentTools:-SetProperty("LocalLabel" , caption, "Locally but not Globally Identifiable Paramters");
  out_sian := table([
    globally = [op(map(x -> ParamToOuter(x, all_vars), theta_g))],
    locally_not_globally = {op(map(x -> ParamToOuter(x, all_vars), select(p -> not p in theta_g, theta_l)))},
    non_identifiable = {op(map(x -> ParamToOuter(x, all_vars), select(p -> not p in theta_l, theta)))},
    parameters = mu,
    basis=gb,
    varordering=tdeg(op(vars)),
    allvars=vars,
    for_outer=all_vars
  ]):
  PrintHeader("WARNING: The result of solution counting is guaranteed with high probability, however it NOT the same probability 'p' as provided in the input."):
  out_sian[num_solutions] := solutions_table:
  return out_sian;
end proc:

#===============================================================================
PrintHeader := proc(text):
#===============================================================================
  LogText(sprintf("\n=======================================================\n"), "LogAreaSIAN"):
  LogText(sprintf(text), "LogAreaSIAN"):
  LogText(sprintf("\n=======================================================\n"), "LogAreaSIAN"):
end proc:

#===============================================================================
GetParameters := proc(system_ODEs, initial_conditions) local initial_values, all_symbols_rhs, mu:
#===============================================================================
  initial_values := map(f -> subs({t = 0}, int(f, t)), select( f -> type(int(f, t), function(name)), map(lhs, system_ODEs) )):
  all_symbols_rhs := foldl(`union`, op( map(e -> indets(rhs(e)), system_ODEs) )) minus {t}:
  mu := select(s -> not type(s, function), all_symbols_rhs):
  if initial_conditions then
    return [op(mu), op(initial_values)]:
  else
    return [op(mu)]:
  end if:
end proc:

#===============================================================================
FunctionToVariable := proc(f):
#===============================================================================
  convert(cat(convert(f, string)[1..-4], "_"), symbol):
end proc:

#===============================================================================
ParamToInner := proc(p) local s:
#===============================================================================
  s := convert(p, string):
  if length(s) > 3 and s[-3..-1] = "(0)" then
    MakeDerivative(FunctionToVariable(p), 0):
  else
    p:
  end if:
end proc:

#===============================================================================
ParamToOuter := proc(p, varnames) local s:
#===============================================================================
  s := convert(p, string):
  if length(s) > 2 and s[-2..-1] = "_0" and parse(s[1..-2] )in varnames then
    parse(cat(s[1..-3], "(0)")):
  else
    p:
  end if:
end proc:

#===============================================================================
MakeDerivative := proc(var_name, der_order):
#===============================================================================
  cat(var_name, der_order):
end proc:

#===============================================================================
DifferentiateOnce := proc(diff_poly, var_list)
#===============================================================================
  local result, aux, v, h, diff_v:
  result := 0:
  for diff_v in indets(diff_poly) do
    aux := GetOrderVar(diff_v):
    # seems that Maple does not have unpacking
    v := aux[1]:
    h := aux[2]:
    if v in var_list then
      result := result + diff(diff_poly, MakeDerivative(v, h)) * MakeDerivative(v, h + 1):
    end if:
  end do:
  simplify(result):
end proc:

#===============================================================================
Differentiate := proc(diff_poly, var_list, ord := 1)
#===============================================================================
  local result, i;
  result := diff_poly:
  for i from 1 to ord do
    result := DifferentiateOnce(result, var_list):
  end do:
  result:
end proc:

#===============================================================================
GetVars := proc(diff_poly, var_list)
#===============================================================================
  local result;
  result := select(v -> evalb(GetOrderVar(v)[1] in var_list), indets(diff_poly)):
  return result:
end proc:

#===============================================================================
GetOrderVar := proc(diff_var)
#===============================================================================
  local s, v, h;
  if not StringTools[RegMatch]("^(.*_)([0-9]+)$", diff_var, s, v, h) then
    return ["", ""]:
  end if:
  return [parse(v), parse(h)]:
end proc:

#===============================================================================
SamplePoint := proc(bound, x_vars, y_vars, u_vars, mu, X_eq, Y_eq, Q)
#===============================================================================
  local n, m, s, all_params, all_vars, theta_hat, u_variables,
        u_hat, x_hat, y_hat, eq, eq_num, eq_denom,
        v, poly, i, j, all_subs, roll, to_compute;
  n := nops(x_vars):
  m := nops(y_vars):
  s := nops(mu) + n:
  all_params := [op(mu), op(map(x -> MakeDerivative(x, 0), x_vars ))]:
  all_vars := [ op(x_vars), op(y_vars), op(u_vars) ]:

  roll := rand(0 .. bound):
  while true do
    theta_hat := map(p -> p = roll(), all_params):
    u_variables := [];
    for i from 1 to nops(u_vars) do
      u_variables := [ op(u_variables), seq(MakeDerivative(u_vars[i], j), j = 0..s + 1) ]:
    end do:
    u_hat := map(p -> p = roll(), u_variables) :

    all_subs := [op(theta_hat), op(u_hat)]:
    if subs(all_subs, Q) = 0 then
      next
    end if:
    to_compute := [op(X_eq), op(Y_eq)]:
    while nops(to_compute) <> 0 do
      to_compute := map(e -> lhs(e) = subs(all_subs, rhs(e)), to_compute);
      all_subs := [ op(all_subs), op(select(e -> type(rhs(e), numeric), to_compute)) ]:
      to_compute := remove(e -> type(rhs(e), numeric), to_compute):
    end do:
    y_hat := map(e -> lhs(e) = subs(all_subs, rhs(e)), Y_eq):
    x_hat := map(e -> lhs(e) = subs(all_subs, rhs(e)), X_eq):
    break:
  end do:

  return [y_hat, u_hat, theta_hat, all_subs];
end proc:

#===============================================================================
GenerateReplica := proc(equations, r)
#===============================================================================
  # generates a system of equations corresponding to r independent trajectories of
  # the original system. Time-dependent variabes are replicated, parameters are not
  local all_functions, zero_order, first_order, funcs, without_t, result, i, subst:
  all_functions := select(f -> type(f, function), foldl(`union`, op( map(indets, equations) ))):
  zero_order := select(f -> not type(int(f, t), function(name)), all_functions):
  first_order := map(f -> int(f, t), select(f -> type(int(f, t), function(name)), all_functions)):
  funcs := {op(zero_order), op(first_order)}:
  without_t := map(f -> convert(convert(f, string)[1..-4], symbol), funcs):
  result := []:
  for i from 1 to r do
    subst := map(f -> f = convert(cat(convert(f, string), "_r", i), symbol), without_t):
    result := [op(result), op(map(e -> subs(subst, e), equations))]:
  end do:
  return result:
end proc:

#===============================================================================
CompareDiffVar := proc(dvl, dvr, var_list)
#===============================================================================
  local vl, vr, hl, hr;
  vl, hl := op(GetOrderVar(dvl, var_list)):
  vr, hr := op(GetOrderVar(dvr, var_list)):
  if evalb(hl <> hr) then
    return evalb(hl > hr):
  end if:
  if evalb(length(vl) <> length(vr)) then
    return evalb(length(vl) > length(vr)):
  end if:
  return StringTools[Compare](vr, vl):
end proc: