(*
 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 "op.mpl"

(* Xalpha *)
op_qab         := 2.5654:
op_enhancement := xs -> 1:


`is_element/cacti` := (A::set) -> proc(C)
 global reason;
 local tag,n,i,j,a,b,U;

 tag := "is_element/cacti";

 if not(is_table_on(A)(C)) then
  reason := [tag,"C is not a table indexed by A",C,A];
  return false;
 fi;

 for a in A do
  if not(`is_element/cactus_lobes`(C[a])) then
   reason := [tag,"C[a] is not a cactus lobe",a,C[a],reason];
   return false;
  fi;
 od;

 n := nops(A);
 for i from 1 to n do
  for j from i+1 to n do
   a := A[i];
   b := A[j];
   if `are_crossed/RZ_set`(C[a][2],C[b][2]) then
    reason := [tag,"lobes C[a] and C[b] are crossed",a,b,C[a],C[b]];
    return false;
   fi;
  od;
 od;

 U := `empty/RZ_set`;
 for a in A do
  U := `union/RZ_set`(U,C[a][2]);
 od;

 if U <> `top/RZ_set` then
  reason := [tag,"The lobes do not fill the whole circle",C,U];
  return false;
 fi;

 return true;
end:

`is_equal/cacti` := (A::set) -> proc(C0,C1)
 local a;
 `and`(seq(evalb(C0[a]=C1[a]),a in A));
end:

`is_leq/cacti` := NULL:

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

`random_element/cacti` := (A) -> proc()
 local J,s,s1,n,l,m,c,T,i,j,a,C;

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

 J,s := op(`random_element/cactus_planar_trees`(A)());

 if nops(A) = 1 then
  return table([op(A) = `id/cactus_lobes`]);
 fi;

 s1 := map(e -> e[1],s);
 n := nops(s1);
 l := [seq(rand(1..6)(),i=1..n)];
 l := l /~ `+`(op(l));
 m := [seq(add(l[i],i=1..j),j=0..n)];
 c := table([seq(a = `random_element/RZ`(),a in A)]);
 T := table([seq(a = [],a in A)]):
 for i from 1 to n do
  T[s1[i]] := [op(T[s1[i]]),m[i],m[i+1]];
 od:
 C := table():
 for a in A do C[a] := [c[a],T[a]]; od:
 C := `source_shift/cacti`(A)(`random_element/RZ`())(C):
 return eval(C);
end:

`list_elements/cacti` := NULL:
`count_elements/cacti` := NULL:

######################################################################
# Here t should be in R/Z

`source_shift/cacti` := (A::set) -> (t) -> proc(C)
 local D,a;

 D := table():
 for a in A do
  D[a] := `source_shift/cactus_lobes`(t)(C[a]);
 od:
 return eval(D);
end:

######################################################################
# Here t should be a table with indices A and entries in R/Z

`target_shift/cacti` := (A::set) -> (t) -> proc(C)
 local D,a;

 D := table():
 for a in A do
  D[a] := `target_shift/cactus_lobes`(t[a])(C[a]);
 od:
 return eval(D);
end:

######################################################################
# The standard basepoint for the space of cacti on {1,..,n}

`basepoint/cacti` := proc(n::posint)
 local i,C;
 C := table():
 for i from 1 to n do
  C[i] := [0,[(i-1)/n,i/n]];
 od:
 return eval(C);
end:

######################################################################
# A path in the space of cacti on {1,..,n}, from the basepoint to
# its image under the transposition (m,m+1).

`omega/cacti` := (n::posint) -> (m::posint) -> proc(t)
 local A,C,i,k;
 if m >= n then error("m is out of range"); fi;
 A := {seq(i,i=1..n)};
 C := table():
 for k from 1 to n do
  if k = m then
   C[k] := [0,[m-1+t,m+t] /~ n]
  elif k = m+1 then
   if t = 0 then
    C[k] := [0,[m,m+1] /~ n];
   elif t = 1 then
    C[k] := [0,[m-1,m] /~ n];
   else
    C[k] := [0,[m-1,m-1+t,m+t,m+1] /~ n];
   fi;
  else
   C[k] := [0,[k-1,k] /~ n];
  fi;
 od:
 return eval(C);
end:

######################################################################
# A family of paths in the space of cacti on {1,2,3}

`alpha/cacti` := proc(i,t)
 local L,C;
 if t < 0 or t > 1 then
  error("t out of range");
 fi;
 if t = 0 then
  L := [[1,2] /~ 3,[0,1] /~ 3,[2,3] /~ 3];
 elif t = 1 then
  L := [[0,1] /~ 3,[1,2] /~ 3,[2,3] /~ 3];
 else
  L := [[0,t,1+t,2] /~ 3,[t,1+t] /~ 3,[2,3] /~ 3];
 fi;
 L := map(u -> [0,u],L);
 C := table():
 if i = 1 then
  C[1] := L[1]; C[2] := L[2]; C[3] := L[3];
 elif i = 2 then
  C[1] := L[3]; C[2] := L[1]; C[3] := L[2];
 elif i = 3 then
  C[1] := L[2]; C[2] := L[3]; C[3] := L[1];
 else
  error("i out of range");
 fi;
 return eval(C);
end:

######################################################################
# A family of paths in the space of cacti on {1,2,3}

`beta/cacti` := proc(z,i,t)
 local C,w;

 C := `alpha/cacti`(i,t);
 if i = 1 then
  w := z;
 elif i = 2 then
  w := z - (1+t)/3;
 elif i = 3 then
  w := z + (1+t)/3;
 else
  error("i is out of range");
 fi;

 return `source_shift/cacti`({1,2,3})(w)(C);
end:

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

`planar_tree/cacti` := (A::set) -> proc(C)
 local S,SI,D,E,E0,E1,EI,J,t0,t1,t,j,jt,u,v,a,ok,s;

 S := table():
 D := table():
 SI := table():

 for a in A do
  S[a] := `starts/RZ_set`(C[a][2]);
  D[a] := `boundary/RZ_set`(C[a][2]);
  for t in S[a] do SI[t] := a; od;
 od:

 E1 := map(op,{seq(S[a],a in A)});
 E1 := sort([op(E1)]);

 J := {};
 E0 := E1;
 EI := table():
 while E0 <> [] do
  t0 := E0[1];
  jt := {t0};
  j := {SI[t0]};
  for t1 in [op(2..-1,E0)] do
   u := `interval/RZ_set`(t0,t1);
   v := `interval/RZ_set`(t1,t0);
   ok := true;
   for a in A do
    if not (`intersect/RZ_set`(u,C[a][2]) = `empty/RZ_set` or
            `intersect/RZ_set`(v,C[a][2]) = `empty/RZ_set`) then
     ok := false;
     break;
    fi;
   od;
   if ok then
    jt := {op(jt),t1};
    j := {op(j),SI[t1]};
   fi;
  od:
  J := {op(J),j};
  E0 := select(t -> not(member(t,jt)),E0);
  for t in jt do EI[t] := [SI[t],j]; od;
 od:

 s := [seq(EI[t],t in E1)];
 return [J,s];
end:

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

# This computes the matrix x as in lem-cactus-x

`x/cacti` := (A::set) -> proc(C)
 local x,a,a1;

 x := table();
 for a1 in A do
  for a in A do
   if a1 <> a then
    x[a,a1] := `eval/cactus_lobes`(C[a])(C[a1][2][1]);
   fi;
  od:
 od:

 return eval(x);
end:

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

`eta/cacti` := (A::set) ->
 `if`(nops(A) = 1,table([op(A) = `id/cactus_lobes`]),FAIL):

`gamma/cacti` := (A::set,B::set) -> (p) -> proc(D,C)
 local a,E;

 E := table():
 for a in A do
  E[a] := `o/cactus_lobes`(C[p[a]][a],D[p[a]]);
 od:
 return eval(E);
end:

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

`phi/ord_simplex_interior/cacti` := (A::set) -> proc(Rx)
 local R,x,n,C,y,i,j;
 R,x := op(Rx);
 n := nops(R);
 C := table():
 y := [seq(add(x[R[i]],i=1..j),j=0..n)];
 for i from 1 to n do
  C[R[i]] := [0,[y[i],y[i+1]]];
 od:
 return eval(C);
end:

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

`phi/cacti/simplex_interior` := (A::set) -> proc(C)
 local x,a;
 x := table();
 for a in A do
  x[a] := `length/RZ_set`(C[a][2]);
 od:
 return eval(x):
end:

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

`plot/cacti` := (A::set) -> proc(C,r := 1,c := [0,0])
 local n,z,i;
 n := nops(A);
 z := table([seq(i = `centroid_R2/RZ_set`(C[A[i]][2]),i=1..n)]);
 display(
  seq(`plot/RZ_set`(C[A[i]][2],r,c,colour=standard_colour(i)),i=1..n),
  seq(point(z[i],colour=standard_colour(i)),i=1..n)
 );
end:


function compare(a, b)
    if islist(a) and islist(b) then
        if size(a) != size(b) then
	    return 0
	end
	for i in 0:size(a)-1
	    if compare(a[i], b[i]) == 0 then
	        return 0
	    end
	    i = i + 1
	end
	return 1
    end
    return a == b
end

function error(a, b, s)
    "error " + s
    a
    b
    a-b
    exit(1)
end

function test(a, b, s)
    if not compare(a, b) then
        error(a, b, s)
    end
end

function test_addition()
    a = { 5, 1, (2,3), (1,2), [1,2,3], [1,2], [(1,2),(3,4)], \
          [(1,2),(3,4)], \
	  [1,2|3,4], [1,2|3,4], [(1,2),(3,4)|(5,6),(7,8)], \
	  [(1,2),(3,4)|(5,6),(7,8)], "abc" }
    b = { 3, (2,3), 1, (3,4), [4,5,6], [(1,2),(3,4)], [1,2], [(5,6),(7,8)], \
          [5,6|7,8], [(1,2),(3,4)|(5,6),(7,8)], [1,2|3,4], \
	  [(8,7),(6,5)|(4,3),(2,1)], "def" }
    q = { 8, (3,3), (3,3), (4,6), [5,7,9], [(2,2),(5,4)], [(2,2),(5,4)], [(6,8),(10,12)], \
          [6,8|10,12], [(2,2),(5,4)|(8,6),(11,8)], [(2,2),(5,4)|(8,6),(11,8)], \
	  [(9,9),(9,9)|(9,9),(9,9)], "abcdef" }
    s = { "real + real", "real + complex", "complex + real", \
          "complex + complex", "vector + vector", "vector + cvector", \
	  "cvector + vector", "cvector + cvector", \
	  "matrix + matrix", "matrix + cmatrix", "cmatrix + matrix", \
	  "cmatrix + cmatrix", "string + string" }
    c = a + b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
        i = i + 1
    end
end

function test_subtraction()
    a = { 5, 1, (2,3), (1,2), [4,5,6], [1,2], [(1,2),(3,4)], [(1,2),(3,4)], \
          [5,6|7,8], [1,2|3,4], [(1,2),(3,4)|(5,6),(7,8)], \
	  [(8,7),(6,5)|(4,3),(2,1)], "abc" }
    b = { 3, (2,3), 1, (3,4), [1,2,3], [(1,2),(3,4)], [1,2], [(5,6),(7,8)], \
          [1,2|3,4], [(1,2),(3,4)|(5,6),(7,8)], [1,2|3,4], \
	  [(1,2),(3,4)|(5,6),(7,8)], "def" }
    x = { 2, (-1,-3), (1,3), (-2,-2), [3,3,3], [(0,-2),(-1,-4)], \
          [(0,2),(1,4)], [(-4,-4),(-4,-4)], \
	  [4,4|4,4], [(0,-2),(-1,-4)|(-2,-6),(-3,-8)], \
	  [(0,2),(1,4)|(2,6),(3,8)], [(7,5),(3,1)|(-1,-3),(-5,-7)], "abcfed" }
    s = { "real - real", "real - complex", "complex - real", \
          "complex - complex", "vector - vector", "vector - cvector", \
	  "cvector - vector", "cvector - cvector", \
	  "matrix - matrix", "matrix - cmatrix", "cmatrix - matrix", \
	  "cmatrix - cmatrix", "string - string" }
    c = a - b
    for i in 0:size(a)-1
        test(x[i], c[i], s[i])
        i = i + 1
    end
end

function test_multiplication()
    a = { 5,                  2,                  (2,3),            (1,2), \
          2,                  [1,2,3],            [1,2,3], \
	  2,                  (1,2),              (1,2), \
	  [(1,2),(3,4)],      [1,2],              [(1,2),(3,4)], \
	  [1,2],              [(1,2),(3,4)],      [(1,2),(3,4)], \
	  2,                  [1,2|3,4],          [1,2|3,4], \
	  [1,2|3,4],          (1,2),              2, \
	  (1,2),              [1,2|3,4],          [(1,2),(3,4)|(5,6),(7,8)], \
	  [(1,2),(3,4)|(5,6),(7,8)],              [(1,2),(3,4)|(5,6),(7,8)], \
	  [1,2|3,4],          [(1,2),(3,4)|(5,6),(7,8)], \
	  [(1,2),(3,4)|(5,6),(7,8)],              [1,2|3,4], \
	  [(1,2),(3,4)|(5,6),(7,8)], \
	  2,                  "abc" }

    b = { 3,                  (2,3),              2,                (3,4), \
          [1,2,3],            2,                  [2,3,4], \
          [(1,2),(3,4)],      [1,2],              [(1,2),(3,4)], \
	  2,                  (1,2),              (1,2), \
	  [(1,2),(3,4)],      [1,2],              [(4,3),(2,1)], \
	  [1,2|3,4],          2,                  [1,2], \
	  [1,3|2,4],          [1,2|3,4],          [(1,2),(3,4)|(5,6),(7,8)], \
	  [(1,2),(3,4)|(5,6),(7,8)], (1,2),       [1,2], \
	  2,                  (1,2), \
	  [(1,2),(3,4)],      [(1,2),(3,4)], \
	  [1,2|3,4],          [(1,2),(3,4)|(5,6),(7,8)], \
	  [(8,7),(6,5)|(4,3),(2,1)], \
	  "abc",              2 }

    q = { 15,                 (4,6),              (4,6),            (-5,10), \
          [2,4,6],            [2,4,6],            20, \
          [(2,4),(6,8)],      [(1,2),(2,4)],      [(-3,4),(-5,10)], \
	  [(2,4),(6,8)],      [(1,2),(2,4)],      [(-3,4),(-5,10)], \
	  (7,-10),            (7,10),             (20,10), \
	  [2,4|6,8],          [2,4|6,8],          [5,11], \
	  [5,11|11,25],       [(1,2),(2,4)|(3,6),(4,8)], [(2,4),(6,8)|(10,12),(14,16)], \
	  [(-3,4),(-5,10)|(-7,16),(-9,22)], [(1,2),(2,4)|(3,6),(4,8)], [(7,10),(19,22)], \
	  [(2,4),(6,8)|(10,12),(14,16)], [(-3,4),(-5,10)|(-7,16),(-9,22)], \
	  [(7,10),(15,22)],   [(-10,28),(-18,68)], \
	  [(10,14),(14,20)|(26,30),(38,44)], [(11,14),(17,20)|(23,30),(37,44)], \
	  [(-6,48),(-2,28)|(2,136),(6,84)], \
	  "abcabc",           "abcabc" }

    s = { "real * real",      "real * complex",   "complex * real", "complex * complex", \
          "real * vector",    "vector * real",    "vector * vector", \
	  "real * cvector",   "complex * vector", "complex * cvector", \
	  "cvector * real",   "vector * complex", "cvector * complex", \
	  "vector * cvector", "cvector * vector", "cvector * cvector", \
	  "real * matrix",    "matrix * real",    "matrix * vector", \
	  "matrix * matrix",  "complex * matrix", "real * cmatrix", \
	  "complex * cmatrix", "matrix * complex", "matrix * complex", \
	  "cmatrix * real",   "cmatrix * complex", \
	  "matrix * cvector", "cmatrix * cvector", \
	  "cmatrix * matrix", "matrix * cmatrix", \
	  "cmatrix * cmatrix", \
	  "real * string",    "string * real" }
    c = a*b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
        i = i + 1
    end
end

function test_pointwise_multiplication()
    a = { [1,2,3], [1,2,3], [(1,2),(3,4),(5,6)], [(1,2),(3,4)], \
          [1,2|3,4], [1,2|3,4], [(1,2),(3,4)|(5,6),(7,8)], \
	  [(1,2),(3,4)|(5,6),(7,8)] }

    b = { [4,5,6], [(4,5),(6,7),(8,9)],[7,8,9], [(5,6),(7,8)], \
          [5,6|7,8], [(1,2),(3,4)|(5,6),(7,8)], [1,2|3,4], \
	  [(1,2),(3,4)|(5,6),(7,8)] }

    q = { [4,10,18], [(4,5),(12,14),(24,27)], \
          [(7,14),(24,32),(45,54)], [(-7,16),(-11,52)], \
	  [5,12|21,32], [(1,2),(6,8)|(15,18),(28,32)], \
	  [(1,2),(6,8)|(15,18),(28,32)], \
	  [(-3,4),(-7,24)|(-11,60),(-15,112)] }

    s = { "vector .* vector", "vector .* cvector", "cvector .* vector", \
          "cvector .* cvector", "matrix .* matrix", "matrix .* cmatrix", \
	  "cmatrix .* matrix", "cmatrix .* cmatrix" }

    c = a.*b

    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_division()
    a = { 6, 13, (4,6), (-5,10), [2,4,6], [1,2], [(1,2),(3,4)], \
          [(1,2),(3,4)], [2,4|6,8], [1,2|3,4], \
	  [(1,2),(3,4)|(5,6),(7,8)], [(1,2),(3,4)|(5,6),(7,8)] }
    b = { 2, (2,-3), 2, (3,4), 2, (1,2), 2, (1,2), 2, (1,2), 2, (1,2) }
    q = { 3, (2,3), (2,3), (1,2), [1,2,3], [(0.2,-0.4),(0.4,-0.8)], \
          [(0.5,1),(1.5,2)], [(1,0),(2.2,-0.4)], [1,2|3,4], \
	  [(0.2,-0.4),(0.4,-0.8)|(0.6,-1.2),(0.8,-1.6)], \
	  [(0.5,1),(1.5,2)|(2.5,3),(3.5,4)], \
	  [(1,0),(2.2,-0.4)|(3.4,-0.8),(4.6,-1.2)] }
    s = { "real / real", "real / complex", "complex / real", \
          "complex / complex", "vector / real", "vector / complex", \
	  "cvector / real", "cvector / complex", "matrix / real", \
	  "matrix / complex", "cmatrix / real", "cmatrix / complex" }
    c = a/b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
        i = i + 1
    end
end

function test_pointwise_division()
    a = { [4,10,18], [5,25,100], \
          [(7,14),(24,32),(45,54)], [(11,52),(-11,52)], \
	  [5,12|21,32], [5,25|100,113], \
	  [(1,2),(6,8)|(15,18),(28,32)], \
	  [(-3,4),(-7,24)|(11,52),(-15,112)] }

    b = { [4,5,6], [(1,2),(3,4),(6,8)], [7,8,9], [(8,7),(7,8)], \
          [5,6|7,8], [(1,2),(3,4)|(6,8),(7,8)], [1,2|3,4], \
	  [(1,2),(3,4)|(8,7),(7,8)] }

    q = { [1,2,3], [(1,-2),(3,-4),(6,-8)], [(1,2),(3,4),(5,6)], [(4,3),(3,4)], \
          [1,2|3,4], [(1,-2),(3,-4)|(6,-8),(7,-8)], [(1,2),(3,4)|(5,6),(7,8)], \
	  [(1,2),(3,4)|(4,3),(7,8)] }

    c = a./b

     s = { "vector ./ vector", "vector ./ cvector", "cvector ./ vector", \
          "cvector ./ cvector", "matrix ./ matrix", "matrix ./ cmatrix", \
	  "cmatrix ./ matrix", "cmatrix ./ cmatrix" }

    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_floored_division()
    test(2, 8 div 3, "real div real")
end

function test_modulo()
    test(2, 8 mod 3, "real mod real")
end

function test_exponent()
    a = { 3, 3, (3,0), (3,0) }
    b = { 2, (2,0), 2, (2,0) }
    q = { 9, (9,0), (9,0), (9.00000000000000177636,0) }
    s = { "real ^ real", "real ^ complex", "complex ^ real", \
          "complex ^ complex" }
    c = a^b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
        i = i + 1
    end
end

function test_negation()
    a = {3, (1,2), [1,2,3], [(1,2),(3,4)], [1,2|3,4], \
         [(1,2),(3,4)|(5,6),(7,8)], "abc"}
    q = {-3, (-1,-2), [-1,-2,-3], [(-1,-2),(-3,-4)], [-1,-2|-3,-4], \
         [(-1,-2),(-3,-4)|(-5,-6),(-7,-8)], "cba" }
    s = { "- real", "- complex", "- vector", "- cvector", "- matrix", \
          "- cmatrix", "- string" }
    c = -a
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_arithmetic()
    test_addition()
    test_subtraction()
    test_multiplication()
    test_pointwise_multiplication()
    test_division()
    test_pointwise_division()
    test_floored_division()
    test_modulo()
    test_exponent()
    test_negation()
end

function test_or()
    a = {1, 1, 0, 0}
    b = {1, 0, 1, 0}
    q = {1, 1, 1, 0}
    c = a or b
    for i in 0:size(a)-1
        test(q[i], c[i], "or")
	i = i + 1
    end
end

function test_and()
    a = {1, 1, 0, 0}
    b = {1, 0, 1, 0}
    q = {1, 0, 0, 0}
    c = a and b
    for i in 0:size(a)-1
        test(q[i], c[i], "and")
	i = i + 1
    end
end

function test_not()
    a = { 0, 1 }
    q = { 1, 0 }
    c = not a
    for i in 0:size(a)-1
        test(q[i], c[i], "not")
	i = i + 1
    end
end

function test_bor()
    test(14, 10 bor 12, "bor")
end

function test_bxor()
    test(6, 10 bxor 12, "bxor")
end

function test_band()
    test(8, 10 band 12, "band")
end

function test_bnot()
    test(-2, bnot 1, "bnot")
end

function test_logic()
    test_or()
    test_and()
    test_not()
    test_bor()
    test_bxor()
    test_band()
    test_bnot()
end

function test_eq()
    a = { 3, 1, (1,2), (1,2), [1,2,3], [1,2], [(1,0),(2,0)], \
          [(1,2),(3,4)], [1,2|3,4], [1,2|3,4], [(1,0),(2,0)|(3,0),(4,0)], \
	  [(1,2),(3,4)|(5,6),(7,8)], "abc" }
    b = { 3, (2,3), 3, (3,4), [1,2,3], [(1,0),(2,0)], [1,2], \
          [(1,2),(3,4)], [1,2|3,4], [(1,0),(2,0)|(3,0),(4,0)], [1,2|3,4], \
	  [(1,2),(3,4)|(5,6),(7,8)], "def" }
    q = { 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0 }
    s = { "real == real", "real == complex", "complex == real", \
           "complex == complex", "vector == vector", "vector == cvector", \
	   "cvector == vector", "cvector == cvector", "matrix == matrix", \
	   "matrix == cmatrix", "cmatrix == matrix", "cmatrix == cmatrix", "string == string" }
    c = a == b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_ne()
    a = { 3, 1, (1,2), (1,2), [1,2,3], [1,2], [(1,0),(2,0)], \
          [(1,2),(3,4)], [1,2|3,4], [1,2|3,4], [(1,0),(2,0)|(3,0),(4,0)], \
	  [(1,2),(3,4)|(5,6),(7,8)], "abc" }
    b = { 3, (2,3), 3, (3,4), [1,2,3], [(1,0),(2,0)], [1,2], \
          [(1,2),(3,4)], [1,2|3,4], [(1,0),(2,0)|(3,0),(4,0)], [1,2|3,4], \
	  [(1,2),(3,4)|(5,6),(7,8)], "def" }
    q = { 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1 }
    s = { "real != real", "real != complex", "complex != real", \
           "complex != complex", "vector != vector", "vector != cvector", \
	   "cvector != vector", "cvector != cvector", "matrix != matrix", \
	   "matrix == cmatrix", "cmatrix == matrix", "cmatrix == cmatrix", "string != string" }
    c = a != b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_lt()
    a = { 3, "abc" }
    b = { 3, "def" }
    q = { 0, 1 }
    s = { "real < real", "string < string" }
    c = a < b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_le()
    a = { 3, "abc" }
    b = { 3, "def" }
    q = { 1, 1 }
    s = { "real <= real", "string <= string" }
    c = a <= b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_gt()
    a = { 3, "abc" }
    b = { 3, "def" }
    q = { 0, 0 }
    s = { "real > real", "string > string" }
    c = a > b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_ge()
    a = { 3, "abc" }
    b = { 3, "def" }
    q = { 1, 0 }
    s = { "real >= real", "string >= string" }
    c = a >= b
    for i in 0:size(a)-1
        test(q[i], c[i], s[i])
	i = i + 1
    end
end

function test_relational_operators()
    test_eq()
    test_ne()
    test_lt()
    test_le()
    test_gt()
    test_ge()
end

function test_vector_index()
    a = [1, 2, 3, 4]
    test(2, a[1], "vector[i]")
    test([2, 3], a[1:2], "vector[i:i]")
    test([2, 4], a[1:2:2], "vector[i:i:i]")
    a[1] = 20
    test([1, 20, 3, 4], a, "vector[i] = real")
    a[1:2] = [200, 300]
    test([1, 200, 300, 4], a, "vector[i:i] = vector")
    a[1:2:2] = [2000, 4000]
    test([1, 2000, 300, 4000], a, "vector[i:i:i] = vector")
end

function test_cvector_index()
    a = [(1,2),(3,4),(5,6),(7,8)]
    test((3,4), a[1], "cvector[i]")
    test([(3,4),(5,6)], a[1:2], "cvector[i:i]")
    test([(3,4),(7,8)], a[1:2:2], "cvector[i:i:i]")
    a[1] = (30,40)
    test([(1,2),(30,40),(5,6),(7,8)], a, "cvector[i] = real")
    a[1:2] = [(300,400),(500,600)]
    test([(1,2),(300,400),(500,600),(7,8)], a, "cvector[i:i] = cvector")
    a[1:2:2] = [(3000,4000), (7000,8000)]
    test([(1,2),(3000,4000), (500,600), (7000,8000)], a, "cvector[i:i:i] = vector")
end

function test_matrix_index()

    ~ simple index

    a = [1,2,3|4,5,6|7,8,9]
    test([4,5,6], a[1], "matrix[i]")
    test([4,5,6|7,8,9], a[1:2], "matrix[i:i]")
    test([1,2,3|7,8,9], a[0:2:2], "matrix[i:i:i]")
    a[1] = [40,50,60]
    test([1,2,3|40,50,60|7,8,9], a, "matrix[i] = vector")
    a[1:2] = [44,55,66|77,88,99]
    test([1,2,3|44,55,66|77,88,99], a, "matrix[i:i] = matrix")
    a[0:2:2] = [10,20,30|70,80,90]
    test([10,20,30|44,55,66|70,80,90], a, "matrix[i:i:i] = matrix")

    ~ row index

    a = [1,2,3|4,5,6|7,8,9]
    test([4,5,6], a[1,], "matrix[i,]")
    test([4,5,6|7,8,9], a[1:2,], "matrix[i:i,]")
    test([1,2,3|7,8,9], a[0:2:2,], "matrix[i:i:i,]")
    a[1,] = [40,50,60]
    test([1,2,3|40,50,60|7,8,9], a, "matrix[i,] = vector")
    a[1:2,] = [44,55,66|77,88,99]
    test([1,2,3|44,55,66|77,88,99], a, "matrix[i:i,] = matrix")
    a[0:2:2,] = [10,20,30|70,80,90]
    test([10,20,30|44,55,66|70,80,90], a, "matrix[i:i:i,] = matrix")

    ~ column index

    a = [1,2,3|4,5,6|7,8,9]
    test([2, 5, 8], a[,1], "matrix[,i]")
    test([2,3|5,6|8,9], a[,1:2], "matrix[,i:i]")
    test([1,3|4,6|7,9], a[,0:2:2], "matrix[,i:i:i]")
    a[,1] = [20,50,80]
    test([1,20,3|4,50,6|7,80,9], a, "matrix[,i] = vector")
    a[,1:2] = [22,33|55,66|88,99]
    test([1,22,33|4,55,66|7,88,99], a, "matrix[,i:i] = matrix")
    a[,0:2:2] = [10,30|40,60|70,90]
    test([10,22,30|40,55,60|70,88,90], a, "matrix[,i:i:i] = matrix")

    ~ matrix index

    a = [1,2,3|4,5,6|7,8,9]
    test(6, a[1,2], "matrix[i,i]")
    test([5,6], a[1,1:2], "matrix[i,i:i]")
    test([4,6], a[1,0:2:2], "matrix[i,i:i:i]")
    test([5,8], a[1:2,1], "matrix[i:i,i]")
    test([5,6|8,9], a[1:2,1:2], "matrix[i:i,i:i]")
    test([4,6|7,9], a[1:2,0:2:2], "matrix[i:i,i:i:i]")
    test([2,8], a[0:2:2,1], "matrix[i:i:i,i]")
    test([2,3|8,9], a[0:2:2,1:2], "matrix[i:i:i,i:i]")
    test([1,3|7,9], a[0:2:2,0:2:2], "matrix[i:i:i,i:i:i]")

    a[1,2] = 60
    test([1,2,3|4,5,60|7,8,9], a, "matrix[i,i] = real")
    a[1,1:2] = [55,66]
    test([1,2,3|4,55,66|7,8,9], a, "matrix[i,i:i] = vector")
    a[1,0:2:2] = [400,600]
    test([1,2,3|400,55,600|7,8,9], a, "matrix[i,i:i:i] = vector")
    a[1:2,1] = [50,80]
    test([1,2,3|400,50,600|7,80,9], a, "matrix[i:i,i] = vector")
    a[1:2,1:2] = [555,666|888,999]
    test([1,2,3|400,555,666|7,888,999], a, "matrix[i:i,i:i] = matrix")
    a[1:2,0:2:2] = [404,606|707,909]
    test([1,2,3|404,555,606|707,888,909], a, "matrix[i:i,i:i:i] = matrix")
    a[0:2:2,1] = [20,80]
    test([1,20,3|404,555,606|707,80,909], a, "matrix[i:i:i,i] = vector")
    a[0:2:2,1:2] = [22,33|88,99]
    test([1,22,33|404,555,606|707,88,99], a, "matrix[i:i:i,i:i] = matrix")
    a[0:2:2,0:2:2] = [10,30|70,90]
    test([10,22,30|404,555,606|70,88,90], a, "matrix[i:i:i,i:i:i] = matrix")
end

function test_cmatrix_index()

    ~ simple index

    a = [(1,2),(3,4),(5,6)
         (7,8),(9,10),(11,12)
	 (13,14),(15,16),(17,18)]

    test([(7,8),(9,10),(11,12)], a[1], "cmatrix[i]")
    test([(7,8),(9,10),(11,12)|(13,14),(15,16),(17,18)], a[1:2], "cmatrix[i:i]")
    test([(1,2),(3,4),(5,6)|(13,14),(15,16),(17,18)], a[0:2:2], "cmatrix[i:i:i]")
    a[1] = [(70,80),(90,100),(110,120)]
    test([(1,2),(3,4),(5,6)|(70,80),(90,100),(110,120)|(13,14),(15,16),(17,18)], a, "cmatrix[i] = cvector")
    a[1:2] = [(77,88),(99,101),(111,122)|(133,144),(155,166),(177,188)]
    test([(1,2),(3,4),(5,6)|(77,88),(99,101),(111,122)|(133,144),(155,166),(177,188)], a, "cmatrix[i:i] = cmatrix")
    a[0:2:2] = [(11,22),(33,44),(55,66)|(31,41),(51,61),(71,81)]
    test([(11,22),(33,44),(55,66)|(77,88),(99,101),(111,122)|(31,41),(51,61),(71,81)], a, "cmatrix[i:i:i] = cmatrix")

    ~ row index

    a = [(1,2),(3,4),(5,6)
         (7,8),(9,10),(11,12)
	 (13,14),(15,16),(17,18)]

    test([(7,8),(9,10),(11,12)], a[1,], "cmatrix[i,]")
    test([(7,8),(9,10),(11,12)|(13,14),(15,16),(17,18)], a[1:2,], "cmatrix[i:i,]")
    test([(1,2),(3,4),(5,6)|(13,14),(15,16),(17,18)], a[0:2:2,], "cmatrix[i:i:i,]")
    a[1,] = [(70,80),(90,100),(110,120)]
    test([(1,2),(3,4),(5,6)|(70,80),(90,100),(110,120)|(13,14),(15,16),(17,18)], a, "cmatrix[i,] = cvector")
    a[1:2,] = [(77,88),(99,101),(111,122)|(133,144),(155,166),(177,188)]
    test([(1,2),(3,4),(5,6)|(77,88),(99,101),(111,122)|(133,144),(155,166),(177,188)], a, "cmatrix[i:i,] = cmatrix")
    a[0:2:2,] = [(11,22),(33,44),(55,66)|(31,41),(51,61),(71,81)]
    test([(11,22),(33,44),(55,66)|(77,88),(99,101),(111,122)|(31,41),(51,61),(71,81)], a, "cmatrix[i:i:i,] = cmatrix")

    ~ column index

    a = [(1,2),(3,4),(5,6)
         (7,8),(9,10),(11,12)
	 (13,14),(15,16),(17,18)]

    test([(3,4),(9,10),(15,16)], a[,1], "cmatrix[,i]")
    test([(3,4),(5,6)|(9,10),(11,12)|(15,16),(17,18)], a[,1:2], "cmatrix[,i]")
    test([(1,2),(5,6)|(7,8),(11,12)|(13,14),(17,18)], a[,0:2:2], "cmatrix[,i:i:i]")
    a[,1] = [(30,40),(90,100),(150,160)]
    test([(1,2),(30,40),(5,6)|(7,8),(90,100),(11,12)|(13,14),(150,160),(17,18)], a, "cmatrix[,i] = cvector")
    a[,1:2] = [(33,44),(55,66)|(99,101),(111,122)|(155,166),(177,188)]
    test([(1,2),(33,44),(55,66)|(7,8),(99,101),(111,122)|(13,14),(155,166),(177,188)], a, "cmatrix[,i:i] = cmatrix")
    a[,0:2:2] = [(11,22),(50,60)|(77,88),(11,21)|(31,41),(71,81)]
    test([(11,22),(33,44),(50,60)|(77,88),(99,101),(11,21)|(31,41),(155,166),(71,81)], a, "cmatrix[,i:i:i] = cmatrix")

    ~ matrix index

    a = [(1,2),(3,4),(5,6)
         (7,8),(9,10),(11,12)
	 (13,14),(15,16),(17,18)]

    test((11,12), a[1,2], "cmatrix[i,i]")
    test([(9,10),(11,12)], a[1,1:2], "cmatrix[i,i:i]")
    test([(7,8),(11,12)], a[1,0:2:2], "cmatrix[i,i:i:i]")
    test([(9,10),(15,16)], a[1:2,1], "cmatrix[i:i,i]")
    test([(9,10),(11,12)|(15,16),(17,18)], a[1:2,1:2], "cmatrix[i:i,i:i]")
    test([(7,8),(11,12)|(13,14),(17,18)], a[1:2,0:2:2], "cmatrix[i:i,i:i:i]")
    test([(3,4),(15,16)], a[0:2:2,1], "cmatrix[i:i:i,i]")
    test([(3,4),(5,6)|(15,16),(17,18)], a[0:2:2,1:2], "cmatrix[i:i:i,i:i]")
    test([(1,2),(5,6)|(13,14),(17,18)], a[0:2:2,0:2:2], "cmatrix[i:i:i,i:i:i]")

    a[1,2] = (111,112)
    test([(1,2),(3,4),(5,6)|(7,8),(9,10),(111,112)|(13,14),(15,16),(17,18)], a, "cmatrix[i,i] = complex")
    a[1,1:2] = [(209,210),(211,212)]
    test([(1,2),(3,4),(5,6)|(7,8),(209,210),(211,212)|(13,14),(15,16),(17,18)], a, "cmatrix[i,i:i] = cvector")
    a[1,0:2:2] = [(307,308),(311,312)]
    test([(1,2),(3,4),(5,6)|(307,308),(209,210),(311,312)|(13,14),(15,16),(17,18)], a, "cmatrix[i,i:i:i] = cvector")
    a[1:2,1] = [(409,410),(415,416)]
    test([(1,2),(3,4),(5,6)|(307,308),(409,410),(311,312)|(13,14),(415,416),(17,18)], a, "cmatrix[i:i,i] = cvector")
    a[1:2,1:2] = [(509,510),(511,512)|(515,516),(517,518)]
    test([(1,2),(3,4),(5,6)|(307,308),(509,510),(511,512)|(13,14),(515,516),(517,518)], a, "cmatrix[i:i,i:i] = cmatrix")
    a[1:2,0:2:2] = [(607,608),(611,612)|(613,614),(617,618)]
    test([(1,2),(3,4),(5,6)|(607,608),(509,510),(611,612)|(613,614),(515,516),(617,618)], a, "cmatrix[i:i,i:i:i] = cmatrix")
    a[0:2:2,1] = [(703,704),(715,716)]
    test([(1,2),(703,704),(5,6)|(607,608),(509,510),(611,612)|(613,614),(715,716),(617,618)], a, "cmatrix[i:i:i,i] = cvector")
    a[0:2:2,1:2] = [(803,804),(805,806)|(815,816),(817,818)]
    test([(1,2),(803,804),(805,806)|(607,608),(509,510),(611,612)|(613,614),(815,816),(817,818)], a, "cmatrix[i:i:i,i:i] = cmatrix")
    a[0:2:2,0:2:2] = [(901,902),(905,906)|(913,914),(917,918)]
    test([(901,902),(803,804),(905,906)|(607,608),(509,510),(611,612)|(913,914),(815,816),(917,918)], a, "cmatrix[i:i:i,i:i:i] = cmatrix")

end

function test_string_index()
    a = "abcdefghijklmnopqrstuvwxyz"
    test("m", a[12], "string[i]")
    test("bcd", a[1:3], "string[i:i]")
    test("bdf", a[1:3:2], "string[i:i:i]")
    b = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    b[12] = "mark"
    test("ABCDEFGHIJKLmNOPQRSTUVWXYZ", b, "string[i] = s")
    b[0:13] = a[13:13]
    test("nopqrstuvwxyzNOPQRSTUVWXYZ", b, "string[i:i] = s")
    b = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    c = string(26)
    c[1:13:2] = a
    c[0:13:2] = b
    test("AaBbCcDdEeFfGgHhIiJjKkLlMm", c, "string[i:i:i]")
end

function test_list_index()
    a = {1, 2, 3, 4}
    test(2, a[1], "list[i]")
    test({2, 3}, a[1:2], "list[i:i]")
    test({2, 4}, a[1:2:2], "list[i:i:i]")
    a[1] = {2, 2.5}
    test({1, {2, 2.5}, 3, 4}, a, "list[i] = value")
    a[1:2] = {20, 30}
    test({1, 20, 30,4}, a, "list[i:i] = list")
    a[1:2:2] = {200, 400}
    test({1, 200, 30, 400}, a, "list[i:i:i] = list")
end

function test_index()
    test_vector_index()
    test_cvector_index()
    test_matrix_index()
    test_cmatrix_index()
    test_string_index()
    test_list_index()
end

function test_standard_functions()
    ~ not testing matvec(), exit(), read(), eof()
    ~ some tests may fail due to machine rounding
    test([0, 0, 0], vector(3), "vector()")
    test("   ", string(3), "string()")
    test({0, 0, 0}, list(3), "list()")
    test(3, size([0, 0, 0]), "size(vector)")
    test(3, size("abc"), "size(string)")
    test(3, size({1, 2, 3}), "size(list)")
    test({1,2,3,4,5,6}, concat({1,2,3},{4,5,6}), "concat(list,list)")
    test(REAL_TYPE, type(0), "type(e)")
    test(65, ascii("A"), "ascii(string)")
    test(1, real((1,2)), "real(complex)")
    test(2, imag((1,2)), "imag(complex)")
    test(2, abs(-2), "abs(real)")
    test(5, abs((3,4)), "abs(complex)")
    test(0, arg((1,0)), "arg(complex)")
    test(25, norm((3,4)), "norm(complex)")
    test((1,-2), conj((1,2)), "conj(complex)")
    test((1,0), polar(1,0), "polar(real,real)")
    test(5, sqrt(25), "sqrt(real)")
    test((1,2), sqrt((-3,4)), "sqrt(complex)")
    test(1, exp(0), "exp(real)")
    test((1,0), exp((0,0)), "exp(complex)")
    test(0, expm1(0), "exp(real)")
    test(0, log(1), "log(real)")
    test((0,0), log((1,0)), "log(complex)")
    test(0, log1p(0), "log1p(real)")
    test(1, log10(10), "log10(real)")
    test(0, sin(0), "sin(real)")
    test((0,0), sin((0,0)), "sin(complex)")
    test(1, cos(0), "cos(real)")
    test((1,0), cos((0,0)), "cos(complex)")
    test(0, tan(0), "tan(real)")
    test((0,0), tan((0,0)), "tan(complex)")
    test(1, csc(PI/2), "csc(real)")
    test((1,0), csc((PI/2,0)), "csc(complex)")
    test(1, sec(0), "sec(real)")
    test((1,0), sec((0,0)), "sec(complex")
    test(1+EPS, cot(PI/4), "cot(real)")
    test((1+EPS,0), cot((PI/4,0)), "cot(complex)")
    test(0, asin(0), "asin(real)")
    test((0,0), asin((0,0)), "asin(complex)")
    test(0, acos(1), "acos(real)")
    test((0,0), acos((1,0)), "acos(complex)")
    test(0, atan(0), "atan(real)")
    test((0,0), atan((0,0)), "atan(complex)")
    test(PI/2, acsc(1), "acsc(real)")
    test((PI/2,0), acsc((1,0)), "acsc(comple)")
    test(0, asec(1), "sec(real)")
    test((0,0), asec((1,0)), "sec(complex)")
    test(PI/4, acot(1), "acot(real)")
    test((PI/4,0), acot((1,0)), "acot(complex)")
    test(0, sinh(0), "sinh(real)")
    test((0,0), sinh((0,0)), "sinh(complex)")
    test(1, cosh(0), "cosh(real)")
    test((1,0), cosh((0,0)), "cosh(complex)")
    test(0, tanh(0), "tanh(real)")
    test((0,0), tanh((0,0)), "tanh(complex)")
    test(0.850918128239321521, csch(1), "csch(real)")
    test((0.850918128239321521,0), csch((1,0)), "csch(complex)")
    test(1, sech(0), "sech(real)")
    test((1,0), sech((0,0)), "sech(complex)")
    test(0.642092615934330624, coth(1), "coth(real)")
    test((0.642092615934330735,0), coth((1,0)), "coth(real)")
    test(0, asinh(0), "asinh(real)")
    test((0,0), asinh((0,0)), "asinh(complex)")
    test(0, acosh(1), "acosh(real)")
    test((0,0), acosh((1,0)), "acosh(complex)")
    test(0, atanh(0), "atanh(real)")
    test((0,0), atanh((0,0)), "atanh(complex)")
    test(0.88137358701954303, acsch(1), "acsch(real)")
    test((0.881373587019542899,0), acsch((1,0)), "acsch(complex)")
    test(0, asech(1), "asech(real)")
    test((0,0), asech((1,0)), "asech(complex)")
    test(0.549306144334054734, acoth(2), "acoth(real)")
    test((0.549306144334054845,0), acoth((2,0)), "acoth(complex)")
    test(120, gamma(6), "gamma(real)")
end

function mpl_test()
    test_arithmetic()
    test_logic()
    test_relational_operators()
    test_index()
    test_standard_functions()
end

mpl_test()

"Done testing"


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

# A standard Stasheff tree for n is a Stasheff tree for the set
# {1,...,n} with its standard ordering.

`is_element/standard_stasheff_trees` := (n::posint) -> proc(TT)
 local A,T,i;
 global reason;

 A := {seq(i,i=1..n)};

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

 for T in TT do
  if nops(T) <> max(T) - min(T) + 1 then
   reason := ["is_element/standard_stasheff_trees","T is not an interval",T];
   return false;
  fi;
 od;

 return true;
end;

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

`is_equal/standard_stasheff_trees` := (n::posint) -> proc(TT,UU)
 local A,i;

 A := {seq(i,i=1..n)};
 return `is_equal/trees`(A)(TT,UU);
end;

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

`is_leq/standard_stasheff_trees` := (n::posint) -> proc(TT,UU)
 local A,i;

 A := {seq(i,i=1..n)};
 return `is_leq/trees`(A)(TT,UU);
end;

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

`random_element/standard_stasheff_trees` := (n::posint) -> proc()
 local N,pi,TT,UU,U,i;

 if n = 0 then return FAIL; fi;
 if n = 1 then return {{1}}; fi;

 N := {seq(i,i=1..n)};

 pi := {N};
 while nops(pi) = 1 do
  pi := `random_element/interval_partitions`(n)();
 od;

 TT := N;

 for U in pi do
  UU := `random_element/standard_stasheff_trees`(nops(U))();

  UU := map(V -> map(v -> v+min(U)-1,V),UU);
  TT := TT,op(UU);
 od;

 TT := {TT};

 return TT;
end;

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

`list_elements/standard_stasheff_trees` := proc(n::posint)
 option remember;

 local TTT,UUU,TT,UU,N,IP,pi,pi_list,P,B,b,i;
 if n = 0 then return []; fi;
 if n = 1 then return [{{1}}]; fi;

 N := {seq(i,i=1..n)};
 TTT := NULL;
 IP := select(pi -> pi <> {N},`list_elements/interval_partitions`(n));

 for pi in IP do
  pi_list := [op(pi)];
  P := NULL;
  for B in pi_list do
   b := min(op(B));
   UUU := `list_elements/standard_stasheff_trees`(nops(B));
   UUU := map(UU -> map(V -> map(v -> b-1+v,V),UU),UUU);
   P := P,UUU;
  od;
  P := `cartesian_product/lists`(P);
  TTT := TTT,op(map(UU -> {N,op(map(op,UU))},P));
 od:
 return([TTT]);
end:

######################################################################
# This is A001003 in OEIS

`count_elements/standard_stasheff_trees` := proc(n)
 local f,L,i;
 if n = 0 then
  return 0;
 elif n = 1 then
  return 1;
 else
  f := (k) -> op([seq(i,i=0..k+1),seq(k-i,i=0..k)]);
  L := [0];
  for i from 1 to n-2 do
   L := map(f,L);
  od;
  return nops(L);
 fi;
end;

# Alternative formula for n > 1:
# add(2^k*3^(n-2-2*k)*binomial(n-2,2*k)*binomial(2*k,k)/(k+1),k=0..floor((n-2)/2));

`dim/standard_stasheff_trees` := (n) -> proc(TT)
 2*n - 1 - nops(TT);
end:

`count_by_dim/standard_stasheff_trees` := proc(n,k)
 if k < 0 or k > n-2 then return 0; fi;

 return binomial(n-2,n-k-2) * binomial(2*n-k-2,n) / (n - k - 1);
end:

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

`draw/standard_stasheff_trees` := (n::posint) -> proc(TT)
 local p,P,T,U,m,i;
 p := table();
 P := NULL;
 for T in TT do
  p[T] := [`+`(op(T))/nops(T),nops(T)];
 od;

 m := parent_map({seq(i,i=1..n)})(TT);

 for T in TT do
  if nops(T) < n then
   U := m[T];
   P := P,line(p[T],p[U]);
  fi;
 od;
 for T in TT do
  P := P,point(p[T],colour=red,symbol=solidcircle,symbolsize=20);
 od;

 P := display(P,axes=none,scaling=constrained);
 return P;
end:

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

`root_children/standard_stasheff_tree` := (n::posint) -> proc(TT)
 local C,A,i,XX,X,m;

 if n = 1 then return []; fi;

 C := NULL;
 A := {seq(i,i=1..n)};
 while A <> {} do
  i := min(op(A));
  XX := select(X -> member(i,X) and nops(X) < n,TT);
  m := max(op(map(nops,XX)));
  XX := select(X -> nops(X) = m,XX);
  X := XX[1];
  C := C,X;
  A := A minus X;
 od:
 return [C];
end:

######################################################################
# A Stasheff tree TT on A is binary if every non-minimal set in TT has
# precisely two children.  This holds iff |TT| = 2|A|-1.

`is_binary/standard_stasheff_trees` := (n::posint) -> proc(TT)
 return evalb(nops(TT) = 2*n-1);
end:

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

`e/loday` := (n::posint) -> proc(pq)
 local p,q;
 p,q := op(pq);
 return [0 $ (p-1), 1 $ (q-p), 0 $ (n-q)];
end:

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

`m/loday` := (n::posint) -> pq -> (pq[2]-pq[1]+1)*(pq[2]-pq[1])/2;

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

`p/loday` := (n::posint) -> proc(pq,u)
 local i;
 return add(u[i],i=pq[1]..pq[2]-1) - `m/loday`(n)(pq);
end:

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

`is_element/PK` := (n::posint) -> proc(u)
 global reason;
 local p,q;

 if not `is_element/R`(n-1)(u) then
  reason := [convert(procname,string),"u is not a list of length n-1",u,n-1];
  return false;
 fi;

 if `p/loday`(n)([1,n],u) <> 0 then
  reason := [convert(procname,string),"p_A(u) <> 0",u];
  return false;
 fi;

 for p from 1 to n do
  for q from p to n do
   if `p/loday`(n)([p,q],u) < 0 then
    reason := [convert(procname,string),"p_J(u) < 0",u,[p,q]];
    return false;
   fi;
  od;
 od;

 return true;
end;

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

`tau/loday` := (n::posint) -> proc(u)
 local TT,p,q,i;
 TT := NULL;
 for p from 1 to n do
  for q from p to n do
   if `p/loday`(n)([p,q],u) = 0 then
    TT := TT,{seq(i,i=p..q)};
   fi;
  od;
 od;
 TT := {TT};

 return TT;
end;

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

`is_element/Sigma0_loday` := (n::posint) -> proc(sigma)
 global reason;
 local JJ,J,g,i,j,k;

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

 JJ := {seq(seq({seq(k,k=i..j)},j=i+1..n),i=1..n)};
 if map(op,{indices(sigma)}) <> JJ then
  reason := [convert(procname,string),"sigma is not indexed by the appropriate set of intervals",sigma,JJ];
  return false;
 fi;

 for J in JJ do
  g := sigma[J];
  if not (type(g,set) and nops(g) = 2 and max(op(g)) - min(op(g)) = 1) then
   reason := [convert(procname,string),"sigma(J) is not a gap",sigma,J,g];
   return false;
  fi;

  if g minus J <> {} then
   reason := [convert(procname,string),"sigma(J) is not a gap in J",sigma,J,g];
   return false;
  fi;
 od;

 return true;
end;

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

`w0/loday` := (n::posint) -> proc(sigma)
 local v,JJ,J,i,j,k;

 v := Vector(n-1);
 JJ := {seq(seq({seq(k,k=i..j)},j=i+1..n),i=1..n)};
 for J in JJ do
  i := min(op(sigma[J]));
  v[i] := v[i] + 1;
 end:

 return convert(v,list);
end;

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

`pi/loday` := (n::posint) -> (TT) -> proc(J)
 local UU,k;

 UU := select(T -> J minus T = {},TT);
 k := min(map(nops,UU));
 UU := select(U -> nops(U) = k,UU);
 return(UU[1]);
end;

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

`w/loday` := (n::posint) -> proc(TT)
 local v,JJ,J,P,G,T,S,g,m,i,j,k;

 v := Vector(n-1);
 JJ := {seq(seq({seq(k,k=i..j)},j=i+1..n),i=1..n)};
 P := table();
 for J in JJ do
  P[J] := `pi/loday`(n)(TT)(J);
 od;
 G := {seq({i,i+1},i=1..n-1)};
 for J in JJ do
  T := P[J];
  S[J] := NULL;
  for j from min(J) to max(J)-1 do
   g := {j,j+1};
   if P[g] = T then
    S[J] := S[J],g;
   fi;
  od;
  S[J] := {S[J]};
  m := nops(S[J]);
  for g in S[J] do
   v[min(g)] := v[min(g)] + 1/m;
  od;
 od;
 return convert(v,list);
end:

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

`w/loday/bin` := (n::posint) -> proc(TT)
 local C,T,v,i;
 C := children_map({seq(i,i=1..n)})(TT);
 v := Vector(n-1);
 for i from 1 to n-1 do
  T := `pi/loday`(n)(TT)({i,i+1});
  v[i] := `*`(op(map(nops,C[T])));
 od;
 return convert(v,list);
end:

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

`T/loday` := (n::posint) -> proc(i)
 local j,k;
 {seq({j},j=1..n),{seq(j,j=1..n)},
  seq({seq(k,k=1..j)},j=2..i),
  seq({seq(k,k=j..n)},j=i+1..n-1)
 };
end:

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

`phi/standard_stasheff_trees/PK` := (n::posint) -> (TT) -> `w/loday`(n)(TT);

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

`phi/realisation/standard_stasheff_trees/PK` := (n::posint) -> proc(x)
 local C,v,TT;

 C := map(op,[indices(x)]);
 v := [0$(n-1)];
 for TT in C do
  v := v +~ x[TT] *~ `phi/standard_stasheff_trees/PK`(n)(TT);
 od;

 return v;
end:


with(ListTools):
with(combinat):
with(Physics):
with(Threads):
with(GroupTheory):
interface(labelling=false):

Setup(mathematicalnotation=true, anticommutativecolor=olive):
Setup(anticommutativeprefix={phi,theta,tau,eta,psi,rho}):

#Protecting variable names to avoid non-omniscient program user errors.
protect(a);
protect(m);
protect(n);
protect(p);
protect(h);
protect(e);
protect(s);
protect(sbar);
protect(sEt);
protect(sbarEt);
protect(beta);
protect(alpha);
protect(box):
protect(circle):

read "./lib/sparts.mpl";
read "./lib/types.mpl";
read "./lib/operators.mpl";
read "./lib/basis.mpl";
read "./lib/CMS.mpl";
read "./lib/visual.mpl";
read "./lib/sBern_1.mpl";
read "./lib/bernsteinLAV.mpl";
####################################################################################################
#interface(screenwidth=100);


# Konvertierung Vektor zu symmetrischer Matrix
# Einleitung
# Generiere die Umwandlung von Vektor mit oberem rechten Teil einer Symmetrischen Matrix zur Matrix selbst für die Dimensionen des Roboters.
# Diese Umwandlung verursacht weniger Rechenoperationen als die Verwendung der numerischen Funktion vec2symmat in Matlab, da dort jedes Mal die Indizes beim Zusammenbauen der Matrix getestet werden müssen.
# Autor
# Moritz Schappler, schappler@irt.uni-hannover.de, 2016-12
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
# Initialization
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
with(LinearAlgebra):
with(ArrayTools):
with(codegen):
with(CodeGeneration):
with(StringTools):
# Einstellungen für Code-Export: Optimierungsgrad (2=höchster) und Aktivierung jedes Terms.
read "../helper/proc_MatlabExport":
read "../helper/proc_vector2symmat":
read "../robot_codegen_definitions/robot_env":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):
printf("Generiere Symmat2Vector-Funktionen für %s\n", robot_name):
codegen_opt := 0: # Soll nicht von Einstellung in robot_env überschrieben werden.
;
# Funktion symmat2vector für den Roboter definieren
# Erstelle eine Dummy-Variable (mv), die als temporäre Variable in Matlab dient (zum Zusammensetzen der Matrix).
clear('mv'):
M_NQ:= vec2symmat(mv, NQ):
M_NQJ:= vec2symmat(mv, NQJ):
M_6:= vec2symmat(mv, 6):
# Warnungen bei Code-Generierung unterdrücken. Die Meldung das der Ausdruck mv() in Matlab nicht bekannt ist, spielt keine Rolle, da diese Variable nach dem Einsetzen des Codes vorher definiert sein wird.
interface(warnlevel=0):
MatlabExport(M_NQ, sprintf("../codeexport/%s/tmp/vec2symmat_%d_matlab.m", robot_name, NQ), codegen_opt):
MatlabExport(M_NQJ, sprintf("../codeexport/%s/tmp/vec2symmat_%d_matlab.m", robot_name, NQJ), codegen_opt):
MatlabExport(M_6, sprintf("../codeexport/%s/tmp/vec2symmat_%d_matlab.m", robot_name, 6), codegen_opt):


print_comp:=proc(A,coord::list,dim::integer,{diag:=false,tp:=dn})

  local i, j;
  local s;
  local cn,cm;

  if dim = 0 then
  s:= "";
  s:= cat(s,convert(A,string));
  s:= cat(s,"_expr");
  s:= cat(s,sprintf(":="));
  s:= cat(s,convert(grcomponent(A),string));
  s:= cat(s,sprintf(";\n"));
  return s;
  end if;

  if dim = 1 then
  s:="";
   for i from 1 to nops(coord)-1 do
    cn:=coord[i];
    s:= cat(s,convert(A||cn,string));
    s:= cat(s,"_expr");
    s:= cat(s,sprintf(":="));
    s:=cat(s,convert(grcomponent(A(tp),[coord[i]]),string));
    s:= cat(s,sprintf(";\n"));
   end do;
    return s;
  end if;

  if dim = 2 then
  s:="";
  if not(diag) then
   for i from 1 to nops(coord)-1 do
   for j from 1 to nops(coord)-1 do
    cn:=coord[i];
    cm := coord[j];
    s:=cat(s,convert(A||cn||cm,string));
    s:= cat(s,"_expr");
    s:=cat(s,sprintf(":="));
    s:=cat(s,convert(grcomponent(A(tp,tp),[coord[i],coord[j]]),string));
    s:=cat(s,sprintf(";\n"));
   end do;
   end do;

  else
   for i from 1 to nops(coord)-1 do
    cn:=coord[i];
    s:=cat(s,convert(A||cn||cn,string));
    s:= cat(s,"_expr");
    s:=cat(s,sprintf(":="));
    s:=cat(s,convert(grcomponent(A(tp,tp),[coord[i],coord[i]]),string));
    s:=cat(s,sprintf(";\n"));
   end do;
   end if;

   return s;
  end if;

end proc;


var $iconst1 <[4] [4] i32> = [ [1007, 707, -273, 75], [0113, 0x4b, 75u, 75l], [75ul, 75lu, 31425926, 60223], [60223, 1619, 30, 314159]]
var $fconst1 <[4] [4] f64> = [ [1007.0, 707.0, -273.0, 75.0], [113.1, 4.0, 75.0, 75.1], [75.0, 75.1, 3.1425926, 6.02e23], [6.02e+23, 1.6e-19, 3.0, 3.14159]]
func &printf (var %p1 <* i8>)void
func &main ( ) i32 {
   call &printf (addrof a32 $fconst1)
   return (constval i32 0) }

 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


######################################################################
# Binary operations on finite sets

`is_element/binops` := (A::set,B::set,C::set) -> proc(p)
 local AB,dom,cod,a,b;
 global reason;

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

 AB := {seq(seq([a,b],b in B),a in A)};

 if {indices(p)} <> AB then
  reason := [convert(procname,string),"wrong domain",{indices(p)},AB];
  return false;
 fi;

 cod := map(op,{entries(p)});
 if cod minus C <> {} then
  reason := [convert(procname,string),"wrong codomain",cod,C];
  return false;
 fi;

 return true;
end;

`is_equal/binops` := (A::set,B::set,C::set) -> proc(p,q)
 local a,b;
 global reason;

 for a in A do
  for b in B do
   if p[a,b] <> q[a,b] then
    reason := [convert(procname,string),"different value",a,b,p[a,b],q[a,b]];
    return false;
   fi;
  od;
 od;

 return true;
end;

`is_leq/binops` := NULL;

`random_element/binops` := (A::set,B::set,C::set) -> proc()
 local p,n,r,a,b;

 p := table();
 if B = {} then
  if A = {} then
   return eval(p);
  else
   return FAIL;
  fi;
 fi;

 n := nops(C);

 r := rand(1..n);

 for a in A do
  for b in B do
   p[a,b] := C[r()];
  od;
 od;

 return eval(p);
end;

`list_elements/binops` := proc(A::set,B::set,C::set)
 local nA,nB,nC,J,L,i,j,k,u;

 nA := nops(A);
 nB := nops(B);
 nC := nops(C);
 J := [seq(seq([A[i],B[j]],j=1..nB),i=1..nA)];
 L := [[]];
 for i from 1 to nA*nB do
  L := [seq(seq([op(u),j],j=1..nC),u in L)];
 od:

 L := map(u -> table([seq(op(J[k])=C[u[k]],k=1..nA*nB)]),L);
 return L;
end;

`count_elements/binops` := (A::set,B::set,C::set) -> nops(C) ^ (nops(A)*nops(B));

`is_associative/binops` := (A::set) -> proc(m)
 local a,b,c;
 for a in A do
  for b in A do
   for c in A do
    if m[a,m[b,c]] <> m[m[a,b],c] then
     return false;
    fi;
   od;
  od;
 od;
 return true;
end:

`is_commutative/binops` := (A::set) -> proc(m)
 local a,b;
 for a in A do
  for b in A do
   if m[a,b] <> m[b,a] then
    return false;
   fi;
  od;
 od;
 return true;
end:

`is_left_proj/binops` := (A::set) -> proc(m)
 local a,b;
 for a in A do
  for b in A do
   if m[a,b] <> a then
    return false;
   fi;
  od;
 od;
 return true;
end:

`is_right_proj/binops` := (A::set) -> proc(m)
 local a,b;
 for a in A do
  for b in A do
   if m[a,b] <> b then
    return false;
   fi;
  od;
 od;
 return true;
end:

`is_idempotent/binops` := (A::set) -> proc(m)
 local a;
 for a in A do
  if m[a,a] <> a then
   return false;
  fi;
 od;
 return true;
end:

`is_left_neutral/binops` := (A::set) -> proc(m,e)
 local a;

 if not(member(e,A)) then return false; fi;
 for a in A do
  if m[e,a] <> a then return false; fi;
 od:
 return true;
end:

`is_right_neutral/binops` := (A::set) -> proc(m,e)
 local a;

 if not(member(e,A)) then return false; fi;
 for a in A do
  if m[a,e] <> a then return false; fi;
 od:
 return true;
end:

`is_neutral/binops` := (A::set) -> proc(m,e)
 return `is_left_neutral/binops`(A)(m,e) and
        `is_right_neutral/binops`(A)(m,e);
end:

`has_left_neutral/binops` := (A::set) -> proc(m)
 local e;

 for e in A do
  if `is_left_neutral/binops`(A)(m,e) then
   return true;
  fi;
 od:
 return false;
end:

`has_right_neutral/binops` := (A::set) -> proc(m)
 local e;

 for e in A do
  if `is_right_neutral/binops`(A)(m,e) then
   return true;
  fi;
 od:
 return false;
end:

`has_neutral/binops` := (A::set) -> proc(m)
 local e;

 for e in A do
  if `is_neutral/binops`(A)(m,e) then
   return true;
  fi;
 od:
 return false;
end:

`is_left_absorbing/binops` := (A::set) -> proc(m,e)
 local a;

 if not(member(e,A)) then return false; fi;
 for a in A do
  if m[e,a] <> e then return false; fi;
 od:
 return true;
end:

`is_right_absorbing/binops` := (A::set) -> proc(m,e)
 local a;

 if not(member(e,A)) then return false; fi;
 for a in A do
  if m[a,e] <> e then return false; fi;
 od:
 return true;
end:

`is_absorbing/binops` := (A::set) -> proc(m,e)
 return `is_left_absorbing/binops`(A)(m,e) and
        `is_right_absorbing/binops`(A)(m,e);
end:

`has_left_absorbing/binops` := (A::set) -> proc(m)
 local e;

 for e in A do
  if `is_left_absorbing/binops`(A)(m,e) then
   return true;
  fi;
 od:
 return false;
end:

`has_right_absorbing/binops` := (A::set) -> proc(m)
 local e;

 for e in A do
  if `is_right_absorbing/binops`(A)(m,e) then
   return true;
  fi;
 od:
 return false;
end:

`has_absorbing/binops` := (A::set) -> proc(m)
 local e;

 for e in A do
  if `is_absorbing/binops`(A)(m,e) then
   return true;
  fi;
 od:
 return false;
end:


rename_cohomology_gens := proc(T0::table,u::list)
 local u0,n0,r,T,i;

 u0 := [op(T0["cohomology_gens"])];
 n0 := nops(u0);

 if nops(u) <> n0 then
  error("Incorect number of cohomology generators");
 fi;

 r := [seq(u0[i] = u[i],i=1..n0)];

 T := copy(T0);
 T["cohomology_gens"] := subs(r,T0["cohomology_gens"]);
 T["cohomology_rels"] := subs(r,T0["cohomology_rels"]);
 T["cohomology_degrees"] := table([]):
 for i from 1 to n0 do
  T["cohomology_degrees"][u[i]] :=
   T0["cohomology_degrees"][u0[i]];
 od;
 T["cohomology_basis"] := subs(r,T0["cohomology_basis"]);
 for i from 0 to T["dimension"] do
  T["cohomology_graded_basis"][i] :=
   subs(r,T["cohomology_graded_basis"][i]);
 od:

 return eval(T);
end:

make_product_space := proc(T0,T1)
 local T,d0,d1,B0,B1,B,i0,i1,u0,u1,x,i;
 T := table():

 T["name"] := sprintf("%s x %s",T0["name"],T1["name"]);
 d0 := T0["dimension"];
 d1 := T1["dimension"];
 T["dimension"] := d0+d1;
 T["cohomology_gens"] := tdeg(op(T0["cohomology_gens"]),
                              op(T1["cohomology_gens"]));
 T["cohomology_rels"] := [op(T0["cohomology_rels"]),
                          op(T1["cohomology_rels"])];
 T["cohomology_degrees"] := table([]);
 for x in T0["cohomology_gens"] do
  T["cohomology_degrees"][x] := T0["cohomology_degrees"][x];
 od:
 for x in T1["cohomology_gens"] do
  T["cohomology_degrees"][x] := T1["cohomology_degrees"][x];
 od:

 T["cohomology_basis"] := [seq(seq(u0*u1,u0 in T0["cohomology_basis"]),
                                         u1 in T1["cohomology_basis"])];

 B0 := T0["cohomology_graded_basis"]:
 B1 := T1["cohomology_graded_basis"]:
 B := table():

 for i from 0 to d0+d1 do
  B[i] := NULL:

  for i0 from max(0,i-d1) to min(i,d0) do
   i1 := i - i0;
   B[i] := B[i],seq(seq(u0*u1,u0 in B0[i0]),u1 in B1[i1]);
  od:
 od;

 T["cohomology_graded_basis"] := eval(B):

 return eval(T);
end:


(*
    变量可以划分为：
    + 自由变量：在满足非零的前提下可以全部取0。
    + 确定性变量：取值已经确定，或者由其它变量确定。
    + 有约束变量：其约束来自于解的定义域，由解的性质可知，其值不由其它变量所确定。

    处理时主要处理约束条件，自由变量可以加单取0，确定性变量的值已知。在完全处理约束的前提下，无需验证是否满足约束。

    至于如何处理约束：
    + 和c有关的约束：为了能够始终满足约束，特解应当和c有关，可以采取变成等式约束进行求解的方式进行处理。(注意对于单独的c的约束，直接删除)
    + 和c无关的约束：可以简单求解不等式，求解后的结果，都是单边的不等式约束，可以看情况取解。

    对于求解后的结果，可以细分为：
    + 单变量约束，可以按照简单的方法取定特解。
    + 多变量约束，可以在取定其它变量的值之后，转化单变量约束进行处理。
*)

$ifndef _FETCH_
$define _FETCH_

$include "Condition.mpl"
$include "Utils.mpl"

# 根据方程和约束取特解
fetchSpecSol:=proc(sol::list,con::set,{nonzero::boolean:=false})
    local vars,vf,eq,ca,cc,res,ccv,sc;
    vars:=lhs~(sol);
    vf,eq,ca,cc:=filtCon({sol[],classifySolve(con)[]});
    if cc<>{} then
        # 对于和c有关的不等式约束，转化成等式约束后再进行求解
        cc:=transIeq~(cc);
        ccv:=indets(cc,name);
        ccv:=select(type,ccv,specindex(a));
        sc:=RealDomain:-solve(cc,[ccv[]],explicit);
        res:=map(rebuildAndFetch,sc,vars,vf,eq,ca,nonzero);
        res:=sortByComplexity(res);
        return res[1];
    else
        return fetchByCons(vars,vf,eq,ca,nonzero);
    end if;
end proc:

# 转化关于c的不等式约束之后，再对约束进行分类
rebuildAndFetch:=proc(s,vars,_vf,_eq,_ca,nonzero)
    local vf,eq,ca,cc;
    vf,eq,ca,cc:=filtCon({s[]} union findSolutionDomain(s));
    vf:=_vf minus indets(lhs~(eq),name);
    eq:=eq union _eq;
    ca:=ca union _ca;
    return fetchByCons(vars,vf,eq,ca,nonzero);
end proc:

# 求解关于a的约束之后，转化为单边约束，再逐解取特解
fetchByCons:=proc(vars,vf,eq,ca,nonzero)
    local sca,res;
    sca:=[RealDomain:-solve(ca)];
    res:=map[4](fetchBySingleCons,vars,vf,eq,sca,nonzero);
    if nonzero then
        # 在满足非零要求时，目的是给出所有可能的基
        # 而求解a的约束产生的每个解是不相交的
        # 所以需要合并各个解的基
        return `union`(res[]);
    else
        return sortByComplexity(res)[1];
    end if;
end proc:

# 对于和a有关的约束，采用逐步替换的方法取特解
fetchBySingleCons:=proc(vars,_vf,_eq,_ca,nonzero)
    local vf,eq,ca,sca,res,req,tmp,i,n,ra;
    vf:=_vf;# 自由变量
    eq:=_eq;# 不等式方程的解等式约束
    ca:=_ca;# 求解跟a有关的约束得到的解
    # 对于单变量约束，采用最邻近整数方式取特解
    # 逐步替换多变量约束中的变量，最终都取得特解
    while true do
        sca,ca:=selectremove(isSingleCon,ca);
        if sca={} then
            break;
        end if;
        sca:=fetchIeq~(sca);
        eq:=eq union sca;
        ca:=subs(sca[],ca);
    end do;
    # 由于对不等约束的求解可能存在等式约束，因此最后剩下的是等式约束
    # BUG  出错的问题在于上面得到的ca可能会有等式约束
    ca,ra:=selectremove(type,ca,equation);
    vf:={seq(x=0,x in vf)};
    eq:=eq union ca union vf;
    req:=vars;
    # 带入两次是因为带入一次可能不完全
    res:=eval(subs(eq[],req));
    res:=eval(subs(eq[],res));
    # 假设还有变量存在，就重新求解
    if indets(res,specindex(a))<>{} then
        res:=fetchSpecSol([seq(a[i]=res[i],i=1..numelems(vars))],{});
    end if;
    if nonzero then
        if andmap(type,res,0) then
            n:=numelems(vf);
            res:={};
            for i from 1 to n do
                tmp:=subsop([i,2]=1,vf);
                res:=res union {eval(subs(tmp[],eq[],req))};
            end do;
        else
            res:={res};
        end if;
    end if;
    return res;
end proc:

# 是否是单变量约束
isSingleCon:=proc(x)
    return not type(x,`=`) and numelems(indets(x,name))=1;
end proc:

# 筛选：自由变量，确定性约束，和c无关的不等式约束，和c有关的不等式约束
# 会删除之和c有关的约束
filtCon:=proc(con::set)
    local ef,eq,ca,cc,rst,vf;
    ef,rst:=selectremove(x->lhs(x)=rhs(x),con);
    eq,rst:=selectremove(type,rst,`=`);
    vf:=indets(ef,name) minus lhs~(eq) minus indets(rst,name);
    cc,ca:=selectremove(has,rst,c);
    cc:=select(has,cc,a);
    return vf,eq,ca,cc;
end proc:

# 将不等式约束转化为等式约束
transIeq:=proc(x)
    if op(0,x)=`<>` or op(0,x)=`<` then
        return lhs(x)=rhs(x)-1;
    elif op(0,x)=`>` then
        return lhs(x)=rhs(x)+1;
    else
        return lhs(x)=rhs(x);
    end if;
end proc:

# 对于 <> < <= 的约束条件取特解
# 取满足条件的最邻近整数
fetchIeq:=proc(x)
    local r;
    if type(x,`<>`) then
        r:=lhs(x)=floor(rhs(x))+1;
    elif type(lhs(x),numeric) then
        if type(x,`<`) then
            r:=rhs(x)=floor(lhs(x))+1;
        else
            r:=rhs(x)=ceil(lhs(x));
        end if;
    else
        if type(x,`<`) then
            r:=lhs(x)=ceil(rhs(x))-1;
        else
            r:=lhs(x)=floor(rhs(x));
        end if;
    end if;
end proc:

$endif


 func $cvtu64tof32 (
  var %i u64
  ) f32 {
   return (
     cvt f32 u64(dread u64 %i))}
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


#######################################################################
# This file is part of the crlibm library, and is distributed under
# the  LGPL.
# To use:
# restart; read "exp-td.mpl";
Digits := 145:

interface(quiet=true):

read "common-procedures.mpl":
read "triple-double.mpl":
read "gal.mpl":
mkdir("TEMPASIN"):

with(orthopoly,T):

truncPoly := proc(p,k)
local i, q:
q := 0:
convert(q,polynom):
for i from 0 to min(degree(p,x),k) do
    q := q + coeff(p,x,i) * x^i:
od:
return (q):
end:

intervals := 10:

for i from 1 to intervals do
	epsAccurate[i] := 0.5:
	epsQuick[i] := 0.5:
	polyAccurate[i] := 1:
	polyQuick[i] := 1:
od:
epsAccurateSpecial := 0.5:
epsQuickExtra := 0.5:

lowestIntervalMax := 0.185:
highestIntervalMin := 0.78:

polyAccurateTDCoeffsLowest := 13:
polyAccurateDDCoeffsLowest := 12:
polyAccurateDCoeffsLowest := 16:

polyAccurateDegreeLowest := polyAccurateTDCoeffsLowest + polyAccurateDDCoeffsLowest + polyAccurateDCoeffsLowest:

polyQuickDDCoeffsLowest := 12:
polyQuickDCoeffsLowest := 10:

polyQuickDegreeLowest := polyQuickDDCoeffsLowest + polyQuickDCoeffsLowest:

polyAccurateTDCoeffsMiddle := 7:
polyAccurateDDCoeffsMiddle := 9:
polyAccurateDCoeffsMiddle := 19:

polyAccurateDegreeMiddle := polyAccurateTDCoeffsMiddle + polyAccurateDDCoeffsMiddle + polyAccurateDCoeffsMiddle:

polyQuickDDCoeffsMiddle := 7:
polyQuickDCoeffsMiddle := 7:

polyQuickDegreeMiddle := polyQuickDDCoeffsMiddle + polyQuickDCoeffsMiddle:

polyAccurateTDCoeffsHighest := 9:
polyAccurateDDCoeffsHighest := 9:
polyAccurateDCoeffsHighest := 11:

polyAccurateDegreeHighest := polyAccurateTDCoeffsHighest + polyAccurateDDCoeffsHighest + polyAccurateDCoeffsHighest:

polyQuickDDCoeffsHighest := 9:
polyQuickDCoeffsHighest := 9:

polyQuickDegreeHighest := polyQuickDDCoeffsHighest + polyQuickDCoeffsHighest:

extrabound := hexa2ieee(["3F500000","00000000"]):
polyQuickDegreeExtra := 5:

bound[0] := 0:
b := nearest(lowestIntervalMax):
he := ieeehexa(b):
bound[1] := hexa2ieee([he[1],"00000000"]):
b := nearest(highestIntervalMin):
he := ieeehexa(b):
bound[intervals - 1] := hexa2ieee([he[1],"00000000"]):
bound[intervals] := 1:
linearWidth := (highestIntervalMin - lowestIntervalMax) / (intervals - 2):
scaleSum := 0:
scale[2] := 1.5:
scale[3] := 1.35:
scale[4] := 1.18:
scale[5] := 1.00:
scale[6] := 0.915:
scale[7] := 0.74:
scale[8] := 0.595:
scale[9] := 0.50:
for i from 2 to (intervals-1) do
	scaleSum := scaleSum + scale[i]:
od:
for i from 2 to (intervals-1) do
	scale[i] := scale[i] / scaleSum;
od:
current := lowestIntervalMax:
for i from 2 to (intervals-2) do
	b := nearest(current + (highestIntervalMin - lowestIntervalMax) * scale[i]):
	current := b:
	he := ieeehexa(b):
	bound[i] := hexa2ieee([he[1],"00000000"]):
od:
printf("Using %d intervals with bounds:\n",intervals):
for i from 0 to intervals do
	printf("bound[%d] = %1.30e\n",i,bound[i]):
od:
printf("Using an extra bound for truncating the quick poly to deg. %d in interval #0 for small args up to %f (2^(%f))\n",
	polyQuickDegreeExtra,extrabound,log[2](abs(extrabound)));

printf("Computing Gal's accurate table values for interval midpoints\n"):
for i from 2 to (intervals-1) do
	m := nearest((bound[i] + bound[i-1]) / 2):
	mhe := ieeehexa(m):
	printf("Interval %d: accurate table research start value %f (%s%s)\n",i,m,mhe[1],mhe[2]):
	midpointFloat[i] := galDoubleToDoubleDouble(nearest(m),arcsin,2^(-121),2^(15)):
od:

printf("Using the following floating point midpoints for intervals 2-%d:\n",intervals-2):
for i from 2 to (intervals-1) do
	mhe := ieeehexa(midpointFloat[i]):
	printf("midpointFloat[%d] = %f (%s%s)\n",i,midpointFloat[i],mhe[1],mhe[2]):
od:

printf("The reduced argument z is therefore bounded by:\n"):
printf("Interval 1: |z| < 2^(%f)\n",
	log[2](abs(bound[1]))):
for i from 2 to (intervals-1) do
	printf("Interval %d: |z| < 2^(%f)\n",i,
	log[2](max(abs(midpointFloat[i] - bound[i-1]),abs(midpointFloat[i] - bound[i])))):
od:
printf("Interval %d: |z| < 2^(%f)\n",intervals,
	log[2](abs(1 - bound[intervals-1]))):

printf("Using a %d degree polynomial for lowest interval (1) (accurate phase)\n",
	polyAccurateDegreeLowest):
printf("with %d triple-double, %d double-double and %d double coefficients\n",
	polyAccurateTDCoeffsLowest, polyAccurateDDCoeffsLowest, polyAccurateDCoeffsLowest):
printf("Using a %d degree polynomial for lowest interval (1) (quick phase)\n",
	polyQuickDegreeLowest):
printf("with %d double-double and %d double coefficients\n",
	polyQuickDDCoeffsLowest, polyQuickDCoeffsLowest):
printf("Using a %d degree polynomial for middle intervals (2-%d) (accurate phase)\n",
	polyAccurateDegreeMiddle,intervals-2):
printf("with %d triple-double, %d double-double and %d double coefficients\n",
	polyAccurateTDCoeffsMiddle, polyAccurateDDCoeffsMiddle, polyAccurateDCoeffsMiddle):
printf("Using a %d degree polynomial for middle intervals (2-%d) (quick phase)\n",
	polyQuickDegreeMiddle,intervals-2):
printf("with %d double-double and %d double coefficients\n",
	polyQuickDDCoeffsMiddle, polyQuickDCoeffsMiddle):
printf("Using a %d degree polynomial for highest interval (%d) (accurate phase)\n",
	polyAccurateDegreeHighest,intervals):
printf("with %d triple-double, %d double-double and %d double coefficients\n",
	polyAccurateTDCoeffsHighest, polyAccurateDDCoeffsHighest, polyAccurateDCoeffsHighest):
printf("Using a %d degree polynomial for highest interval (%d) (quick phase)\n",
	polyQuickDegreeHighest,intervals):
printf("with %d double-double and %d double coefficients\n",
	polyQuickDDCoeffsHighest, polyQuickDCoeffsHighest):

if true then

printf("Computing polynomials for interval 1 ([%f;%f])\n",bound[0],bound[1]):

f := unapply(convert(series((arcsin(sqrt(x))/sqrt(x) - 1)/x,x=0,300),polynom),x):

p := unapply(eval(numapprox[chebyshev](f(x),x=(bound[0])^2..(bound[1])^2,2^(-127))),x):

polyAccuExact[1] := truncPoly(subs(X=x^2,p(X))*x^3+x,polyAccurateDegreeLowest):

polyAccurate[1] := poly_exact32(polyAccuExact[1],polyAccurateTDCoeffsLowest,polyAccurateDDCoeffsLowest):

epsAccurate[1] := numapprox[infnorm]((polyAccurate[1]/arcsin(x))-1, x=bound[0]..bound[1]):
epsAccurateSpecial := numapprox[infnorm]((polyAccurate[1]/arcsin(x))-1, x=bound[0]..evalf(sin(2^(-18)))):

polyQuickExact[1] := truncPoly(polyAccuExact[1],polyQuickDegreeLowest):
polyQuick[1] := poly_exact2(polyQuickExact[1],polyQuickDDCoeffsLowest):

epsQuick[1] := numapprox[infnorm]((polyQuick[1]/arcsin(x))-1, x=bound[0]..bound[1]):

polyQuickExtraExact := truncPoly(polyAccuExact[1],polyQuickDegreeExtra):
polyQuickExtra := poly_exact2(polyQuickExtraExact,polyQuickDegreeExtra):
epsQuickExtra := numapprox[infnorm]((polyQuickExtra/arcsin(x))-1, x=bound[0]..extrabound):

end if:

for i from 2 to (intervals-1) do

printf("Computing polynomials for interval %d ([%f;%f])\n",i,bound[i-1],bound[i]):
printf("Reduced argument z will be in interval [%1.8e;%1.8e] ([-2^%f,2^%f]),\n",
	bound[i-1]-midpointFloat[i],bound[i]-midpointFloat[i],
	log[2](abs(bound[i-1]-midpointFloat[i])),log[2](abs(bound[i]-midpointFloat[i]))):

f := unapply(arcsin(x+midpointFloat[i]),x):

fhelp := unapply(convert(series((f(x)-arcsin(midpointFloat[i]))/x,x=0,polyAccurateDegreeMiddle*3),polynom),x):

polyAccuExact[i] := numapprox[minimax](fhelp(x),
				x=bound[i-1]-midpointFloat[i]..bound[i]-midpointFloat[i],
				[polyAccurateDegreeMiddle,0],1,'err')*x + nearestDD(evalf(arcsin(midpointFloat[i]))):

polyAccurate[i] := poly_exact32(polyAccuExact[i],polyAccurateTDCoeffsMiddle,polyAccurateDDCoeffsMiddle):

epsAccurate[i] := numapprox[infnorm]((polyAccurate[i]/f(x))-1,
					x=bound[i-1]-midpointFloat[i]..bound[i]-midpointFloat[i]):

polyQuickExact[i] := truncPoly(polyAccuExact[i],polyQuickDegreeMiddle):
polyQuick[i] := poly_exact2(polyQuickExact[i],polyQuickDDCoeffsMiddle):

epsQuick[i] := numapprox[infnorm]((polyQuick[i]/f(x))-1,
			 	   x=bound[i-1]-midpointFloat[i]..bound[i]-midpointFloat[i]):

od:

if true then

printf("Computing polynomials for interval %d ([%f;%f])\n",intervals,bound[intervals-1],bound[intervals]):

g := unapply(((arcsin(1 - x) - Pi/2)/sqrt(2*x)),x):
f := unapply(convert(series(((g(x)+1)/x),x=0,polyAccurateDegreeHighest*4),polynom),x):

polyAccuExact[intervals] := numapprox[minimax](f(x),x=(1-bound[intervals]+2^(-53))..(1-bound[intervals-1]),
						[polyAccurateDegreeHighest-1,0],1,'err')*x-1:

polyAccurate[intervals] := poly_exact32(polyAccuExact[intervals],polyAccurateTDCoeffsHighest,polyAccurateDDCoeffsHighest):

epsAccurate[intervals] := numapprox[infnorm](((unapply(polyAccurate[intervals],x)(x)/g(x))-1),
					x=(1-bound[intervals]+2^(-53))..(1-bound[intervals-1])):

polyQuickExact[intervals] := truncPoly(polyAccuExact[intervals],polyQuickDegreeHighest):
polyQuick[intervals] := poly_exact2(polyQuickExact[intervals],polyQuickDDCoeffsHighest):

epsQuick[intervals] := numapprox[infnorm](((unapply(polyQuick[intervals],x)(x)/g(x))-1),
					x=(1-bound[intervals]+2^(-53))..(1-bound[intervals-1])):

printf("Checking if the polynomial for interval %d is exactly -1 in z = %f...\n",intervals,1-bound[intervals]);

if (unapply(polyAccurate[intervals],x)(1-bound[intervals]) = -1) then
	printf("  Check passed!\n"):
else
	printf("  Check failed!\n"):
end if:

end if:

for i from 1 to intervals do
	printf("Relative error for accurate phase polynomial in interval %d ([%f;%f]) is 2^(%f)\n",
       		i,bound[i-1],bound[i],log[2](abs(epsAccurate[i]))):
	printf("Relative error for quick phase polynomial in interval %d ([%f;%f]) is 2^(%f)\n",
       		i,bound[i-1],bound[i],log[2](abs(epsQuick[i]))):
od:
printf("Relative error for accurate phase polynomial #1 in special interval [0;sin(2^(-18))]) is 2^(%f)\n",
       log[2](abs(epsAccurateSpecial))):

printf("Relative error for quick phase extra case truncated polynomial #1 in special interval [0;%f]) is 2^(%f)\n",
       extrabound,log[2](abs(epsQuickExtra))):

(PiHalfH, PiHalfM, PiHalfL) := hi_mi_lo(evalf(Pi/2)):

epsPiDD := evalf(((PiHalfH + PiHalfM) - Pi/2)/(Pi/2)):
epsPiTD := evalf(((PiHalfH + PiHalfM + PiHalfL) - Pi/2) / (Pi/2)):

printf("Relative error for storing Pi/2 as a double-double is 2^(%f)\n",evalf(log[2](abs(epsPiDD)))):
printf("Relative error for storing Pi/2 as a triple-double is 2^(%f)\n",evalf(log[2](abs(epsPiTD)))):

# Ce qui suit est pifometrique et doit etre prouve en Gappa ensuite

arithmeticalErrorQuick[1] := 2^(-61):
arithmeticalErrorQuick[2] := 2^(-61):
arithmeticalErrorQuick[3] := 2^(-61):
arithmeticalErrorQuick[4] := 2^(-61):
arithmeticalErrorQuick[5] := 2^(-61):
arithmeticalErrorQuick[6] := 2^(-61):
arithmeticalErrorQuick[7] := 2^(-61):
arithmeticalErrorQuick[8] := 2^(-61):
arithmeticalErrorQuick[9] := 2^(-61):
arithmeticalErrorQuick[10] := 2^(-68):

arithmeticalErrorQuickExtra := 2^(-80):

for i from 1 to intervals do
	estimatedOverallEpsQuick[i] := abs(epsQuick[i]) +
				       abs(arithmeticalErrorQuick[i]) +
                                       abs(epsQuick[i]) * abs(arithmeticalErrorQuick[i]):
	printf("Relative quick phase overall error bound to show in Gappa for interval %d ([%f;%f]) is 2^(%f)\n",
		i,bound[i-1],bound[i],log[2](abs(estimatedOverallEpsQuick[i]))):
od:

estimatedOverallEpsQuickExtra := abs(epsQuickExtra) +
				 abs(arithmeticalErrorQuickExtra) +
                                 abs(epsQuickExtra) * abs(arithmeticalErrorQuickExtra):
printf("Relative quick phase overall error bound to show for extra truncted poly in interval [0;%f]) is 2^(%f)\n",
	extrabound,log[2](abs(estimatedOverallEpsQuickExtra))):

printf("Write tables...\n"):

filename:="TEMPASIN/asin-td.h":
fd:=fopen(filename, WRITE, TEXT):

fprintf(fd, "#include \"crlibm.h\"\n#include \"crlibm_private.h\"\n"):

fprintf(fd, "\n/* File generated by maple/asin-td.mpl */\n\n"):

printf("Write table with bounds\n"):

fprintf(fd, "/* High order words of interval bounds (low order word is 0) */\n"):
for i from 1 to (intervals-1) do
	heb := ieeehexa(bound[i]):
	fprintf(fd, "\#define BOUND%d 0x%s\n",i,heb[1]):
od:

heb := ieeehexa(extrabound):
fprintf(fd, "\#define EXTRABOUND 0x%s\n",heb[1]):

printf("Write additional constants\n"):

fprintf(fd, "\n\n/* Pi/2 as a triple-double*/\n"):
fprintf(fd, "\#define PIHALFH %1.50e\n",PiHalfH):
fprintf(fd, "\#define PIHALFM %1.50e\n",PiHalfM):
fprintf(fd, "\#define PIHALFL %1.50e\n",PiHalfL):

printf("Write table with midpoints and polynomial coefficients\n"):
k := 0:
for i from 0 to polyAccurateDegreeLowest do
	(hi,mi,lo) := hi_mi_lo(coeff(polyAccurate[1],x,i)):
	if ((abs(hi) = 1.0) and (mi = 0) and (lo = 0)) then
		printf(
		"Coefficient %d of interval 1 polynomial is exactly %f and will not be stored in the table\n",i,hi):
	else
	g := 0;
	if (hi <> 0) then
		if (i <= polyQuickDegreeLowest) then
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyLowC%dh, quickPolyLowC%dh */",hi,k,i,i):
		else
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyLowC%dh */",hi,k,i):
		end if:
		k := k + 1:
	end if:
	if (mi <> 0) then
		if (i <= polyQuickDDCoeffsLowest) then
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyLowC%dm, quickPolyLowC%dl */",mi,k,i,i):
		else
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyLowC%dm */",mi,k,i):
		end if:
		k := k + 1:
	end if:
	if (lo <> 0) then
		tbl[k] := sprintf("%1.50e, \t/* %d, accPolyLowC%dl */",lo,k,i):
		k := k + 1:
	end if:
	end if:
od:
tbl[k] := sprintf("%1.50e, \t/* %d, RN rounding constant quick poly low*/",
		compute_rn_constant(estimatedOverallEpsQuick[1]),k):
k := k + 1:
tbl[k] := sprintf("%1.50e, \t/* %d, RD rounding constant quick poly low*/",
		estimatedOverallEpsQuick[1],k):
k := k + 1:
printf("Table for interval 1 written\n"):
for l from 2 to (intervals-1) do
	tbl[k] := sprintf("%1.50e, \t/* %d, midpoint in interval %d*/",midpointFloat[l],k,l):
	tblidx[l] := k;
	k := k + 1;
	for i from 0 to polyAccurateDegreeMiddle do
		(hi,mi,lo) := hi_mi_lo(coeff(polyAccurate[l],x,i)):
		if ((abs(hi) = 1.0) and (mi = 0) and (lo = 0)) then
			printf(
		"Coefficient %d of interval %d polynomial is exactly %f and will not be stored in the table\n",i,l,hi):
		else
		g := 0;
		if (hi <> 0) then
			if (i <= polyQuickDegreeMiddle) then
				tbl[k] := sprintf(
					"%1.50e, \t/* %d, accPolyMid%dC%dh, quickPolyMid%dC%dh */",hi,k,l,i,l,i):
			else
				tbl[k] := sprintf("%1.50e, \t/* %d, accPolyMid%dC%dh */",hi,k,l,i):
			end if:
			k := k + 1:
		end if:
		if (mi <> 0) then
			if (i <= polyQuickDDCoeffsMiddle) then
				tbl[k] := sprintf(
					"%1.50e, \t/* %d, accPolyMid%dC%dm, quickPolyMid%dC%dl */",mi,k,l,i,l,i):
			else
				tbl[k] := sprintf("%1.50e, \t/* %d, accPolyMid%dC%dm */",mi,k,l,i):
			end if:
			k := k + 1:
		end if:
		if (lo <> 0) then
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyMid%dC%dl */",lo,k,l,i):
			k := k + 1:
		end if:
		end if:
	od:
	tbl[k] := sprintf("%1.50e, \t/* %d, RN rounding constant quick poly middle %d*/",
			compute_rn_constant(estimatedOverallEpsQuick[l]),k,l):
	k := k + 1:
	tbl[k] := sprintf("%1.50e, \t/* %d, RD rounding constant quick poly middle %d*/",
			estimatedOverallEpsQuick[l],k,l):
	k := k + 1:
	printf("Table for interval %d written\n",l):
od:
tblidx[intervals] := k:
for i from 0 to polyAccurateDegreeHighest do
	(hi,mi,lo) := hi_mi_lo(coeff(polyAccurate[intervals],x,i)):
	if ((abs(hi) = 1.0) and (mi = 0) and (lo = 0)) then
		printf(
	"Coefficient %d of interval %d polynomial is exactly %f and will not be stored in the table\n",i,intervals,hi):
	else
	g := 0;
	if (hi <> 0) then
		if (i <= polyQuickDegreeHighest) then
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyHighC%dh, quickPolyHighC%dh */",hi,k,i,i):
		else
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyHighC%dh */",hi,k,i):
		end if:
		k := k + 1:
	end if:
	if (mi <> 0) then
		if (i <= polyQuickDDCoeffsHighest) then
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyHighC%dm, quickPolyHighC%dl */",mi,k,i,i):
		else
			tbl[k] := sprintf("%1.50e, \t/* %d, accPolyHighC%dm */",mi,k,i):
		end if:
		k := k + 1:
	end if:
	if (lo <> 0) then
		tbl[k] := sprintf("%1.50e, \t/* %d, accPolyHighC%dl */",lo,k,i):
		k := k + 1:
	end if:
	end if:
od:
tbl[k] := sprintf("%1.50e, \t/* %d, RN rounding constant quick poly high*/",
		compute_rn_constant(estimatedOverallEpsQuick[intervals]),k):
k := k + 1:
tbl[k] := sprintf("%1.50e, \t/* %d, RD rounding constant quick poly high*/",
 		estimatedOverallEpsQuick[intervals],k):
k := k + 1:
printf("Table for interval %d written\n",intervals):
tbllen := k:
printf("The whole table has %d entries, so uses %d bytes of memory\n",tbllen,tbllen*8):
fprintf(fd,"\n\n/* Indices to the following table */\n"):
for i from 2 to intervals do
	fprintf(fd,"\#define TBLIDX%d %d\n",i,tblidx[i]):
od:
fprintf(fd, "\n\n/* Table with midpoints and polynomial coefficients */\n"):
fprintf(fd, "static const double tbl[%d] = {\n",tbllen):
for i from 0 to (tbllen - 1) do
	fprintf(fd, "%s\n",tbl[i]):
od:
fprintf(fd, "};\n\n"):

fclose(fd):

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


######################################################################
# An ordering of a set A is encoded as a list containing each element
# of A precisely once.

`is_element/ord` := (A::set) -> proc(R)
 type(R,list) and nops(R) = nops(A) and {op(R)} = A;
end;

`is_equal/ord` := (A::set) -> (R,S) -> evalb(R = S);

`is_leq/ord` := NULL;

`random_element/ord` := (A::set) -> () -> combinat[randperm]([op(A)]);

`list_elements/ord` := (A::set) -> combinat[permute](sort([op(A)]));

`count_elements/ord` := (A::set) -> nops(A)!;

`rank_table/ord` := (A::set) -> proc(R)
 local i;
 table([seq(R[i] = i, i = 1 .. nops(R))]):
end:


# Vierachsroboter implizit
# Initialisierung
restart:
kin_constraints_exist := true: # Für Speicherung
;
with(StringTools): # Für Zeitausgabe
with(LinearAlgebra):
with(codegen):
with(CodeGeneration):
codegen_act := true:
codegen_opt := 1: # Geringerer Optimierungsgrad. Sonst zu lange.
codegen_debug := 0: # Zur Code-Generierung auch für Nicht-Inert-Ausdrücke
;
read "../helper/proc_MatlabExport":
read "../transformation/proc_rotx":
read "../transformation/proc_roty":
read "../transformation/proc_rotz":
read "../transformation/proc_trotz":
read "../transformation/proc_transl":
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
read "../helper/proc_intersect_circle":
with(RealDomain): # Schränkt alle Funktionen auf den reellen Bereich ein. Muss nach Definition von MatlabExport kommen. Sonst geht dieses nicht.
;
read "../robot_codegen_definitions/robot_env_IC":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name_OL):
# Ergebnisse der Kinematik laden
read sprintf("../codeexport/%s/tmp/kinematics_floatb_%s_rotmat_maple.m", robot_name_OL, base_method_name);
read "../robot_codegen_definitions/robot_env_IC":
Trf := Trf:
Trf_c := Trf_c:
Trf
;
# VGK Gelb 2-7-11-14-6
# Schleife (1-6)-(6-14)
T_1_14 := combine( Matrix(Trf(1..4,1..4, 6)) . Matrix(Trf(1..4,1..4,14))):
# Schleife (1-2)-(2-7)-(7-11)
T_1_11:= combine( Matrix(Trf(1..4,1..4, 2)) . Matrix(Trf(1..4,1..4,7)) . Matrix(Trf(1..4,1..4,11))):
h1t := T_1_14(1..3,4) - T_1_11(1..3,4);

#tmp := Transpose( Matrix(T_1_14(1..3,1..3)) ) . Matrix(T_1_11(1..3,1..3));  nur anzeigen lassen für h1r
;
#combine(tmp);# nur anzeigen lassen für h1r
;
h1r := -(-qJ6(t)+qJ2(t)+qJ7(t)+phi711+qJ11(t))+Pi/2:
# VGK PINK 2-3-12-15-9-8-2
# Schleife (2-3)-(3-12)
T_2_12 := combine(Matrix(Trf(1..4,1..4, 3)) . Matrix(Trf(1..4,1..4,12))):
# Schleife (2-8)-(8-9)-(9-15)
T_2_15:= combine(Matrix(Trf(1..4,1..4, 8)) . Matrix(Trf(1..4,1..4,9)).Matrix(Trf(1..4,1..4, 15))):
h2t := T_2_12(1..3,4) - T_2_15(1..3,4):
tmp := Transpose( Matrix(T_2_12(1..3,1..3)) ) . Matrix(T_2_15(1..3,1..3));  # nur anzeigen lassen für h1r
;
 combine(tmp); # nur anzeigen lassen für h1r
;
h2r:=(qJ3(t)+phi312+qJ12(t)-qJ8(t)-qJ9(t))+3*Pi/2:
# VGK GRÜN 2-3-4-13-16-10-7-2
# Schleife (2-3)-(3-4)-(4-13)
T_2_13 := combine( Matrix(Trf(1..4,1..4, 3)) . Matrix(Trf(1..4,1..4,4)) . Matrix(Trf(1..4,1..4,13))):
# Schleife (2-7)-(7-10)-(10-16)
T_2_16:= combine( Matrix(Trf(1..4,1..4, 7)) . Matrix(Trf(1..4,1..4,10)).Matrix(Trf(1..4,1..4,16)) ):
h3t := T_2_13(1..3,4) - T_2_16(1..3,4):
#tmp := Transpose( Matrix(T_2_13(1..3,1..3)) ) . Matrix(T_2_16(1..3,1..3));  nur anzeigen lassen für h2r
;
#combine(tmp);  nur anzeigen lassen für h3r
;
h3r:=-(qJ3(t)+qJ4(t)+phi413+qJ13(t)-qJ7(t)+phi710-qJ10(t))+5*Pi/2:
# Zusammenstellen aller Zwangsbedingungen
implconstr_t := <h1t([1, 3],1);h2t([1, 2],1);h3t([1, 2],1); h1r; h2r; h3r>; # TODO: In h1r, h2r, h3r muss das richtige drinstehen.
implconstr_s := convert_t_s(implconstr_t):
# Exportiere Code für folgende Skripte
kin_constraints_exist:=true:
save implconstr_t, implconstr_s, kin_constraints_exist, sprintf("../codeexport/%s/tmp/kinematic_constraints_implicit_maple.m", robot_name):
# Exportieren des vollständigen Ausdruckes
if codegen_act then
  MatlabExport(implconstr_s, sprintf("../codeexport/%s/tmp/kinconstr_impl_matlab.m", robot_name), 2):
end if:
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( implconstr_s )):
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_implicit_constraints_symbols_list_maple", robot_name):
MatlabExport(Transpose(kc_symbols), sprintf("../codeexport/%s/tmp/kinematic_implicit_constraints_symbols_list_matlab.m", robot_name), 2):


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

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


#int fact (int n) {
#  if(n != 1)
#    return foo(n - 1);
#  else return 1;
#}
func $foo varargs ( var %i i32, ... ) i32 {
  return (dread i32 %i) }
func $foo1 varargs ( ... ) i32 {
  return (constval i32 99) }

func $fact (
 var %n i32) i32 {
 if (ne i32 i32 (dread i32 %n, constval i32 1)) {
    call &foo(
      sub i32 (dread i32 %n, constval i32 1))
    return (regread i32 %%retval)}
   else {
     return (constval i32 1) } }
 # EXEC: %irbuild Main.mpl
 # EXEC: %irbuild Main.irb.mpl
 # EXEC: %cmp Main.irb.mpl Main.irb.irb.mpl


make_example_surfaces := proc()
 global example_surface;
 local P,T,R,dp,a,u,i,j,k;

 dp := (u,v) -> add(u[i] * v[i],i=1..3):
 R := (x) -> [-x[1]/2+sqrt(3)*x[2]/2,-sqrt(3)*x[1]/2-x[2]/2,x[3]]:

 P := table():
 P[0] := `map/pants`(x -> x,`base/pants`):
 for i from 1 to 5 do P[i] := `sprout/pants`(P[i-1],modp(i-1,3)+1); od:
 T := table():
 T[0] := `pants_joiner/pants_tube`(P[0],2,P[1],3):
 T[1] := `pants_joiner/pants_tube`(P[2],1,P[3],2):
 T[2] := `pants_joiner/pants_tube`(P[4],3,P[5],1):
 example_surface[0] := display(
  seq(`rough_plot/pants`(op(X)),X in entries(P)),
  seq(`plot/pants_tube`(op(X)),X in entries(T))
 ):

 P := table():
 T := table():
 P[0] := eval(`base/pants`):
 P[1] := `sprout/pants`(P[0],1):
 T[0] := `pants_joiner/pants_tube`(P[0],2,P[1],3):
 T[1] := `pants_joiner/pants_tube`(P[0],3,P[1],2):
 example_surface[1] := display(
  seq(`rough_plot/pants`(op(X)),X in entries(P)),
  seq(`plot/pants_tube`(op(X)),X in entries(T))
 ):

 P := table(): T := table():
 P[0] := eval(`base/pants`):
 P[1] := `sprout/pants`(P[0],1):
 P[2] := `map/pants`((x) -> x +~ [0,3,0],P[0]):
 P[3] := `map/pants`((x) -> x +~ [0,3,0],P[1]):
 T[0] := `pants_joiner/pants_tube`(P[0],2,P[2],3):
 T[1] := `pants_joiner/pants_tube`(P[1],3,P[3],2):
 T[3] := `pants_joiner/pants_tube`(P[0],3,P[1],2):
 T[4] := `pants_joiner/pants_tube`(P[2],2,P[3],3):
 example_surface[2] := display(
  seq(`rough_plot/pants`(op(X)),X in entries(P)),
  seq(`plot/pants_tube`(op(X)),X in entries(T))
 ):

 P := table(): T := table():
 P[0] := eval(`base/pants`):
 P[1] := `sprout/pants`(P[0],1):
 T[0] := `pants_joiner/pants_tube`(P[0],2,P[0],3):
 T[1] := `pants_joiner/pants_tube`(P[1],2,P[1],3):
 example_surface[3] := display(
  seq(`rough_plot/pants`(op(X)),X in entries(P)),
  seq(`plot/pants_tube`(op(X)),X in entries(T))
 ):

 a := 2:
 u := table():
 P := table():
 T := table():
 u[0] := simplex_embedding([1,0,0,0]):
 u[1] := simplex_embedding([0,1,0,0]):
 u[2] := simplex_embedding([0,0,1,0]):
 u[3] := simplex_embedding([0,0,0,1]):
 for i from 0 to 3 do
  P[i] := table([
   "centre" = a *~ u[i],
   "circle_centres" = [seq(simplify(a *~ u[i] +~ (u[j] -~ dp(u[j],u[i]) *~ u[i]) *~ (sqrt(27/32))),j in {0,1,2,3} minus {i})],
   "top" = (a + 1/2) *~ u[i]
  ]);
 od:
 T[0,1] := `pants_joiner/pants_tube`(P[0],1,P[1],1):
 T[0,2] := `pants_joiner/pants_tube`(P[0],2,P[2],1):
 T[0,3] := `pants_joiner/pants_tube`(P[0],3,P[3],1):
 T[1,2] := `pants_joiner/pants_tube`(P[1],2,P[2],2):
 T[1,3] := `pants_joiner/pants_tube`(P[1],3,P[3],2):
 T[2,3] := `pants_joiner/pants_tube`(P[2],3,P[3],3):
 example_surface[4] := display(
  seq(`rough_plot/pants`(op(X)),X in entries(P)),
  seq(`plot/pants_tube`(op(X)),X in entries(T)),
  axes=none,scaling=constrained
 ):

 P := table():
 T := table():
 a := 2:
 for i in [-1,1] do
  for j in [-1,1] do
   for k in [-1,1] do
    P[i,j,k] := table([
     "centre" = a *~ [i,j,k],
     "circle_centres" = evalf(map(x -> (a *~ [i,j,k] +~ x /~ sqrt(8)),
			    [[-2*i,j,k],[i,-2*j,k],[i,j,-2*k]])),
     "top" = evalf((a + 1/(2*sqrt(3))) *~ [i,j,k])
    ]);
   od:
  od:
 od:
 T[ 0, 1, 1] := `pants_joiner/pants_tube`(P[ 1, 1, 1],1,P[-1, 1, 1],1):
 T[ 0, 1,-1] := `pants_joiner/pants_tube`(P[ 1, 1,-1],1,P[-1, 1,-1],1):
 T[ 0,-1, 1] := `pants_joiner/pants_tube`(P[ 1,-1, 1],1,P[-1,-1, 1],1):
 T[ 0,-1,-1] := `pants_joiner/pants_tube`(P[ 1,-1,-1],1,P[-1,-1,-1],1):
 T[ 1, 0, 1] := `pants_joiner/pants_tube`(P[ 1, 1, 1],2,P[ 1,-1, 1],2):
 T[ 1, 0,-1] := `pants_joiner/pants_tube`(P[ 1, 1,-1],2,P[ 1,-1,-1],2):
 T[-1, 0, 1] := `pants_joiner/pants_tube`(P[-1, 1, 1],2,P[-1,-1, 1],2):
 T[-1, 0,-1] := `pants_joiner/pants_tube`(P[-1, 1,-1],2,P[-1,-1,-1],2):
 T[ 1, 1, 0] := `pants_joiner/pants_tube`(P[ 1, 1, 1],3,P[ 1, 1,-1],3):
 T[ 1,-1, 0] := `pants_joiner/pants_tube`(P[ 1,-1, 1],3,P[ 1,-1,-1],3):
 T[-1, 1, 0] := `pants_joiner/pants_tube`(P[-1, 1, 1],3,P[-1, 1,-1],3):
 T[-1,-1, 0] := `pants_joiner/pants_tube`(P[-1,-1, 1],3,P[-1,-1,-1],3):
 example_surface[5] := display(
  seq(`rough_plot/pants`(op(X)),X in entries(P)),
  seq(`plot/pants_tube`(op(X)),X in entries(T)),
  axes=none,scaling=constrained
 ):

 return eval(example_surface);
end:


make_alternating_five := proc()
 global alternating_five;
 local G,x2,y2,z2,x3,x5,y5,id,o,oo,inv,idm,om,oom,E,ccl,
       t0,t1,i,j,k,l,g,h,w,m,x,u0,u1,u2,u3,u,v,M,theta;

 G := table():

 x2 := [2,1,4,3,5];
 y2 := [3,4,1,2,5];
 z2 := [1,3,2,5,4];
 x3 := [2,3,1,4,5];
 x5 := [3,5,4,2,1];
 y5 := [2,3,4,5,1];

 id := [1,2,3,4,5];
 o  := (u,v) -> [seq(u[v[i]],i=1..5)];
 oo := proc()
  if   nargs = 0 then return(id);
  elif nargs = 1 then return(args[1]);
  elif nargs = 2 then return(o(args));
  else return o(args[1],oo(args[2..-1]));
  fi;
 end:
 inv := proc(g)
  local gi;
  gi := table():
  for i from 1 to 5 do gi[g[i]] := i; od;
  return [seq(gi[i],i=1..5)];
 end:

 G["id"] := id;
 G["o"]  := eval(o);
 G["oo"]  := eval(oo);
 G["inv"] := eval(inv);

 G["x2"] := x2;  G["x2c"] := convert(x2,disjcyc);
 G["y2"] := y2;  G["y2c"] := convert(y2,disjcyc);
 G["z2"] := z2;  G["z2c"] := convert(z2,disjcyc);
 G["x3"] := x3;  G["x3c"] := convert(x3,disjcyc);
 G["x5"] := x5;  G["x5c"] := convert(x5,disjcyc);
 G["y5"] := y5;  G["y5c"] := convert(y5,disjcyc);

 G["H"] := table():

 G["H"][ 1] := [id];
 G["H"][ 2] := [id,x2];
 G["H"][ 3] := [id,x3,o(x3,x3)];
 G["H"][ 4] := [id,x2,y2,o(x2,y2)];
 G["H"][ 5] := [id,x5,o(x5,x5),oo(x5 $ 3),oo(x5 $ 4)];
 G["H"][ 6] := [seq(seq(o(u,v),u in [id,z2]),v in G["H"][3])];
 G["H"][10] := [seq(seq(o(u,v),u in G["H"][ 2]),v in G["H"][5])];
 G["H"][12] := [seq(seq(o(u,v),u in G["H"][ 4]),v in G["H"][3])];
 G["H"][60] := [seq(seq(o(u,v),u in G["H"][12]),v in G["H"][5])];

 E := G["H"][60];
 G["elements"] := E;

 G["element_index"] := table();
 for i from 1 to 60 do
  G["element_index"][E[i]] := i;
 od:

 G["gens_rule"] := {X2 = x2, Y2 = y2, Z2 = z2, X3 = x3, X5 = x5, Y5 = y5};

 # words in x2, y2, z2 for all elements
 G["words_a"] := [
 [],[X2],[Y2],[X2,Y2],[X2,Z2,Y2,Z2,X2,Z2],[Z2,Y2,Z2,X2,Z2],[Z2,Y2,Z2,X2,Z2,X2],
 [Y2,Z2,Y2,Z2,X2,Z2],[Y2,Z2,X2,Z2,Y2,Z2],[Z2,X2,Z2,Y2,Z2,Y2],[Z2,X2,Z2,Y2,Z2],
 [X2,Z2,X2,Z2,Y2,Z2],[X2,Y2,Z2,Y2],[Y2,Z2,Y2],[X2,Z2,Y2],[Z2,Y2],[X2,Y2,Z2,Y2,Z2,X2,Y2],
 [Y2,Z2,Y2,Z2,X2,Y2],[X2,Z2,Y2,Z2,X2,Y2],[Z2,Y2,Z2,X2,Y2],[X2,Y2,Z2,X2,Z2],[Y2,Z2,X2,Z2],
 [X2,Z2,X2,Z2],[Z2,X2,Z2],[X2,Y2,Z2,X2,Z2,Y2],[Y2,Z2,X2,Z2,Y2],[X2,Z2,X2,Z2,Y2],
 [Z2,X2,Z2,Y2],[X2,Y2,Z2],[Y2,Z2],[X2,Z2],[Z2],[X2,Y2,Z2,Y2,Z2,X2],[Y2,Z2,Y2,Z2,X2],
 [X2,Z2,Y2,Z2,X2],[Z2,Y2,Z2,X2],[Z2,Y2,Z2,Y2,Z2,X2,Z2],[X2,Z2,Y2,Z2,Y2,Z2,X2,Z2],
 [Z2,X2,Z2,X2,Y2],[X2,Z2,X2,Z2,X2,Y2],[Z2,X2],[X2,Z2,X2],[Y2,Z2,X2],[X2,Y2,Z2,X2],
 [X2,Z2,Y2,Z2],[Z2,Y2,Z2],[X2,Y2,Z2,Y2,Z2],[Y2,Z2,Y2,Z2],[Y2,Z2,X2,Y2],[Z2,X2,Y2,Z2],
 [Z2,X2,Y2],[X2,Z2,X2,Y2],[Z2,Y2,Z2,Y2],[X2,Z2,Y2,Z2,Y2],[Y2,Z2,Y2,Z2,Y2],
 [X2,Y2,Z2,Y2,Z2,Y2],[X2,Z2,X2,Z2,X2],[Z2,X2,Z2,X2],[X2,Y2,Z2,X2,Z2,X2],[Y2,Z2,X2,Z2,X2]];

 # words in x2, y2, x3, x5 for all elements
 G["words_b"] := [seq(seq(seq(seq([X2$i,Y2$j,X3$k,X5$l],i=0..1),j=0..1),k=0..2),l=0..4)];

 G["rels"] := [
  [X2$2],[Y2$2],[Z2$2],[X3$3],[X5$5],[Y5$5],
  map(op,[[X2,Y2]$2]),map(op,[[X2,Y2,Z2]$3]),
  map(op,[[Z2,X2,Z2,Y2]$3]),map(op,[[X2,Z2]$5]),map(op,[[Y2,Z2]$5]),
  [X3,Y2,Z2,X2,Z2,Y2,Z2],[Y5,Y2,Z2,X2,Z2,X2],[X5,Y2,X5,X5,X5,X3,X3]];

 ccl := (x) -> sort([op({seq(oo(g,x,inv(g)), g in E)})]);

 G["conjugacy_classes"] := [
  ccl(id),
  ccl(x2),
  ccl(x3),
  ccl(o(x5,x5)),
  ccl(x5)
 ];

 G["conjugacy_class_index"] := table();
 for i from 1 to 5 do
  for g in G["conjugacy_classes"][i] do
   G["conjugacy_class_index"][g] := i;
  od;
 od;

 G["element_order"] := table();

 for g in E do
  h := g;
  i := 1;
  while h <> id do i := i + 1; h := o(g,h); od:
  G["element_order"][g] := i;
 od:

 t0 := (sqrt(5)+1)/2;
 t1 := (sqrt(5)-1)/2;

 # Dodecahedron representation

 idm := [[1,0,0],[0,1,0],[0,0,1]];
 om := (u,v) -> expand(convert(Matrix(u) . Matrix(v),listlist));
 oom := proc()
  if   nargs = 0 then return(idm);
  elif nargs = 1 then return(args[1]);
  elif nargs = 2 then return(om(args));
  else return om(args[1],oom(args[2..-1]));
  fi;
 end:

 G["idm"] := idm;
 G["om"]  := eval(om);
 G["oom"] := eval(oom);

 G["matrix_gens_rule"] := {
   X1 = [[ 1,0,0],[0, 1,0],[0,0, 1]],
   X2 = [[ 1,0,0],[0,-1,0],[0,0,-1]],
   Y2 = [[-1,0,0],[0,-1,0],[0,0, 1]],
   Z2 = [[t1,-t0,-1],[-t0,-1,t1],[-1,t1,-t0]] /~ 2,
   X3 = [[0,0,1],[1,0,0],[0,1,0]],
   X5 = [[t1,-t0,1],[t0,1,t1],[-1,t1,t0]] /~ 2,
   Y5 = [[t0,1,-t1],[-1,t1,-t0],[-t1,t0,1]] /~ 2
 };

 G["matrix"] := table();
 G["axis"]   := table();
 G["angle"]  := table();

 for i from 1 to 60 do
  g := E[i];
  G["matrix"][g] := oom(op(subs(G["matrix_gens_rule"],G["words_b"][i])));
  if i = 1 then
   G["axis"][g] := [0,0,0];
   G["angle"][g] := 0;
  else
   M := Matrix(G["matrix"][g]);
   u0 := convert(NullSpace(M - IdentityMatrix(3))[1],list);
   u0 := simplify(expand(rationalize(u0 /~ sqrt(add(u0[j]^2,j=1..3)))));
   u1 := [1,2,3];
   u1 := u1 -~ add(u1[j] * u0[j],j=1..3) *~ u0;
   u1 := simplify(expand(rationalize(u1)));
   u2 := [u0[2] * u1[3] - u0[3] * u1[2],
          u0[3] * u1[1] - u0[1] * u1[3],
          u0[1] * u1[2] - u0[2] * u1[1]];
   u2 := simplify(expand(rationalize(u2)));
   u3 := simplify(expand(rationalize(convert(M . Vector(u1), list))));

   theta := evalf(arctan(add(u3[j] * u2[j],j=1..3),add(u3[j] * u1[j],j=1..3)));
   theta := round(evalf(60 * theta / Pi)) * Pi / 60;

   if evalf(theta) < 0 then u0 := -~ u0; theta := -theta; fi;
   G["axis"][g] := u0;
   G["angle"][g] := theta;
  fi;
 od;

 alternating_five := eval(G);
 return eval(G);
end:

make_alternating_five():

check_alternating_five := proc()
 local A5,f,fm,is_rot,ok,i,j,ij,g,h,gh,gm,hm,ghm0,ghm1;

 A5 := eval(make_alternating_five()):

 f := (u) -> A5["oo"](op(subs(A5["gens_rule"],u)));
 fm := (u) -> A5["oom"](op(subs(A5["matrix_gens_rule"],u)));

 _ASSERT(
  evalb({op(map(f,A5["rels"]))} = {A5["id"]}),
  "permutation relations");

 _ASSERT(
  evalb({op(map(fm,A5["rels"]))} = {A5["idm"]}),
  "matrix relations");

 _ASSERT(
  `and`(seq(evalb(f(A5["words_a"][i]) = A5["elements"][i]),i=1..60)),
  "words_a");

 _ASSERT(
  `and`(seq(evalb(f(A5["words_b"][i]) = A5["elements"][i]),i=1..60)),
  "words_b");

 is_rot := proc(m)
  local M,N;
  M := Matrix(m);
  if (simplify(expand(Determinant(M) - 1)) <> 0) then
   return false;
  fi;

  N := map(simplify,map(expand,Transpose(M) . M - IdentityMatrix(3)));
  if not(Equal(N,Matrix(3,3))) then return false; fi;
  return true;
 end:

 _ASSERT(
  `and`(seq(is_rot(A5["matrix"][g]),g in A5["elements"])),
  "matrices are rotations"
 );

 ok := true;
 for i from 1 to 60 do
  for j from 1 to 60 do
   g := A5["elements"][i];
   h := A5["elements"][j];
   gh := A5["o"](g,h);
   ij := A5["element_index"][gh];
   gm := A5["matrix"][g];
   hm := A5["matrix"][h];
   ghm0 := A5["matrix"][gh];
   ghm1 := A5["om"](gm,hm);
   if ghm0 <> ghm1 then ok := false; break; fi;
  od:
  if not(ok) then break; fi;
 od:

 _ASSERT(ok,"matrix representation is a homomorphism");
end:


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

`eta/cubes` := (k::posint) -> (A::set) ->
 `if`(nops(A) = 1,table(op(A) = `id/single_cubes`(k)),FAIL);

`gamma/cubes` := (k::posint) -> (A::set,B::set) -> (p) -> proc(f,g)
 local a,h;

 h := table();
 for a in A do
  h[a] := `compose/single_cubes`(k)(f[p[a]],g[p[a]][a]);
 od;
 return eval(h);
end;


$ifndef _TEQ_SOL_
$define _TEQ_SOL_

$include "Utils.mpl"

TeqSol:=module()
    option object;
    export
            rsol,           # 对应特解
            teq,            # 变换方程
            teqInd,
            tsols,          # 变换方程的解
            tcons,          # 解对应的条件

            printTsol::static,
            getNSols::static,
            getRep::static,
            ModuleApply::static,    # 构造函数
            hasSol::static,         # 判断是否有解
            getCon::static;         # 给出最简约束条件

    ModuleApply:=proc(spec,ESC)
        local s,k;
        s:=Object(TeqSol);
        s:-rsol:=spec;
        s:-teq:=[ESC[1][1],ESC[2][1]];
        s:-teqInd:=[1$numelems(ESC[1][2]),2$numelems(ESC[2][2])];
        s:-tsols:=[ESC[1][2][],ESC[2][2][]];
        s:-tcons:=[ESC[1][3][],ESC[2][3][]];
        return s;
    end proc:

    hasSol:=proc(s::TeqSol)
        return ormap(x->evalb(x<>[]),s:-tsols);
    end proc:

    printTsol:=proc(s::TeqSol)
        local i,n:=numelems(s:-tsols);
        printf("=======================================\n");
        printf("特解\n");
        print(s:-rsol);
        printf("变换方程的解\n");
        for i from 1 to n do
            if s:-teqInd[i]=1 then
                printf("正向\n");
            else
                printf("逆向\n");
            end if;
            print(s:-tsols[i]);
            print(s:-tcons[i]);
        end do;
        printf("=======================================\n");
        return;
    end proc:

    getNSols:=proc(s::TeqSol)
        return numelems(s:-tsols);
    end proc:

    getRep:=proc(s::TeqSol)
        return add(v[i]*s:-rsol[i],i=1..numelems(s:-rsol));
    end proc:

end module:

$endif


######################################################################
# This section is about the suboperad of little 1-cubes where the
# subintervals fill the whole interval.

`is_element/one_cubes_prime` := (A::set) -> proc(f)
 local X,n,i;
 global reason;

 if not(`is_element/cubes`(1)(A)(f)) then
  reason := [convert(procname,string),"f is not a 1-cube for A",f,A,reason];
  return false;
 fi;

 X := map(a -> map(op,f[a]),[op(A)]);
 X := sort(X,(u,v) -> evalb(u[1]<v[1]));
 n := nops(A);
 if X[1][1] <> 0 then
  reason := [convert(procname,string),"The first interval does not start at 0",X[1]];
  return false;
 fi;
 if X[n][2] <> 1 then
  reason := [convert(procname,string),"The last interval does not end at 1",X[n]];
  return false;
 fi;

 for i from 1 to n-1 do
  if X[i][2] <> X[i+1][1] then
   reason := [convert(procname,string),"Successive intervals do not touch",X[i],X[i+1]];
   return false;
  fi;
 od;

 return true;
end;

`is_equal/one_cubes_prime` := (A::set) -> proc(f1,f2)
 `is_equal/cubes`(1)(A)(f1,f2);
end:

`is_leq/one_cubes_prime` := NULL;

`random_element/one_cubes_prime` := (A::set) -> proc()
 local d,n,u,i,r,R,xy;

 d := 12;
 n := nops(A);
 u := table();
 u[0] := 0;
 for i from 1 to n do
  u[i] := u[i-1] + rand(1..d)();
 od;
 r := u[n];
 for i from 1 to n do u[i] := u[i]/r; od;

 R := `random_element/ord`(A)();
 xy := table();
 for i from 1 to n do
  xy[R[i]] := [[u[i-1]],[u[i]]];
 od;

 return eval(xy);
end;

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