# This file sets up the letters of the alphabet as one-dimensional simplicial
# complexes.

letters := table():

alphabet_list := [["A","B","C","D","E"],
                  ["F","G","H","I","J"],
                  ["K","L","M","N","O"],
                  ["P","Q","R","S","T"],
                  ["U","V","W","X","Y"]]:

alphabet_type_list := [
 ["C","G","L","M","N","S","U","V","W"],
 ["E","F","J","T","Y"],
 ["H","I"],
 ["K","X"],
 ["O","D","A","Q"],
 ["B"]
]:

set_map := proc(T)
 local P,e,s,t;
 T["map"] := table():
 P := T["embedding"]:
 for e in T["max_simplices"] do
  T["map"][e] := unapply((1-t) *~ P[e[1]] +~ t *~ P[e[2]],t);
 od:
end:

set_alt_map := proc(T)
 local P,e,s,t;
 T["alt_map"] := table():
 P := T["alt_embedding"]:
 for e in T["max_simplices"] do
  T["alt_map"][e] := unapply((1-t) *~ P[e[1]] +~ t *~ P[e[2]],t);
 od:
end:

set_isotopy := proc(T)
 local P,Q,e,s,t;
 T["isotopy"] := table():
 for e in T["max_simplices"] do
  T["isotopy"][e] :=
   unapply((1-s) *~ T["map"][e](t) +~ s *~ T["alt_map"][e](t),s,t);
 od:
end:

rotate_isotopy := proc(T,a)
 local P0,P1,P2,e,v,s,t;
 P0 := eval(T["alt_embedding"]):
 P1 := eval(T["alt_map"]):
 P2 := eval(T["isotopy"]):
 T["alt_embedding"] := table():
 T["alt_map"] := table():
 T["isotopy"] := table():
 for v in T["vertices"] do
  T["alt_embedding"][v] := rot(a,P0[v]):
 od:
 for e in T["max_simplices"] do
  T["alt_map"][e] := unapply(rot(a,P1[e](t)),t):
  T["isotopy"][e] := unapply(rot(a*s,P2[e](s,t)),s,t):
 od:
end:

translate_letter := proc(T,a)
 local P0,P1,P2,P3,P4,e,v,s,t;
 P0 := eval(T["embedding"]):
 P1 := eval(T["map"]):
 P2 := eval(T["alt_embedding"]):
 P3 := eval(T["alt_map"]):
 P4 := eval(T["isotopy"]):
 T["embedding"] := table():
 T["map"] := table():
 T["alt_embedding"] := table():
 T["alt_map"] := table():
 T["isotopy"] := table():
 for v in T["vertices"] do
  T["embedding"][v] := P0[v] +~ a:
  T["alt_embedding"][v] := P3[v] +~ a:
 od:
 for e in T["max_simplices"] do
  T["map"][e] := unapply(P1[e](t) +~ a,t):
  T["alt_map"][e] := unapply(P3[e](t) +~ a,t):
  T["isotopy"][e] := unapply(P2[e](s,t) +~ a,s,t):
 od:
end:

pol := (r,t) -> evalf([r * cos(Pi*t),r * sin(Pi*t)]):
rot := (t,x) -> evalf([cos(Pi*t)*x[1]-sin(Pi*t)*x[2],sin(Pi*t)*x[1] + cos(Pi*t)*x[2]]):

show_map := (T,s) ->
 display(seq(plot([op(T["map"][e](t)),t=0..1]),e in T["max_simplices"]),axes=none,scaling=constrained):

show_alt_map := (T,s) ->
 display(seq(plot([op(T["alt_map"][e](t)),t=0..1]),e in T["max_simplices"]),axes=none,scaling=constrained):

show_isotopy := (T,s) ->
 display(seq(plot([op(T["isotopy"][e](s,t)),t=0..1]),e in T["max_simplices"]),axes=none,scaling=constrained):

show_movie := (T) ->
 display([seq(show_isotopy(T,s),s=0..1,0.02)],insequence=true,view=[-1.5..1.5,-1.5..1.5]):

show_list_map := proc(L)
 display(seq(seq(
   translate(show_map(letters[L[i][j]]),2*j,-3*i),
  j=1..nops(L[i])),i=1..nops(L)),scaling=constrained);
end:

show_list_alt_map := proc(L)
 display(seq(seq(
   translate(show_alt_map(letters[L[i][j]]),3*j,-3*i),
  j=1..nops(L[i])),i=1..nops(L)),scaling=constrained);
end:

show_list_isotopy := proc(L,s)
 display(seq(seq(
   translate(show_isotopy(letters[L[i][j]],s),3*j,-3*i),
  j=1..nops(L[i])),i=1..nops(L)),scaling=constrained);
end:

show_list_movie := proc(L)
 display([seq(show_list_isotopy(L,s),s=0..1,0.02)],insequence=true):
end:

tikz_map := proc(T)
 local s,e,u,n;
 s := "";
 for e in T["max_simplices"] do
  u := T["map"][e];
  if type(u(t),list(polynom(realcons,t))) and
     max(map(degree,u,t)) <= 1 then
   n := 1;
  else
   n := 16;
  fi;
  s := cat(s," \\draw ",
    StringTools[Join]([seq(sprintf("(%.3f,%.3f)",op(u(i/n))),i=0..n)]," -- "),
    ";\n");
 od:
 return s;
end:

tikz_alt_map := proc(T)
 local s,e,u,n;
 s := "";
 for e in T["max_simplices"] do
  u := T["alt_map"][e];
  if type(u(t),list(polynom(realcons,t))) and
     max(map(degree,u,t)) <= 1 then
   n := 1;
  else
   n := 16;
  fi;
  s := cat(s," \\draw ",
    StringTools[Join]([seq(sprintf("(%.3f,%.3f)",op(u(i/n))),i=0..n)]," -- "),
    ";\n");
 od:
 return s;
end:

tikz_list_map := proc(L,{width::numeric := 2},{height::numeric := 3})
 cat(seq(seq(
  cat(
   sprintf("\\begin{scope}[shift={(%f,%f)}]\n",width*j,-height*i),
   tikz_map(letters[L[i][j]]),
   "\\end{scope}\n"),
   j=1..nops(L[i])),i=1..nops(L)));
end:

tikz_list_alt_map := proc(L,{width::numeric := 3.2},{height::numeric := 3})
 cat(seq(seq(
  cat(
   sprintf("\\begin{scope}[shift={(%f,%f)}]\n",width*j,-height*i),
   tikz_alt_map(letters[L[i][j]]),
   "\\end{scope}\n"),
   j=1..nops(L[i])),i=1..nops(L)));
end:

######################################################################
# A

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[4,5],[2,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([
 1 = [-1,-1], 2 = [-0.5,0], 3 = [0,1], 4 = [0.5,0], 5 = [1,-1]
]):
T["alt_embedding"] := table([
 1 = [-1.5,0], 2 = [-1,0], 3 = [0,1], 4 = [1,0], 5 = [1.5,0]
]):
set_map(T):
set_alt_map(T):
T["alt_map"][[2,3]] := (t) -> [-cos(Pi/2*t),sin(Pi/2*t)]:
T["alt_map"][[3,4]] := (t) -> [ sin(Pi/2*t),cos(Pi/2*t)]:
T["alt_map"][[2,4]] := (t) -> [-cos(Pi*t),-sin(Pi*t)]:
set_isotopy(T):
letters["A"] := eval(T):

######################################################################
# B

T := table():
T["vertices"] := [1,2,3,4,5,6]:
T["max_simplices"] := [[1,2],[1,4],[2,3],[2,5],[3,6],[4,5],[5,6]]:
T["embedding_dim"] := 2:
T["embedding"] := table([
 1 = [-0.5,-1],2=[-0.5,0],3=[-0.5,1],4=[0,-1],5=[0,0],6=[0,1]
]):
T["alt_embedding"] := table([
 1 = pol(1,-2/3), 2 = pol(1,1), 3 = pol(1,2/3), 4 = pol(1,-1/3), 5 = pol(1,0), 6 = pol(1,1/3)
]):
set_map(T):
set_alt_map(T):
T["map"][[4,5]] := (t) -> [0,-0.5] +~ pol(0.5,t-0.5):
T["map"][[5,6]] := (t) -> [0, 0.5] +~ pol(0.5,t-0.5):
T["alt_map"][[1,2]] := (t) -> pol(1,(-2-t)/3):
T["alt_map"][[1,4]] := (t) -> pol(1,(-2+t)/3):
T["alt_map"][[2,3]] := (t) -> pol(1,(-3-t)/3):
T["alt_map"][[3,6]] := (t) -> pol(1,( 2-t)/3):
T["alt_map"][[4,5]] := (t) -> pol(1,(-1+t)/3):
T["alt_map"][[5,6]] := (t) -> pol(1,(   t)/3):
set_isotopy(T):
letters["B"] := eval(T):

######################################################################
# C

T := table():
T["vertices"] := [1,2]:
T["max_simplices"] := [[1,2]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1 = pol(1,0.4) *~ [0.8,1], 2 = pol(1,-0.4) *~ [0.8,1]]):
T["alt_embedding"] := table([1 = [0,1], 2=[0,-1]]):
T["map"] := table([[1,2] = ((t) -> pol(1,0.4 + 1.2*t) *~ [0.8,1])]):
set_alt_map(T):
set_isotopy(T):
letters["C"] := eval(T):

######################################################################
# D

T := table():
T["vertices"] := [1,2,3]:
T["max_simplices"] := [[1,2],[1,3],[2,3]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1 = [-0.5,-1], 2=[-0.5,1], 3 = [0.5,0]]):
T["alt_embedding"] := table([1 = [0,-1], 2=[0,1], 3 = [1,0]]):
set_map(T):
T["map"][[1,3]] := (t) -> [-0.5,0] +~ pol(1,-0.5 + 0.5*t):
T["map"][[2,3]] := (t) -> [-0.5,0] +~ pol(1, 0.5 - 0.5*t):
T["alt_map"] := table():
T["alt_map"][[1,2]] := (t) -> pol(1,-0.5 - t):
T["alt_map"][[1,3]] := (t) -> pol(1,-0.5 + 0.5*t):
T["alt_map"][[2,3]] := (t) -> pol(1, 0.5 - 0.5*t):
set_isotopy(T):
letters["D"] := eval(T):

######################################################################
# E

T := table():
T["vertices"] := [1,2,3,4,5,6]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[4,5],[3,6]]:
T["embedding_dim"] := 2:
T["embedding"] := table([
 1 = [0.5,-1], 2 = [-0.5,-1], 3 = [-0.5,0], 4 = [-0.5,1], 5 = [0.5,1], 6 = [0,0]
]):
T["alt_embedding"] := table([
 1 = [-1,-1], 2 = [-1,-0.5], 3 = [-1,0], 4 = [-1,0.5], 5 = [-1,1], 6 = [1,0]
]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
T["isotopy"][[1,2]] := (s,t) -> (1-s) *~ [-0.5,-1] +~ s *~ [-1,-0.5] +~ pol((1-0.5*s)*(1-t),-s/2):
T["isotopy"][[4,5]] := (s,t) -> (1-s) *~ [-0.5, 1] +~ s *~ [-1, 0.5] +~ pol((1-0.5*s)*(1-t), s/2):
rotate_isotopy(T,-0.5):
letters["E"] := eval(T):

######################################################################
# F

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[2,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([
 1 = [-0.5,-1], 2 = [-0.5,0], 3 = [-0.5,1], 4 = [0.5,1], 5 = [0,0]
]):
T["alt_embedding"] := table([
 1 = [-1,-1], 2 = [-1,0], 3 = [-1,0.5], 4 = [-1,1], 5 = [1,0]
]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
T["isotopy"][[3,4]] := (s,t) -> (1-s) *~ [-0.5, 1] +~ s *~ [-1, 0.5] +~ pol((1-0.5*s)*(1-t), s/2):
rotate_isotopy(T,-0.5):
letters["F"] := eval(T):

######################################################################
# G

T := table():
T["vertices"] := [1,2,3]:
T["max_simplices"] := [[1,2],[2,3]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1 = pol(1,0.4) *~ [0.8,1], 2 = pol(1,-0.4) *~ [0.8,1],
                         3 = pol(1,-0.4) *~ [0.8,1] +~ [0,-0.4]
                         ]):
T["alt_embedding"] := table([1 = [0,1], 2=[0,0], 3=[0,-1]]):
set_map(T):
T["map"][[1,2]] := ((t) -> pol(1,0.4 + 1.2*t) *~ [0.8,1]):
set_alt_map(T):
set_isotopy(T):
letters["G"] := eval(T):

######################################################################
# H

T := table():
T["vertices"] := [1,2,3,4,5,6]:
T["max_simplices"] := [[1,2],[2,3],[2,5],[4,5],[5,6]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.5,-1],2=[-0.5,0],3=[-0.5,1],
                         4=[ 0.5,-1],5=[ 0.5,0],6=[ 0.5,1]
                         ]):
T["alt_embedding"] := table([1 = [-1,-1], 2=[-1,0], 3=[-1,1],
                             4=[1,-1],5=[1,0],6=[1,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
rotate_isotopy(T,-0.5):
letters["H"] := eval(T):

######################################################################
# I

T := table():
T["vertices"] := [1,2,3,4,5,6]:
T["max_simplices"] := [[1,2],[2,3],[2,5],[4,5],[5,6]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.2,-1],2=[0,-1],3=[0.2,-1],
                         4=[-0.2,1],5=[0,1],6=[0.2,1]
                         ]):
T["alt_embedding"] := table([1 = [-1,-1], 2=[0,-1], 3=[1,-1],
                             4=[-1,1],5=[0,1],6=[1,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["I"] := eval(T):

######################################################################
# J

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,4],[3,4],[4,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.6,-0.7],2=[0,-0.7],3=[-0.5,1],
                         4=[0,1],5=[0.5,1]
                         ]):
T["alt_embedding"] := table([1 = [0,-1], 2=[0,0], 3=[-1,1],
                             4=[0,1],5=[1,1]]):
set_map(T):
T["map"][[1,2]] := (t) -> [-0.3,-0.7] +~ pol(0.3,-1+t):
set_alt_map(T):
set_isotopy(T):
letters["J"] := eval(T):

######################################################################
# K

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[2,4],[2,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.5,-1],2=[-0.5,0],3=[-0.5,1],
                         4=[0.5,-1],5=[0.5,1]
                         ]):
T["alt_embedding"] := table([1 = [-1,-1], 2=[0,0], 3=[-1,1],
                             4=[1,-1],5=[1,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["K"] := eval(T):

######################################################################
# L

T := table():
T["vertices"] := [1,2,3]:
T["max_simplices"] := [[1,2],[2,3]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[0.5,-1],2=[-0.5,-1],3=[-0.5,1]]):
T["alt_embedding"] := table([1 = [0,-1], 2=[0,0], 3=[0,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["L"] := eval(T):

######################################################################
# M

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[4,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.6,-1],2=[-0.3,1],3=[0,-1],4=[0.3,1],5=[0.6,-1]]):
T["alt_embedding"] := table([1 = [-1,0], 2=[-0.5,0], 3=[0,0],4=[0.4,0],5=[1,0]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
rotate_isotopy(T,-0.5):
letters["M"] := eval(T):

######################################################################
# N

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[3,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.5,-1],2=[-0.5,1],3=[0.5,-1],4=[0.5,1]]):
T["alt_embedding"] := table([1 = [-1,0], 2=[-0.33,0], 3=[0.33,0],4=[1,0]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
rotate_isotopy(T,-0.5):
letters["N"] := eval(T):

######################################################################
# O

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[1,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=pol(1,0) *~ [0.6,1], 2=pol(1,0.5) *~ [0.6,1],
                         3=pol(1,1) *~ [0.6,1], 4=pol(1,1.5) *~ [0.6,1]]):
T["alt_embedding"] := table([1 = pol(1,0),2=pol(1,0.5),3=pol(1,1),4=pol(1,1.5)]):
set_map(T):
set_alt_map(T):
T["map"][[1,2]] := (t) -> pol(1,0.5* t   ) *~ [0.6,1]:
T["map"][[2,3]] := (t) -> pol(1,0.5*(t+1)) *~ [0.6,1]:
T["map"][[3,4]] := (t) -> pol(1,0.5*(t+2)) *~ [0.6,1]:
T["map"][[1,4]] := (t) -> pol(1,0.5*(4-t)) *~ [0.6,1]:
T["alt_map"][[1,2]] := (t) -> pol(1,0.5* t   ):
T["alt_map"][[2,3]] := (t) -> pol(1,0.5*(t+1)):
T["alt_map"][[3,4]] := (t) -> pol(1,0.5*(t+2)):
T["alt_map"][[1,4]] := (t) -> pol(1,0.5*(4-t)):
set_isotopy(T):
letters["O"] := eval(T):

######################################################################
# P

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[2,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.25,-1],2=[-0.25,0],3=[-0.25,1],4=[0.5,0.5]]):
T["alt_embedding"] := table([1=[0,-1.5],2=[0,-1],3=pol(1,2/3),4=pol(1,1/3)]):
set_map(T):
set_alt_map(T):
T["map"][[2,4]] := (t) -> pol(0.5,0.5*(t-1)) *~ [1.5,1] +~ [-0.25,0.5]:
T["map"][[3,4]] := (t) -> pol(0.5,0.5*(1-t)) *~ [1.5,1] +~ [-0.25,0.5]:
T["alt_map"][[2,3]] := (t) -> pol(1,-1/2-2/3*t):
T["alt_map"][[2,4]] := (t) -> pol(1,-1/2+2/3*t):
T["alt_map"][[3,4]] := (t) -> pol(1,5/6-2/3*t):
set_isotopy(T):
rotate_isotopy(T,0.5):
letters["P"] := eval(T):

######################################################################
# Q

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[1,3],[1,4],[1,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([
 1= pol(1,-1/4)   *~ [0.6,1],
 2= pol(1,5/12)   *~ [0.6,1],
 3= pol(1,13/12)  *~ [0.6,1],
 4= pol(1.3,-1/4) *~ [0.6,1],
 5= pol(0.7,-1/4) *~ [0.6,1]
]):
T["alt_embedding"] :=
table([
 1= pol(1,-1/4),
 2= pol(1,5/12),
 3= pol(1,13/12),
 4= pol(1.5,-1/4),
 5= pol(0.5,-1/4)
]):
set_map(T):
set_alt_map(T):
T["map"][[1,2]] := (t) -> pol(1,-1/4+2/3*t) *~ [0.6,1]:
T["map"][[1,3]] := (t) -> pol(1,-1/4-2/3*t) *~ [0.6,1]:
T["map"][[2,3]] := (t) -> pol(1,5/12+2/3*t) *~ [0.6,1]:
T["alt_map"][[1,2]] := (t) -> pol(1,-1/4+2/3*t):
T["alt_map"][[1,3]] := (t) -> pol(1,-1/4-2/3*t):
T["alt_map"][[2,3]] := (t) -> pol(1,5/12+2/3*t):
set_isotopy(T):
rotate_isotopy(T,0.25):
letters["Q"] := eval(T):

######################################################################
# R

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[2,4],[2,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.25,-1],2=[-0.25,0],3=[-0.25,1],4=[0.5,0.5],5=[0.5,-1]]):
T["alt_embedding"] := table([1=[-0.5,-1.5],2=[0,-1],3=pol(1,2/3),4=pol(1,1/3),5=[0.5,-1.5]]):
set_map(T):
set_alt_map(T):
T["map"][[2,4]] := (t) -> pol(0.5,0.5*(t-1)) *~ [1.5,1] +~ [-0.25,0.5]:
T["map"][[3,4]] := (t) -> pol(0.5,0.5*(1-t)) *~ [1.5,1] +~ [-0.25,0.5]:
T["alt_map"][[2,3]] := (t) -> pol(1,-1/2-2/3*t):
T["alt_map"][[2,4]] := (t) -> pol(1,-1/2+2/3*t):
T["alt_map"][[3,4]] := (t) -> pol(1,5/6-2/3*t):
set_isotopy(T):
rotate_isotopy(T,0.5):
letters["R"] := eval(T):

######################################################################
# S

T := table():
T["vertices"] := [1,2,3]:
T["max_simplices"] := [[1,2],[2,3]]:
T["embedding_dim"] := 2:
theta := -0.05;
T["embedding"] := table([
 1=rot(theta,[0,-0.5] +~ pol(0.5,-0.7)),
 2=rot(theta,[0,0],3=[0,0.5] +~ pol(0.5,0.3))
 ]):
T["alt_embedding"] := table([1=[0,-1],2=[0,0],3=[0,1]]):
set_map(T):
set_alt_map(T):
T["map"][[1,2]] := (t) -> rot(theta,[0,-0.5] +~ pol(0.5,-0.7+1.2*t)):
T["map"][[2,3]] := (t) -> rot(theta,[0, 0.5] +~ pol(0.5,-0.5-1.2*t)):
set_isotopy(T):
letters["S"] := eval(T):

######################################################################
# T

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[2,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[0,-1],2=[0,1],3=[-0.7,1],4=[0.7,1]]):
T["alt_embedding"] := table([1 = [0,-1], 2=[0,1], 3=[-1,1],4=[1,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["T"] := eval(T):

######################################################################
# U

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[3,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.6,1],2=[-0.6,-0.4],3=[0.6,-0.4],4=[0.6,1]]):
T["alt_embedding"] := table([1 = [-1,0], 2=[-0.33,0], 3=[0.33,0],4=[1,0]]):
set_map(T):
set_alt_map(T):
T["map"][[2,3]] := (t) -> [0,-0.4] +~ pol(0.6,t-1):
set_isotopy(T):
rotate_isotopy(T,-0.5):
letters["U"] := eval(T):

######################################################################
# V

T := table():
T["vertices"] := [1,2,3]:
T["max_simplices"] := [[1,2],[2,3]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.6,1],2=[0,-1],3=[0.6,1]]):
T["alt_embedding"] := table([1 = [-1,0], 2=[0,0], 3=[1,0]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
rotate_isotopy(T,-0.5):
letters["V"] := eval(T):

######################################################################
# W

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[3,4],[4,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.6,1],2=[-0.3,-1],3=[0,1],4=[0.3,-1],5=[0.6,1]]):
T["alt_embedding"] := table([1 = [-1,0], 2=[-0.5,0], 3=[0,0],4=[0.4,0],5=[1,0]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
rotate_isotopy(T,-0.5):
letters["W"] := eval(T):

######################################################################
# X

T := table():
T["vertices"] := [1,2,3,4,5]:
T["max_simplices"] := [[1,2],[2,3],[2,4],[2,5]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[-0.5,-1],2=[0,0],3=[-0.5,1],
                         4=[0.5,-1],5=[0.5,1]
                         ]):
T["alt_embedding"] := table([1 = [-1,-1], 2=[0,0], 3=[-1,1],
                             4=[1,-1],5=[1,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["X"] := eval(T):

######################################################################
# Y

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[2,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[0,-1],2=[0,0],3=[-0.7,1],4=[0.7,1]]):
T["alt_embedding"] := table([1 = [0,-1], 2=[0,1], 3=[-1,1],4=[1,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["Y"] := eval(T):

######################################################################
# Z

T := table():
T["vertices"] := [1,2,3,4]:
T["max_simplices"] := [[1,2],[2,3],[3,4]]:
T["embedding_dim"] := 2:
T["embedding"] := table([1=[0.5,-1],2=[-0.5,-1],3=[0.5,1],4=[-0.5,1]]):
T["alt_embedding"] := table([1 = [0,-1], 2=[0,-0.33], 3=[0,0.33],4=[0,1]]):
set_map(T):
set_alt_map(T):
set_isotopy(T):
letters["Z"] := eval(T):


#int fact(int n) {
#  if (n == 1)
#    return 1;
#  return n * fact(n-1);
#}

func $fact (var %n i32) i32 {
  if (ne i32 i32 (dread i32 %n, constval i32 1)) {
       call &fact (sub i32 (dread i32 %n, constval i32 1))
            return (mul i32 (dread i32 %n, regread i32 %%retval))
             }
  return (constval i32 1)
}

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


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

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

(* type: work_mgga_x *)
(* prefix:
  mgga_x_tpss_params *params;

  assert(pt->params != NULL);
  params = (mgga_x_tpss_params * ) (pt->params);
*)

ff     := z -> params_a_BLOC_a + params_a_BLOC_b*z:
mkappa := (x, t) -> params_a_kappa:

$include "tpss_x.mpl"

(* Equation (5) *)

a1  := (x, t) -> mkappa(x, t)/(mkappa(x, t) + fx(x, t)):
f   := (rs, x, t, u) -> 1 + mkappa(x, t)*(1 - a1(x, t)):


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

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

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

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

n12_omega_x := 2.5:
n12_gamma_x := 0.004:

n12_rss := (rs, z) -> rs * 2^(1/3) * opz_pow_n(z,-1/3):

n12_vx := rs -> 1/(1 + (1/(RS_FACTOR*n12_omega_x))*rs):
n12_ux := x -> n12_gamma_x*x^2/(1 + n12_gamma_x*x^2):

n12_FN12 := (rs, z, x) ->
  + add(params_a_CC_0_[i+1]*n12_ux(x)^i, i=0..3)
  + add(params_a_CC_1_[i+1]*n12_ux(x)^i, i=0..3) * n12_vx(n12_rss(rs, z))
  + add(params_a_CC_2_[i+1]*n12_ux(x)^i, i=0..3) * n12_vx(n12_rss(rs, z))^2
  + add(params_a_CC_3_[i+1]*n12_ux(x)^i, i=0..3) * n12_vx(n12_rss(rs, z))^3:

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


with(ListTools):

####################
f1 := 2*x^2-x*y+4:
f2 := x*y-2*y^2+4:
sub := [x=x1+I*x2, y=y1+I*y2]:
f1 := expand(subs( sub, f1)):
f2 := expand(subs( sub, f2)):
p1 := Re(f1) assuming real:
p2 := Im(f1) assuming real:
p3 := Re(f2) assuming real:
p4 := Im(f2) assuming real:

################
nld := proc(d, nb_vars)
local l, i, j, p, x, vars;
l := [];
vars := [];
for i from 1 to nb_vars do
    p := -1;
    for j from 1 to nb_vars do
        if i=j then
           p := p+x||j^d;
        else
           p := p+x||j;
        end if;
    end do;
    l := [op(l), p];
    vars := [op(vars), x||i];
end do;
return l, vars;
end proc:

################
nqleven := proc(nb_vars, even_d)
local x, vars, eqs, i;
vars := [ x||1 ];
eqs := [ x||1^even_d-2 ];
for i from 2 to nb_vars do
    vars := [ x||i, op(vars)];
    eqs := [op(eqs), x||i^even_d + x||i^(even_d/2)- x||(i-1)];
od;
return eqs, vars;
end proc:

################
simplenql := proc(nbvar, d)
local x, eqs, i, vars;
vars := [ x||1 ];
eqs := [ x||1^d-2 ];
for i from 2 to nbvar do
    vars := [ x||i, op(vars) ];
    eqs := [op(eqs), x||i^d - x||(i-1)];
end do;
return eqs, vars;
end proc:

####################
cm :=
[
    [   #(1) 4-body-homog ((1)-(47) are from changbo's folder BCLM-cm14)
        [-2*p^3+2*p^3*phi^3-4*phi^3*s*p^2+5*phi^3*s^3*p-phi^3*s^5,
         -2*s*p^3-2*phi^3*s^2+phi^3*s^4-3*phi^3*s^2*p+2*phi^3*p,
         -2*s^2+s^4-4*s^2*p+phi^2+1+4*p
        ],
        [phi,s,p]
    ],
    [
        #(2) 5-body-homog
        [-6*p^3+4*p^3*phi^3+15*phi^3*s^3*p-3*phi^3*s^5-12*phi^3*s*p^2-3*phi^3*s*p+phi^3*s^3,
        -9*phi^3*s^2*p-5*phi^3*s^2-6*s*p^3+3*phi^3*s^4+5*phi^3*p,
        -12*s^2*p-6*s^2+3*s^4+4*phi^2+3+12*p
        ],
        [phi,s,p]
    ],
    [
        #(3) Arnborg-Lazard
        [x^2*y*z + x*y^2*z + x*y*z^2 + x*y*z + x*y + x*z + y*z,
        x^2*y^2*z + x*y^2*z^2 + x^2*y*z + x*y*z + y*z + x + z,
        x^2*y^2*z^2 + x^2*y^2*z + x*y^2*z + x*y*z + x*z + z + 1
        ],
        [z,y,x]
    ],
    [
        #(4) Arnborg-Lazard-rev
        [x^2*y*z + x*y^2*z + x*y*z^2 + x*y*z + x*y + x*z + y*z,
        x^2*y^2*z + x*y^2*z^2 + x^2*y*z + x*y*z + y*z + x + z,
        x^2*y^2*z ^2 + x^2*y^2*z + x*y^2*z + x*y*z + x*z + z + 1
        ],
        [x,y,z]
    ],
    [
        #(5) Barry
        [-x^5+y^5-3*y-1,
         5*y^4-3,
         -20*x+y-z
        ],
        [z,y,x]
    ],
    [
        #(6) Caprasse
        [y^2*z+2*x*y*t-2*x-z,
         -x^3*z+4*x*y^2*z+4*x^2*y*t+2*y^3*t+4*x^2-10*y^2+4*x*z-10*y*t+2,
         2*y*z*t+x*t^2-x-2*z,
         -x*z^3+4*y*z^2*t+4*x*z*t^2+2*y*t^3+4*x*z+4*z^2-10*y*t-10*t^2+2
        ],
        [t,z,y,x]
    ],
    [
        #(7) Caprasse-Li
        [y^2*z+2*x*y*t-2*x-z,
         -x^3*z+4*x*y^2*z+4*x^2*y*t+2*y^3*t+4*x^2-10*y^2+4*x*z-10*y*t+2,
         2*y*z*t+x*t^2-x-2*z,
         -x*z^3+4*y*z^2*t+4*x*z*t^2+2*y*t^3+4*x*z+4*z^2-10*y*t-10*t^2+2
        ],
        [x,y,z,t]
    ],
    [
        #(8) chemical-reaction
        [2 - 7*x1 + x1^2*x2 - 1/2*(x3 - x1),
        6*x1 - x1^2*x2 - 5*(x4 - x2 ),
        2 - 7*x3 + x3^2*x4 - 1/2*(x1 - x3 ),
        6*x3 - x3^2*x4 + 1 + 1/2*(x2 - x4 )
        ],
        [x1,x2,x3,x4]
    ],
    [
        #(9) circles
        [product( (x-'i'), 'i'=1..10) +1/100,
         product ( (x-'i')^2+(y-'i')^2-2, 'i'=1..5)+1/1000
        ],
        [x,y]
    ],
    [
        #(10) cyclic-5
        [a + b + c + d + e,
         a*b + b*c + c*d + d*e + e*a,
         a*b*c + b*c*d + c*d*e + d*e*a + e*a*b,
         a*b*c*d + b*c*d*e + c*d*e*a + d*e*a*b  + e*a*b*c,
         a*b*c*d*e - 1
        ],
        [e,d,c,b,a]
    ],
    [
        #(11) Czapor-Geddes-Wang
        [b-2,
         c*c*q*q-2*d*c*q*q+d*d*q*q-2*c*c*q+2*d*p*c*q+2*b*p*c*q+2*d*c*q-2*d*d*p*q+2*b*p*q-2*p*q-2*b*d*d*q-2*b*q+2*q+c*c-2*d*p*c-2*b*d*c+b*b*d*d*p*p-2*b*d*d*p*p+d*d*p*p+2*b*b*p*p+2*p*p-2*b*b*d*d*p+4*b*d*d*p-4*b*b*p+4*b*p+b*b*d*d+2*b*b-4*b+2,
         -b*p*c*q-p*c*q+b*c*q-2*c*q+2*d*p*q+d*q+p*c+b*b*c-b*c+2*c+b*b*d*p*p+b*d*p*p-2*d*p*p-2*b*b*d*p+b*d*p-d*p+b*b*d-2*b*d,
         -2*p*q-2*q-b*b*p*p+2*p*p+2*b*b*p-b*b+2,
         3*c*c*q*q-3*d*d*q*q-4*q*q-6*c*c*q+6*b*d*p*c*q+6*b*d*c*q+6*d*d*p*q+3*c*c+6*b*d*p*c-6*b*d*c+3*b*b*d*d*p*p-3*d*d*p*p+b*b*p*p-6*b*b*d*d*p-2*b*b*p+4*p+3*b*b*d*d+b*b
        ],
        [b,d,p,c,q]
    ],
    [
        #(12) fabfaux
        [30752*x^3 + 46128*y*x^2 - 216256*x + 46128*x*y^2 + 141980 + 30752*y^3- 216256*y,
        30752*x^3 + 46128*z*x^2 - 216256*x + 46128*x*z^2 + 141980 + 30752*z^3+ 216256*z,
        46128*y^3 + 46128*x*y^2 + 46128*z*y^2 + 46128*y*x^2 - 432512*y +46128*x*z*y + 46128*z^2*y + 46128*x^3 - 432512*x + 425940 +46128*z*x^2 - 432512*z + 46128*x*z^2 + 46128*z^3
        ],
        [z,y,x]
    ],
    [
        #(13) geometric-constraints
        [1/100 - 4*s*(s - 1)*(s - b)*(s - c),
         1/5 - b*c,
         2*s - 1 - b - c
        ],
        [s,b,c]
    ],
    [
        #(14) GonzalezGonzalez
        [x^3 + y*x^2 + x + z,
         x^2*y +3*x +2,
         x^2-y*x+z
        ],
        [z,y,x]
    ],
    [
        #(15) Katsura-4
        [2*x^2 + 2*y^2 + 2*z^2 + 2*t^2 + u^2 - u ,
        2*x*y + 2*y*z + 2*z*t + 2*t*u - t ,
        2*x*z + 2*y*t + t^2 + 2*z*u - z ,
        2*x*t + 2*z*t + 2*y*u - y ,
        2*x + 2*y + 2*z + 2*t + u - 1
        ],
        [u,t,z,y,x]
    ],
    [
        #(16) lhlp1
        [2*x^7+2-3*x^2-x^4,
         x^2+2*y^2-5,
         x*z-1
        ],
        [x,y,z]
    ],
    [
        #(17) lhlp2
        [y*(320+1600*y^4-240*y^5-471*y^6+36*y^7-48*y^2+36*y^8),
        -40*y^2+3*y^3+6*y^4+8*x,
        -8*y*z-8-40*y^4+3*y^5+6*y^6
        ],
        [x,y,z]
    ],
    [
        #(18) lhlp3
        [2450*x^6-1241*x^4+196*x^2-49,
         86*x^2+35*y*x^2-77*y-14,
         175*x^4+70*x^2*z-76*x^2-154*z+21
        ],
        [x,y,z]
    ],
    [
        #(19) lhlp4
        [x^4+y^4-1,
         x^5*y^2-4*x^3*y^3+x^2*y^5-1
        ],
        [x,y]
    ],
    [
        #(20) lhlp5
        [-7*x*y*z+6*y*z-14*x*z+9*z-3*x*y-12*y-x+1,
         2*x*y*z-y*z+14*z+15*x*y+14*y-15*x,
         -8*x*y*z+11*y*z-12*x*z-5*z+15*x*y+2*y+10*x-14
        ],
        [x,y,z]
    ],
    [
        #(21) lhlp6
        [p1,p2,p3,p4
        ],
        [y1,x1,y2,x2]
    ],
    [
        #(22) neural-network
        [1 - c*x - x*y^2 - x*z^2,
         1 - c*y - y*x^2 - y*z^2,
         1 - c*z - z*x^2 - z*y^2,
         8*c^6 + 378*c^3 - 27
        ],
        [z,c,y,x]
    ],
    [
        #(23) nld-3-4
        [x^3 + y + z + t- 1,
         x + y^3 + z + t -1,
         x + y + z^3 + t-1,
         x + y + z + t^3 -1
        ],
        [t,z,y,x]
    ],
    [
        #(24) nld-3-5
        [x^3 + y + z + t + u- 1,
         x + y^3 + z + t + u-1,
         x + y + z^3 + t + u-1,
         x + y + z + t^3 + u-1,
         x + y + z + t + u^3 -1
        ],
        [u,t,z,y,x]
    ],
    [
        #(25) nld-4-5
        [x^4 + y + z + t + u- 1,
         x + y^4 + z + t + u-1,
         x + y + z^4 + t + u-1,
         x + y + z + t^4 + u-1,
         x + y + z + t + u^4 -1
        ],
        [x,y,z,t,u]
    ],
    [
        #(26) nld-7-3
        [x^7 + y + z - 1,
         x + y^7 + z - 1,
         x + y + z^7 - 1
        ],
        [z,y,x]
    ],
    [
        #(27) nld-8-3
        [x^8 + y + z - 1,
         x + y^8 + z - 1,
         x + y + z^8 - 1
        ],
        [z,y,x]
    ],
    [
        #(28) nld-9-3
        [x^9 + y + z - 1,
         x + y^9 + z - 1,
         x + y + z^9 - 1
        ],
        [z,y,x]
    ],
    [
        #(29) nld-10-3
        [x^10 + y + z - 1,
         x + y^10 + z - 1,
         x + y + z^10 - 1
        ],
        [z,y,x]
    ],
    [
        #(30) nql-5-4
        nqleven(5,4)
    ],
    [
        #(31) nql-10-2
        nqleven(10,2)
    ],
    [
        #(32) nql-10-4
        nqleven(10,4)
    ],
    [
        #(33) nql-15-2
        nqleven(15,2)
    ],
    [
        #(34) p3p-special
        [x^2 + y^2 - x*y - 1,
         y^2 + z^2 - y*z - a^2,
         z^2 + x^2 - z*x - b^2,
         a^2 - 1 + b - b^2,
         3*b^6 + 56*b^4 - 122*b^3 + 56*b^2 + 3
        ],
        [b,a,x,y,z]
    ],
    [
        #(35) PlateForme2d-easy
        [(x1+5)^2+ (y1-0)^2 - 1,
         (x2-5)^2+ (y2-0)^2 - 1,
         (x3)^2  + (y3-5)^2 - 1,
         (x1-x2)^2 + (y1-y2)^2 - 3,
         (x1-x3)^2 + (y1-y3)^2 - 3,
         (x2-x3)^2 + (y2-y3)^2 - 3
        ],
        [y3,x3,y2,x2,y1,x1]
    ],
    [
        #(36) r-5
        [a^2 + a,
         a*b + b + a*b^2 +a,
         b^2*c + c + b*c^3 + b,
         c^3*d + d + c*d^4 + c,
         d^4*e + e + d*e^5 + d
        ],
        [e,d,c,b,a]
    ],
    [
        #(37) r-6
        [a^2 + a,
         a*b + b + a*b^2 +a,
         b^2*c + c + b*c^3 + b,
         c^3*d + d + c*d^4 + c,
         d^4*e + e + d*e^5 + d,
         e^5*f + f + e*f^6 + e
        ],
        [f,e,d,c,b,a]
    ],
    [
        #(38) Reif
        [x4*x13+x5*x14+x6*(1-x13-x14),
         x4*x15+x5*x16-x6*(x15+x16) ,
         x7*x13+x8*x14+x9*(1-x13-x14) ,
         x7*x15+x8*x16-x9*(x15+x16)-1 ,
         x10*x13+x11*x14+x12*(1-x13-x14) ,
         x10*x15+x11*x16-x12*(x15+x16) ,
         x1*x13+x2*x14+x3*(1-x13-x14) ,
         x1*x15+x2*x16-x3*(x15+x16) ,
         x1*x4*x13+x2*x5*x14+x3*x6*(1-x13-x14)-1 ,
         x1*x4*x15+x2*x5*x16-x3*x6*(x15+x16) ,
         x1*x7*x13+x2*x8*x14+x3*x9*(1-x13-x14) ,
         x1*x7*x15+x2*x8*x16-x3*x9*(x15+x16) ,
         x1*x10*x13+x2*x11*x14+x3*x12*(1-x13-x14) ,
         x1*x10*x15+x2*x11*x16-x3*x12*(x15+x16)-1
        ],
        [x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15,x16]
    ],
    [
        #(39) Rose
        [7*y^4 - 20*x^2,
         2160*x*x*z^4+1512*x*z^4+315*z^4-4000*x*x-2800*x-490,
         -10080000*x^4*z^3-28224000*x^3*z^3-15288000*x*x*z^3-1978032*x*z^3-180075*z^3-23520000*x^4*y*z*z-41395200*x^3*y*z*z-26726560*x*x*y*z*z-7727104*x*y*z*z-852355*y*z*z+40320000*x^6*y*y*z+28800000*x^5*y*y*z+21168000*x^3*y*y*z+4939200*x*x*y*y*z+347508*x*y*y*z+67200000*x^5*y^3+94080000*x^4*y^3+40924800*x^3*y^3+2634240*x*x*y^3-2300844*x*y^3-432180*y^3
        ],
        [x,y,z]
    ],
    [
        #(40) simple-nql-20-30
        simplenql(20, 30)
    ],
    [
        #(41) Takeuchi-Lu
        [2*x1*(2 - x1 - y1 ) + x2 - x1,
         2*x2*(2 - x2 - y2 ) + x1 - x2,
         2*y1*(5 - x1 - 2*y1 ) + y2 - y1,
         y2*(3 - 2*x2 - 4*y2 ) + y1 - y2
        ],
        [x1,x2,y1,y2]
    ],
    [
        #(42) Themos-net
        [10000*d - 323536,
         (x-48)^2+(y-89)^2+(28)^2-(48*a+89*b+28*c)^2-d^2,
         (x-77)^2+(y-3)^2+(37)^2-(77*a+3*b+37*c)^2-d^2,
         (x-49)^2+(y-23)^2+(57)^2-(49*a+23*b+57*c)^2-d^2,
         a*x+b*y,
         a^2+b^2+c^2-1
        ],
        [d,c,b,a,y,x]
    ],
    [
        #(43) Trinks-2
        [45*y+35*u-165*v-36 ,
         35*y+25*z+40*t-27*u ,
         25*y*u-165*v^2+15*x-18*z+30*t ,
         15*y*z+20*t*u-9*x ,
         -11*v^3+x*y+2*z*t ,
         -11*u*v+3*v^2+99*x ,
         10000*v^3+6600*v+2673
        ],
        [v,u,z,t,y,x]
    ],
    [
        #(44) Trinks-difficult
        [45*y+35*u-165*v-36 ,
         35*y+25*z+40*t-27*u ,
         25*y*u-165*v^2+15*x-18*z+30*t ,
         15*y*z+20*t*u-9*x ,
         -11*v^3+x*y+2*z*t ,
         -11*u*v+3*v^2+99*x
        ],
        [v,u,z,t,y,x]
    ],
    [
        #(45) Uteshev-Bikker
        [x^2+x*y+y^2-2*x*z-4*y*z+3*z^2-3*x*t+2*y*t+t^2-3*x-2*y+3*z-2*t-2 ,
        2*x^2-x*y+y^2-x*z-y*z-6*z^2-x*t+y*t-5*z*t-3*t^2-5*x+y+5*z+2*t+5 ,
        -3-3*x*y+2*x*z+x*t^2-5*x*z^2-5*z^2*t-3*x*t-2*z*t+x*y*z+x*y*t-x^2*z+x^2-y^2+2*z^2+11*z-2*t-x+y+x^3+y^3-3*z^3+2*t^3-3*t^2-5*y^2*z+7*y*z^2 ,
        -15+2*x*y+11*x*t^2+5*x*z^2-z*t-4*x*y*z+6*x*y*t-x^2*z+3*x^2+2*y^2-z^2+4*z-10*t-35*x-14*y-x^3+6*y^3+15*z^3+4*t^3+5*t^2+6*y^2*z+4*y*z^2-x*z*t+6*x^2*y-12*x*y^2-7*y^2*t+2*y*t
        ],
        [t,z,y,x]
    ],
    [
        #(46) wilkinson20
        [mul( (x-i),i=0..20 )+1/100],
        [x]
    ],
    [
        #(47) wilkinsonxy
        [mul( (x-i),i=1..5 )+1/100,
	     mul( (y-x-i),i=1..5)
        ],
        [x,y]
    ],
    [
        #(48) trivial-5 ((48) is from changbo's folder RCtest-zerodim)
        [x^2 -1,
         y^2 - 1,
         (x-1)*(y-1)
        ],
        [y,x]
    ],
    [
        #(49) nld-4-4
        nld(4, 4)
    ],
    [
        #(50) nld-5-4
        nld(5, 4)
    ],
    [
        #(51) nld-6-4
        nld(6, 4)
    ],
    [
        #(52) nld-5-3
        nld(5, 3)
    ]
]:


(*
 Copyright (C) 2021 Susi Lehtola

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

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

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

$include "gga_x_optx.mpl"
$include "gga_x_ityh.mpl"

ityh_enhancement := xs -> optx_f(xs):


#You can also play with deg
deg:=2:
for n from 4 to 10 do
  for s from 2 to n-1 do
    vars:=[seq(cat(x,i),i=1..n)]:
    f:=expand(add(randpoly(vars,degree=deg)^2,i=1..s)):

    #To decompose
    F:=[f, seq(diff(f,v), v in vars[2..n])]:

#  rr:=rand(1..512):
#  l:=add(rr()*v, v in vars):

#  J:=linalg:-jacobian([f,l], vars):
#  J:=convert(J, Matrix):
#  with(LinearAlgebra):
#  lcols:=combinat:-choose(n, 2):

#  #To decompose
#  F1:=[f, seq(Determinant(SubMatrix(J, [1,2], cols)), cols in lcols)]:

   str:=cat("./soscritpoints_deg_", deg, "_nvars_", n, "_s_",s,".jl");
   fd:=fopen(str, WRITE):
   fprintf(fd, "using SignatureGB\n");
   fprintf(fd, "using Singular\n");
   fprintf(fd, "P, (%a, ", vars[1]);
   for j from 2 to n-1 do
   fprintf(fd, "%a, ", vars[j]);
   od:
   fprintf(fd, "%a)  = Singular.PolynomialRing(Fp(65521), [", vars[n]);
   for j from 1 to n-1 do
   fprintf(fd, "\"%a\", ", vars[j]);
   od:
   fprintf(fd, "\"%a\"]);\n", vars[n]);
   fprintf(fd, "gb = SignatureGB.f5(%a);", vars[1..n]);

   fprintf(fd, "F = %a;\n", F);
   fprintf(fd, "sort!(F, by = p -> leading_monomial(p))\n");
   fprintf(fd, "println(@elapsed SignatureGB.f5(F, verbose=true));");
   fprintf(fd, "exit()\n");
   fclose(fd):
  od:
od:


#@ Not autoload

p := 3;   # the ambient prime
n := 2;   # height
d := 243; # degree of approximate FGL

# find the FGL
T := make_fgl_Morava(p,n,d):
F_E := eval(T["sum"]);
F_K := eval(T["sum0"]);

# Generators and relations for O_Y, where Y is the scheme defined in
# Section sec_Y.  Note that the quantities called a,b and c in the
# main document are aa,bb and cc here.  Note also that we build up
# the relations in two stages: we first do a preliminary version
# without the condition \psi^4(D) = D, then we add that condition
# as a second step.

vars_Y := plex(aa,bb,cc,c[1],c[3],c[2]):
rels_Y := {
 c[1] - (aa+bb+cc),
 c[2] - (aa*bb+bb*cc+cc*aa),
 c[3] - (aa*bb*cc),
 c[1]^9,c[2]^9,c[3]^9,
 aa + F_K(bb,cc)
}:
basis_Y := Basis(rels_Y,vars_Y,characteristic=p); # Preliminary version

# aa4 = [4](aa), bb4 = [4](bb), cc4 = [4](cc)
aa4 := mods(NormalForm(F_K(aa,aa^(p^n)),basis_Y,vars_Y,characteristic=p),p);
bb4 := mods(NormalForm(F_K(bb,bb^(p^n)),basis_Y,vars_Y,characteristic=p),p);
cc4 := mods(NormalForm(F_K(cc,cc^(p^n)),basis_Y,vars_Y,characteristic=p),p);

# To impose the condition psi^4(D) = D, the elementary symmetric functions
# in aa4, bb4, cc4 must be the same as for aa, bb and cc.
rels_Y := {
 op(basis_Y),
 c[1] - (aa4+bb4+cc4),
 c[2] - (aa4*bb4+bb4*cc4+cc4*aa4),
 c[3] - (aa4*bb4*cc4)
}:

basis_Y := Basis(rels_Y,vars_Y,characteristic=p);
NF_Y := (u) -> mods(NormalForm(u,basis_Y,vars_Y,characteristic=p),p):

# The above Groebner basis includes the variables aa, bb and cc which were
# adjoined to O_Y for convenience.  Because these were placed first in a pure
# lexicographic order, we can obtaina Groebner basis for O_Y itself by simply
# omitting any relations that involve aa, bb or cc.
vars_Y1 := plex(c[1],c[3],c[2]):
basis_Y1 := remove(has,basis_Y,{aa,bb,cc});
cobasis_Y1 := cobasis(basis_Y1,vars_Y1);
nops(cobasis_Y1);

# Definitions of some auxiliary elements

# gamma is used by default for the Euler-Mascheroni constant; we need
# to cancel this.
unprotect('gamma'):

alpha := c[3]^3-c[2]^3*c[3];
beta  := 1 + c[2]^4;
gamma := c[2]^3*c[3]^3;
dd := NF_Y(F_K(aa,-bb));
mm := aa^5*bb^5 + bb^5*cc^5 + cc^5*aa^5;
uu := c[2] + c[2]^2*c[3]^2;
for i from 0 to 18 do
 s[i] := NF_Y(aa^i + bb^i + cc^i);
od:

# Formulae in the Claim labelled claim-A
_ASSERT(
 map(NF_Y,{
  c[1]+c[3]^3,
  c[1]^3
 }) = {0},
 "claim-A"
):

# Formulae in the Claim labelled claim-B and its proof
_ASSERT(
 map(NF_Y,{
  c[2]^6,
  s[1]-c[1],
  s[2]-(c[1]^2+c[2]),
  s[3],
  s[4]-c[1]*s[3]+c[2]*s[2]-c[3]*s[1],
  s[12]-s[4]^3,
  aa^27,bb^27,cc^27,
  aa4 - (aa + aa^9),
  bb4 - (bb + bb^9),
  cc4 - (cc + cc^9),
  aa4^4 - (aa^4 + aa^12),
  bb4^4 - (bb^4 + bb^12),
  cc4^4 - (cc^4 + cc^12)
 }) = {0},
 "claim-B"
):

# Formulae in the Claim labelled claim-C and its proof
_ASSERT(
 map(NF_Y,{
  c[1]*c[2]                                   - c[2]^3 * (-c[2]*c[3]),
  c[3]^3*c[2]                                 - c[2]^3 * ( c[2]*c[3]),
  aa^3-c[1]*aa^2+c[2]*aa-c[3],
  aa^9 - c[3]^3                               - c[2]^3 * (-aa^3),
  aa^9 + c[1]                                 - c[2]^3 * (-aa^3),
  aa4 - (aa - c[1])                           - c[2]^3 * (-aa^3),
  aa4*bb4*cc4 - (aa-c[1])*(bb-c[1])*(cc-c[1]) - c[2]^3*(-c[2]*c[3]),
  aa4*bb4*cc4 - (c[3]-c[2]*c[1])              - c[2]^3*(-c[2]*c[3]),
  aa4*bb4*cc4 - c[3]
 }) = {0},
 "claim-C"
):

# Formulae in Corollary cor-C and its proof
_ASSERT(
 map(NF_Y,{
  c[3]^6*c[2]^2,
  c[3]^3*c[2]^4,
  c[3]^3*c[2]-c[2]^3*(c[2]*c[3]),
  c[2]^6
 }) = {0},
 "cor-C"
):

# Formulae in the Claim labelled claim-D and its proof
_ASSERT(
 map(NF_Y,{
  c[3]^3*c[2]-c[3]*c[2]^4,
  aa^3-c[1]*aa^2+c[2]*aa-c[3],
  aa^9+c[2]^3*aa^3-c[3]^3,
  aa^9+c[2]^3*aa^3-c[3]^3,
  aa^9-c[2]^3*c[3]^3*aa^2-c[2]^4*aa+c[2]^3*c[3]-c[3]^3,
  F_K(aa,aa^9) - (aa+aa^9),
  F_K(aa,aa^9) - (alpha + beta*aa + gamma*aa^2),
  alpha*beta - alpha,
  beta*gamma - gamma,
  gamma^2,
  alpha^3,
  alpha^2*gamma,
  beta^3 - 1,
  alpha^2*c[1],
  alpha*gamma*c[1]*c[2],
  gamma*c[1]*c[3],
  aa4*bb4*cc4 -
   ((alpha+beta*aa+gamma*aa^2) *
    (alpha+beta*bb+gamma*bb^2) *
    (alpha+beta*cc+gamma*cc^2)),
  aa4*bb4*cc4 - (alpha^2*c[1]+alpha*c[2]+alpha*gama*c[1]*c[2]+c[3]+gamma*c[1]*c[3]),
  alpha^2*c[1],
  -(c[3]^3-c[2]^3*c[3])^2*c[3]^3,
  alpha*gamma*c[1]*c[2],
  gamma*c[1]*c[3],
  aa4*bb4*cc4 - (c[3]+alpha*c[2]),
  alpha*c[2]
 }) = {0},
 "claim-D"
):

# Formulae in the Claim labelled claim-E and its proof
_ASSERT(
 map(NF_Y,{
  c[3]^6-c[2]^5,
  aa4^2 - (aa^2-aa^10+aa^18),
  aa4^2+bb4^2+cc4^2 - (s[2]-s[10]+s[18]),
  s[18],
  s[10],
  aa^9-(alpha+(beta-1)*aa+gamma*aa^2),
  gamma,
  aa^10 - (alpha*aa + (beta-1)*aa^2),
  s[10] - (alpha*s[1] + (beta-1)*s[2]),
  s[10] - (-c[3]^6+c[2]^5)
 }) = {0},
 "claim-E"
):

# Groebner basis for O_Y
_ASSERT(
 mods(basis_Y1,3) = [c[2]^6,c[3]^3*c[2]-c[3]*c[2]^4,c[3]^6-c[2]^5,c[1]+c[3]^3],
 "prop-Y"
):

# Formulae in the Claim labelled claim-F and its proof
_ASSERT(
 map(NF_Y,{
  dd - (aa-bb+aa^6*bb^3-aa^3*bb^6),
  aa^9+c[2]^3*aa^3-c[3]^3,
  bb^9+c[2]^3*bb^3-c[3]^3,
  (c[2]^3)^2,
  c[2]^3*c[3]^3,
  (c[3]^3)^2-c[2]^5,
  aa^9*bb^9 - c[2]^5,
  aa^3-(-c[3]^3*aa^2-c[2]*aa+c[3]),
  aa^12 * bb^9  - c[2]^5*c[3],
  aa^9  * bb^12 - c[2]^5*c[3],
  aa^9 * bb^9 * (bb^3 - aa^3)
 }) = {0},
 "claim-F"
):

# Formulae in the Claim labelled claim-G and its proof
_ASSERT(
 map(NF_Y,{
  c[2] - (-(aa^2+aa*bb+bb^2)-(aa+bb)*c[3]^3),
  c[3] - (-aa*bb*(aa+bb)-aa*bb*c[3]^3),
  aa+bb - (-c[3]^3-cc),
  aa*bb - (cc^2+c[3]^3*cc+c[2]),
  aa^9*bb^9 - c[2]^5,
  (aa-bb)^2 - (-c[2]-(aa+bb)*c[3]^3),
  aa^3-bb^3 - (-c[2]*(aa-bb)-c[3]^3*(aa^2-bb^2)),
  aa^9-bb^9 - c[2]^4*(aa-bb),
  aa+bb+cc-c[1],
  aa+bb+cc+c[3]^3,
  c[2] - (-(aa^2+aa*bb+bb^2)-(aa+bb)*c[3]^3),
  c[3] - (-aa*bb*(aa+bb)-aa*bb*c[3]^3),
  cc^2 + cc * c[3]^3 + c[2] - aa * bb,
  - aa^18 - aa^9 * bb^9 - bb^18,
  aa^18 + bb^18 + c[2]^5
 }) = {0},
 "claim-G"
):

# Formulae in the Claim labelled claim-H
_ASSERT(
 map(NF_Y,{
  s[ 1] - (-c[3]^3),
  s[ 2] - (c[2]+c[2]^5),
  s[ 3],
  s[ 4] - (-c[3]^4-c[2]^2),
  s[ 5] - (c[3]*c[2]),
  s[ 6] - (c[2]^3),
  s[ 7] - (-c[3]^5+c[3]*c[2]^2),
  s[ 8] - (-c[2]^4+c[3]^2*c[2]),
  seq(s[i],i=9..18)
 }) = {0},
 "claim-H"
);

# Formula in the Claim labelled claim-I
_ASSERT(
 NF_Y(
  dd - (aa-bb)*(1-c[3]^2*c[2]+c[3]^2*c[2]^5-c[2]^4-(c[3]*c[2]^2-c[3]^5)*cc-c[2]^3*cc^2)
 ) = 0,
 "claim-I"
);

# Formulae in the Claim labelled claim-J and its proof
_ASSERT(
 map(NF_Y,{
 dd^3 - (aa-bb)^3,
 dd^3 - (-c[3]^3*(aa^2-bb^2)-c[2]*(aa-bb)),
 c[2]^4*dd - c[2]^4*(aa-bb)*(1-c[2]*c[3]^2),
 c[2]^4*dd^4,
 c[2]^4*(aa-bb)^4,
 c[2]^5*dd - c[2]^5*(aa-bb),
 c[2]^5*dd^2,
 dd-(aa-bb) - aa^3*bb^3*(aa^3-bb^3),
 aa^9*bb^9*(aa^9-bb^9),
 c[2]^4*c[3]^3,
 aa^3-bb^3+c[3]^3*(aa^2-bb^2)+c[2]*(aa-bb),
 c[2]^4*(aa^3-bb^3)+c[2]^5*(aa-bb),
 (c[3]^3)                      * c[2]^5,
 (c[2])                        * c[2]^5,
 (aa*bb-cc^2)                  * c[2]^5,
 ((aa*bb)^3-cc^6)              * c[2]^5,
 (cc^3-c[3])                   * c[2]^5,
 (cc^6-c[3]^2)                 * c[2]^5,
 c[2]^4*(aa^3-bb^3)*(aa*bb)^3 + c[2]^5*c[3]^2*(aa-bb),
 (aa-bb)^2+c[2]+(aa+bb)*c[3]^3
 }) = {0},
 "claim-J"
);

points_E := map(NF_Y,[
 F_K(aa,-bb), F_K(bb,-cc), F_K(cc,-aa),
 F_K(bb,-aa), F_K(cc,-bb), F_K(aa,-cc)
]):
f_E := NF_Y(expand(mul(t - u,u in points_E)));

vars_Z := plex(aa,bb,cc,c[1],z,c[3],c[2]):

az := rem(NF_Y(F_K(aa,z)),z^9,z);
bz := rem(NF_Y(F_K(bb,z)),z^9,z);
cz := rem(NF_Y(F_K(cc,z)),z^9,z);

rels_Z := {
 op(basis_Y),
 z^9,
 c[1] - (az+bz+cz),
 c[2] - (az*bz+bz*cz+cz*az),
 c[3] - (az*bz*cz)
}:
basis_Z := Basis(rels_Z,vars_Z,characteristic=p):
NF_Z := (u) -> mods(NormalForm(u,basis_Z,vars_Z,characteristic=p),p):

vars_Z1 := plex(c[1],z,c[3],c[2]):
basis_Z1 := remove(has,basis_Z,{aa,bb,cc});
cobasis_Z1 := cobasis(basis_Z1,vars_Z1);

# Formulae in the Claim labelled claim-K and its proof
_ASSERT(
 map(NF_Z,{
  t^3 * f_E - (t^9 - c[2]^5*t^7 + c[2]^3 * t^3),
  F_K(aa,-bb) - dd,
  F_K(bb,-aa) - (-dd),
  F_K(aa,-cc) - (-dd+aa^9),
  F_K(cc,-aa) - ( dd-aa^9),
  F_K(cc,-bb) - (-dd-bb^9),
  F_K(bb,-cc) - ( dd+bb^9),
  f_E - (t^2-dd^2)*(t^2-(dd-aa^9)^2)*(t^2-(dd+bb^9)^2),
  (dd-aa^9)^2*(dd+bb^9)^2 - dd^4,
  coeff(f_E,t,4) - (-dd^2-(dd-aa^9)^2-(dd+bb^9)^2),
  coeff(f_E,t,4) - (-c[2]^4*(aa-bb)*dd+c[2]^5),
  c[2]^4*dd-c[2]^4*(aa-bb)*(1-c[2]*c[3]^2),
  (aa-bb)^2+c[2]+(aa+bb)*c[3]^3,
  coeff(f_E,t,4) + c[2]^5,
  coeff(f_E,t,2) - (dd^2*(dd-aa^9)^2+dd^2*(dd+bb^9)^2+(dd-aa^9)^2*(dd+bb^9)^2),
  coeff(f_E,t,2),
  coeff(f_E,t,0) + dd^6
 }) = {0},
 "claim-K"
);

# Formulae in the Claim labelled claim-L and its proof
_ASSERT(
 map(NF_Z,{
  z^9,
  z^3+(c[2]+c[2]^2*c[3]^2)*z,
  (c[3]^3-c[3]*c[2]^3)*z,
  az - z - aa*(1 - z^3*aa^5 - z^6*aa^2),
  (aa-z)*(bb-z)*(cc-z) -
   c[3]*(1-z^3*aa^5-z^6*aa^2)*
        (1-z^3*bb^5-z^6*bb^2)*
        (1-z^3*cc^5-z^6*cc^2),
  c[2]^3*z^3,
  c[3]-c[2]*z+c[1]*z^2-z^3-(c[3]-c[3]*s[5]*z^3-c[3]*s[2]*z^6-c[3]*mm*z^6),
  s[5]-c[3]*c[2],
  c[2]*z+z^3*(1-c[3]^2*c[2]),
  c[3]^4*c[2]^2*z^3,
  c[3]^2*c[2]^5*z^3,
  (c[2]+c[3]^2*c[2]^2)*z+z^3,
  az^2 - (aa^2-z*aa+z^2+z^3*aa^7+z^4*aa^6+z^6*(aa^12+aa^4)+z^7*aa^3),
  az^2 + bz^2 + cz^2 - (s[2]-z*s[1]+z^3*s[7]+z^6*(s[12]+s[4])+z^7*s[3]),
  -z*s[1]+z^3*s[7]+z^4*s[6]+z^6*(s[12]+s[4])+z^7*s[3],
  -z*s[1]+z^3*s[7]+z^7*s[3],
  s[1]+c[3]^3,
  s[3],
  s[7]-(-c[3]^5+c[3]*c[2]^2),
  z^3+(c[3]^2*c[2]^2+c[2])*z,
  (c[3]^3-c[3]*c[2]^3)*z
 }) = {0},
 "claim-L"
):

vars_ZW := plex(aa,bb,cc,c[1],z,w,c[3],c[2]):
rels_ZW := {
 op(basis_Z),
 op(subs(z = w,basis_Z))
}:
basis_ZW := Basis(rels_ZW,vars_ZW,characteristic=p):
NF_ZW := (u) -> mods(NormalForm(u,basis_ZW,vars_ZW,characteristic=p),p):

vars_ZW1 := plex(c[1],z,w,c[3],c[2]):
basis_ZW1 := remove(has,basis_ZW,{aa,bb,cc});
cobasis_ZW1 := cobasis(basis_ZW1,vars_ZW1);

points_ZW := map(NF_ZW,[
 0,z,-z,w,-w,F_K(z,w),F_K(z,-w),F_K(-z,w),F_K(-z,-w)
]):

f_ZW := t^9 + uu^3*z^2*w^2*t^7 - (uu*z^2*w^2+uu^2*(z^2+w^2))*t^3;

# Formulae in the Claim labelled claim-M and its proof

### UNFINISHED
_ASSERT(
 map(NF_ZW,{
  f_ZW - mul(t-m,m in points_ZW),
  z^3 + uu*z,
  z^9,
  uu^4*z,
  F_K(z, w) - (z+w)*(1+uu^3*z*w),
  F_K(z,-w) - (z-w)*(1-uu^3*z*w),
  F_K(z, w)^2 - (z+w)^2 - uu^3*z^2*w^2,
  F_K(z,-w)^2 - (z-w)^2 - uu^3*z^2*w^2,
  uu      * z^2*w^2*uu^3,
  z       * z^2*w^2*uu^3,
  w       * z^2*w^2*uu^3
 }) = {0},
 "claim-M"
):

vars_C := vars_ZW:
rels_C := {op(basis_ZW),coeffs(mods(expand(f_ZW - t^3*f_E),p),t)}:
basis_C := Basis(rels_C,vars_C,characteristic=p);
NF_C := (u) -> mods(NormalForm(u,basis_C,vars_C,characteristic=p),p);

vars_C1 := plex(c[1],z,w,c[3],c[2]);
basis_C1 := mods(remove(has,basis_C,{aa,bb,cc}),p);
cobasis_C1 := cobasis(basis_C1,vars_C1);

_ASSERT(nops(cobasis_C1) = 108,"C(K,G) has rank 108");

rels_C1_alt := [
c[3]^6-c[2]^5,
c[3]^3*c[2]-c[3]*c[2]^4,
c[2]^6,
c[3]^3*z-c[3]*c[2]^3*z,
c[2]^4*z,
z^3+c[2]*z+c[3]^2*c[2]^2*z,
c[3]^3*w-c[3]*c[2]^3*w,
c[2]^4*w,
w^3+c[2]*w+c[3]^2*c[2]^2*w,
uu*z^2*w^2+uu^3+uu^2*(z^2+w^2)
]:

map(NF_C,rels_C1_alt);

cza[1] := mods(expand(rem(expand(a + F_E(a,z) + F_E(a,-z)),z^8+3,z)),p^6):
cza[2] := mods(expand(rem(expand(a * F_E(a,z) + a * F_E(a,-z) + F_E(a,z)*F_E(a,-z)),z^8+3,z)),p^6):
cza[3] := mods(expand(rem(expand(a * F_E(a,z) * F_E(a,-z)),z^8+3,z)),p^6):

# Series for [3](x) in terms of y = x(x+_Fz)(x-_Fz) assuming <3>(z)=0
nn := (z,y) ->
   z^6*y+
28    *y^3-
27*z^2*y^5-
39*z^4*y^7+
 9*z^2*y^13-
27    *y^19+
27*z^4*y^23-
 9*z^6*y^25+
27*z^4*y^31-
27*z^6*y^49-
27*z^6*y^73;

# Series for c_2({x,x+_Fz,x-_Fz}) in terms of y = x(x+_Fz)(x-_Fz) assuming <3>(z)=0
mm := (z,y) ->
-z^2+
38*z^4*y^2+
35*z^6*y^4+
27    *y^6-
21*z^2*y^8-
 6*z^4*y^10+
 9*z^6*y^12+
18*z^2*y^16+
18*z^6*y^20+
 9    *y^22-
24*z^2*y^24-
15*z^4*y^26+
39*z^6*y^28+
36*z^2*y^32-
 9*z^4*y^34-
27*z^6*y^36+
27*z^2*y^40-
27*z^4*y^42+
27*z^6*y^44+
27    *y^46+
18*z^2*y^48-
36*z^4*y^50+
18*z^6*y^52-
27*z^2*y^56+
27*z^4*y^58;

_ASSERT(
 mods(expand(rem(T["p_series"](a)-nn(z,cza[3]),z^8+3,z)),p^4) = 0,
 "Defining property of nn"
);

# The assertion below actually works mod (p^4,p^3z^6) but for simplicity
# we just check mod p^3.
_ASSERT(
 mods(expand(rem(cza[2]-mm(z,cza[3]),z^8+3,z)),p^3) = 0,
 "Defining property of nn"
);

mu := 1+3^8+3^16+3^18;

# 3-adic square root of -2
rr := 5-3^3+3^5-3^6-3^7+3^11+3^12-3^14-3^15-3^17-3^18+3^20-3^22-3^23-3^24;
nu := mods((rr-2)/(3*mu),p^25);
lm := 1 + 3 * mu * nu;

_ASSERT(
 modp(rem(T["p_series"](x),x^9+3*mu*x,x),p^25) = 0,
 "Defining property of mu"
);

_ASSERT(
 modp(rr^2+2,p^25) = 0,
 "Defining property of rr = sqrt(-2)"
);

_ASSERT(
 mods(rem(rem(nn(z,y),y^3+y*z^6,y),z^8+3,z),p^4) = 0,
 "Consistency check for nn"
);

_ASSERT(
 mods(rem(rem(mm(z,y)+z^2+nu*z^4*y^2,y^3+y*z^6,y),z^8+3,z),p^4) = 0,
 "Consistency check for mm"
);

char0 := proc(t)
 local u,v;
 u := subs(LL = 1+3*MU*NU,t);
 v :=
 [rem(subs({z=0,w=0,c[2]=3*a^2,c[3]=a^3},u),a^9+3*MU*a,a),
  rem(rem(subs({w= 0,c[2]=-NU*z^4*y^2-z^2,c[3]=y},u),y^3+y*z^6,y),z^8+3*MU,z),
  rem(rem(subs({w= z,c[2]=-NU*z^4*y^2-z^2,c[3]=y},u),y^3+y*z^6,y),z^8+3*MU,z),
  rem(rem(subs({w=-z,c[2]=-NU*z^4*y^2-z^2,c[3]=y},u),y^3+y*z^6,y),z^8+3*MU,z),
  rem(rem(subs({z= 0,c[2]=-NU*w^4*y^2-w^2,c[3]=y},u),y^3+y*w^6,y),w^8+3*MU,w)
 ];
 v := simplify(subs(NU = (sqrt(-2)-2)/(3*MU),v));
 return v;
end:

char := proc(t)
 local u;
 u := char0(t);
 [seq(coeff(u[1],a,i),i=0..8),
  seq(seq(seq(coeff(coeff(u[i],y,k),z,j),k=0..2),j=0..7),i=2..4),
      seq(seq(coeff(coeff(u[5],y,k),w,j),k=0..2),j=0..7)];
end:

SS :=
 (3*MU^2*NU^2+2*MU*NU-3)/MU/((1+3*MU*NU)^3-27) * c[3]^2*(c[2]^3-27*c[3]^2) +
 (3/MU) * c[3]^4 +
 c[2]^2 +
 w^2*z^2 +
 (w^2+z^2)*c[2] +
 (NU/(1+3*MU*NU)^2) * (z^2+w^2)*c[2]^2*c[3]^2;

rels_E_lift := [
 (LL+6)*c[2]^6+(-36*LL-192)*c[3]^2*c[2]^3+(3*LL*MU+18*MU)*c[2]^2+(252*LL+864)*c[3]^4,
 (-LL*MU-3*MU)*c[2]^5+(16*LL*MU+68*MU)*c[3]^2*c[2]^2+(-3*LL*MU^2-9*MU^2)*c[2]+(-32*LL-36)*c[3]^6,
 -c[2]^4*c[3]+(4*LL+24)*c[3]^3*c[2]+(36*LL*MU-27*MU)*c[3],
 z*c[3]*(-c[2]^3+(LL+6)*c[3]^2),
 w*c[3]*(-c[2]^3+(LL+6)*c[3]^2),
 z*((c[2]^4+3*MU)-(4*LL+20)/3*c[2]*c[3]^2),
 w*((c[2]^4+3*MU)-(4*LL+20)/3*c[2]*c[3]^2),
 (LL^2*(c[2]+z^2) + (LL-1)/(3*MU)*c[2]^2*c[3]^2)*z,
 (LL^2*(c[2]+w^2) + (LL-1)/(3*MU)*c[2]^2*c[3]^2)*w,
 SS
];

ss := mods(subs({MU = mu,NU = nu},SS),p^25);

_ASSERT(
 {rem(subs({z=0,w=0,c[2]=3*a^2,c[3]=a^3},SS),a^8+3*MU,a),
  rem(rem(subs({w= 0,c[2]=-NU*z^4*y^2-z^2,c[3]=y},SS),y^3+y*z^6,y),z^8+3*MU,z),
  rem(rem(subs({w= z,c[2]=-NU*z^4*y^2-z^2,c[3]=y},SS),y^3+y*z^6,y),z^8+3*MU,z),
  rem(rem(subs({w=-z,c[2]=-NU*z^4*y^2-z^2,c[3]=y},SS),y^3+y*z^6,y),z^8+3*MU,z),
  rem(rem(subs({z= 0,c[2]=-NU*w^4*y^2-w^2,c[3]=y},SS),y^3+y*w^6,y),w^8+3*MU,w)
 } = {0},
 "Character theory relation"
);

vars_E := vars_C1:
rels_E := {op(basis_C1),mods(ss,p)}:
basis_E := Basis(rels_E,vars_E,characteristic=p);
NF_E := (u) -> mods(NormalForm(u,basis_E,vars_E,characteristic=p),p);
cobasis_E := cobasis(basis_E,vars_E);

_ASSERT(nops(cobasis_E) = 105,"E^0(BG) has rank 105");


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

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

(* type: mgga_exc *)

$define lda_c_pw_params
$define lda_c_pw_modified_params
$include "lda_c_pw.mpl"

rmggac_gamma1 := 0.08:
rmggac_gamma2 := 0.3:
rmggac_g := (alpha, s) ->
  (1 + rmggac_gamma1)*alpha/(rmggac_gamma1 + alpha + rmggac_gamma2*s^2):

rmggac_f2 := (alpha, s) ->
  3*rmggac_g(alpha, s)^3/(1 + rmggac_g(alpha, s)^3 + rmggac_g(alpha, s)^6):
rmggac_f1 := (alpha, s) ->
  1 - rmggac_f2(alpha, s):

rmggac_gamma := 0.031091:

(* from gga_c_regtpss *)
beta_a := 0.066724550603149220:
beta_b := 0.1:
beta_c := 0.1778:
mbeta := (rs, t) -> beta_a*(1 + beta_b*rs)/(1 + beta_c*rs):
(* from mgga_c_r2scan *)
rmggac_w1 := (rs, z) -> exp(-f_pw(rs, z)/(rmggac_gamma*mphi(z)^3)) - 1:
(* from gga_c_pbe *)
A := (rs, z, t) -> mbeta(rs, t)/(rmggac_gamma * rmggac_w1(rs, z)):
(* from gga_c_scan_e0 *)
scan_e0_g := (rs, z, t) -> (1 + 4*A(rs, z, t)*t^2)^(-1/4):
(* from mgga_c_r2scan *)
rmggac_H1 := (rs, z, t) -> rmggac_gamma*mphi(z)^3*log(1 + rmggac_w1(rs, z) * (1 - scan_e0_g(rs, z, t))):

(* from mgga_c_scan *)
scan_alpha := (z, xt, ts0, ts1) ->
  (t_total(z, ts0, ts1) - xt^2/8)/(K_FACTOR_C*t_total(z, 1, 1)):
scan_b1c := 0.0285764:
scan_b2c := 0.0889:
scan_b3c := 0.125541:
scan_eclda0 := rs -> -scan_b1c/(1 + scan_b2c*sqrt(rs) + scan_b3c*rs):

scan_chi_infty := 0.12802585262625815:
scan_g_infty := s -> 1/(1 + 4*scan_chi_infty*s^2)^(1/4):
scan_G_cnst := 2.3631:
scan_Gc := z -> (1 - scan_G_cnst*(2^(1/3) - 1)*f_zeta(z))*(1 - z^12):

scan_H0 := (rs, s) ->
  scan_b1c*log(1 + (exp(-scan_eclda0(rs)/scan_b1c) - 1)*(1 - scan_g_infty(s))):
scan_e0 := (rs, z, s) ->
  (scan_eclda0(rs) + scan_H0(rs, s))*scan_Gc(z):

(* define the functional *)
rmggac_eps1 := (rs, z, t) ->
  (f_pw(rs, z) +  rmggac_H1(rs, z, t)):

rmggac_f := (rs, z, xt, xs0, xs1, ts0, ts1) ->
  + scan_e0(rs, z, X2S*2^(1/3)*xt)
      * rmggac_f1(scan_alpha(z, xt, ts0, ts1), X2S*2^(1/3)*xt)
  + rmggac_eps1(rs, z, tt(rs, z, xt))
      * rmggac_f2(scan_alpha(z, xt, ts0, ts1), X2S*2^(1/3)*xt):

f := (rs, z, xt, xs0, xs1, us0, us1, ts0, ts1) ->
  rmggac_f(rs, z, xt, xs0, xs1, ts0, ts1):


######################################################################
# SW(N)(A) is the sphere associated to the vector space W(N)(A).
# In the main LaTeX document this is called S(NWA).
#
# Elements are represented as nonzero elements of the space W(N)(A),
# with an appropriate equivalence relation built into the definition
# the function `is_equal/SW`.

`is_element/SW` := (N::posint) -> (A::set) -> proc(x)
 local x0,a;
 global reason;

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

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

 for a in A do
  if x0[a] <> [0$N] then return true; fi;
 od;

 reason := [convert(procname,string),"x is zero",x];
 return false;
end;

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

 x0 := `normalise/W`(N)(A)(x);
 r := max(0,seq(op(map(abs,x0[a])),a in A));
 for a in A do
  x0[a] := x0[a] /~ r;
 od;

 return(eval(x0));
end;

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

 x0 := `bottom_normalise/W`(N)(A)(x);
 r := max(0,seq(op(map(abs,x0[a])),a in A));
 for a in A do
  x0[a] := x0[a] /~ r;
 od;

 return(eval(x0));
end;

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

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

 for a in A do
  if not(`is_equal/R`(N)(x0[a],y0[a])) then
   return false;
  fi;
 od;

 return true;
end;

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

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

 d := 0;
 for a in A do
  d := d + `d_infinity/R`(N)(x0[a],y0[a]);
 od;

 return d;
end;

`normalise_2/SW` := (N::posint) -> (A::set) -> proc(x)
 local x0,u,r2,r,a;

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

 for a in A do
  x0[a] := x[a];
  u := u +~ x[a];
 od;
 u := u /~ nops(A);
 r2 := 0;
 for a in A do
  x0[a] := x0[a] -~ u;
  r2 := r2 + `norm_2/R`(N)(x0[a])^2;
 od;
 r := sqrt(r2);

 for a in A do
  x0[a] := x0[a] /~ r;
 od;

 return(eval(x0));
end;

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

 x0 := `normalise_2/SW`(N)(A)(x);
 y0 := `normalise_2/SW`(N)(A)(y);

 d := 0;
 for a in A do
  d := d + `d_2/R`(N)(x0[a],y0[a])^2;
 od;

 d := combine(simplify(expand(d)));
 d := combine(simplify(expand(sqrt(d))));
 return d;
end;

`is_leq/SW` := NULL;

`random_element/SW` := (N::posint) -> (A::set) -> proc()
 local x,ok;

 ok := false;

 while not(ok) do
  x := `random_element/W`(N)(A)();
  ok := `is_element/SW`(N)(A)(x);
 od:

 return eval(x);
end;

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


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

`is_element/cycord` := (A::set) -> proc(C)
 global reason;

 if not type(C,list) then
  reason := ["is_element/cycord","C is not a list",C];
  return false;
 fi;

 if nops(C) <> nops(A) then
  reason := ["is_element/cycord","C does not the same length as A",C,A];
  return false;
 fi;

 if {op(C)} <> A then
  reason := ["is_element/cycord","C is not an enumeration of A",C,A];
  return false;
 fi;

 return true;
end;

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

`is_equal/cycord` := (A::set) -> proc(C0,C1)
 local n,a,i,C2;

 n := nops(A);
 if n <= 2 then
  return true;
 fi;

 a := C0[1];
 i := 1;
 while i < n and C1[i] <> a do i := i+1; od;

 C2 := [op(i..n,C1),op(1..i-1,C1)];
 return evalb(C0 = C2);
end;

`is_leq/cycord` := NULL;

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

`op/cycord` := (A::set) -> proc(C)
 local n,i;
 n := nops(A);
 return [seq(C[n-i],i=0..n-1)];
end;

`res/cycord` := (A::set,B::set) -> proc(C)
 return select(a -> member(a,B),C);
end:

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

`random_element/cycord` := (A::set) -> proc()
 return combinat[randperm](A);
end:

`list_elements/cycord` := proc(A::set)
 local a,B;

 a := A[1];
 B := A minus {a};
 return map(C -> [a,op(C)],combinat[permute](B));
end:

`count_elements/cycord` := proc(A::set)
 return max(0,nops(A) - 1) !;
end:

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

`cut/cycord` := (A::set) -> (C) -> proc(a)
 local n,i;
 n := nops(C);
 if n <= 1 then return C; fi;
 i := 1;
 while i <= n and C[i] <> a do i := i+1; od;
 if i > n then error("a is not in C"); fi;
 return [op(i..n,C),op(1..i-1,C)];
end:

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

`cycord_is_strictly_cyclic` := (A::set) -> (C) -> proc(x::list)
 local n,S,a,i,y;

 n := nops(x);
 S := {op(x)};
 if n < 2 then return true; fi;
 if nops(S) < n then return false; fi;
 if S minus A <> {} then return false; fi;
 y := `cut/cycord`(A)(C)(x[1]);
 y := select(i -> member(i,S),y);
 return evalb(x = y);
end:

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

`cycord_is_cyclic` := (A::set) -> (C) -> proc(x)
 local n,y,i;
 n := nops(x);
 y := NULL;
 for i from 1 to n do
  if (i = n and x[n] <> x[1]) or (i < n and x[i] <> x[i+1]) then
   y := y,x[i];
  fi;
 od;
 y := [y];
 return `cycord_is_strictly_cyclic`(A)(C)(y);
end:

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

`open_interval/cycord` := (A::set) -> (C) -> proc(a,b)
 local n,i,J,C0;
 if a = b then return []; fi;
 C0 := `cut/cycord`(A)(C)(a);
 J := NULL;
 i := 2;
 n := nops(C0);
 while i <= n and C0[i] <> b do i := i+1; od;
 return [op(2..i-1,C0)];
end:

`half_open_interval/cycord` := (A::set) -> (C) -> proc(a,b)
 return [a,op(`open_interval/cycord`(A)(C)(a,b))];
end:

`closed_interval/cycord` := (A::set) -> (C) -> proc(a,b)
 return [a,op(`open_interval/cycord`(A)(C)(a,b)),b];
end:

`are_crossed/cycord` := (A::set) -> (C) -> proc(U,V)
 local C0,n,i,j,k;
 if U intersect V <> {} then return true; fi;
 if U = {} or V = {} then return false; fi;
 C0 := `cut/cycord`(A)(C)(U[1]);
 n := nops(C0);
 i := 2;
 while i <= n and not(member(C0[i],V)) do i := i+1; od;
 if i > n then return false; fi;
 j := i+1;
 while j <= n and not(member(C0[j],U)) do j := j+1; od;
 if j > n then return false; fi;
 k := j+1;
 while k <= n and not(member(C0[k],V)) do k := k+1; od;
 if k > n then return false; fi;
 return true;
end:

`is_convex/cycord` := (A::set) -> (C) -> proc(W)
 return not(`are_crossed/cycord`(A)(C)(W,A minus W));
end;


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

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

(* type: gga_exc *)

$include "gga_x_pw86.mpl"

params_a_aa := 2.208:
params_a_bb := 9.27:
params_a_cc := 0.2:

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


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

`mult/free_algebra` := () -> bar(args);

`commutator/free_algebra` := () -> bar(bracket(args));

`basis/free_algebra` := (A::set) -> proc(d::nonnegint)
 local i,B,a,b;
 B := [bar()];
 for i from 1 to d do
  B := [seq(seq(bar(op(b),a),a in A),b in B)];
 od:
 return B;
end:

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


# Center of Mass Calculation for the Robot based on MDH frames
# Introduction
# Berechnung der Schwerpunkts-Kinematik (Positionen)
#
# Dateiname:
# robot -> Berechnung für allgemeinen Roboter
# tree -> Berechnung für eine beliebige Baumstruktur (ohne Schleifen)
# floatb -> floating base wird durch base twist (Geschwindigkeit der Basis) oder vollständige Orientierung (Euler-Winkel) berücksichtigt
# rotmat -> Kinematik wird mit Rotationsmatrizen berechnet
# kinematics_com -> Kinematik der Körperschwerpunkte
# worldframe -> Berechnung der Geschwindigkeit im Welt-KS (KSW)
# par1 -> Parametersatz 1 (Schwerpunkt als Parameter: SX,SY,SZ)
# Testergebnisse
# Test des exportierten Matlab-Codes erfolgreich (kinetische Energie)
# Authors
# Moritz Schappler, schappler@irt.uni-hannover.de, 2014-11
# (C) Institut fuer Regelungstechnik, Leibniz Universitaet Hannover
# Sources
# [GautierKhalil1990] Direct Calculation of Minimum Set of Inertial Parameters of Serial Robots
# [KhalilDombre2002] Modeling, Identification and Control of Robots
# [Ortmaier2014] Vorlesungsskript Robotik I (WS 2014/15)
# [Ott2008] Cartesian Impedance Control of Redundant and Flexible-Joint Robots
# 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):
codegen_act := true:
codegen_opt := 2:
read "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../helper/proc_MatlabExport":
read "../helper/proc_simplify2":
read "../transformation/proc_rotx":
read "../transformation/proc_roty":
read "../transformation/proc_rotz":
read "../transformation/proc_trotx":
read "../transformation/proc_troty":
read "../transformation/proc_trotz":
read "../transformation/proc_transl":
read "../transformation/proc_trafo_mdh":
read "../robot_codegen_definitions/robot_env":
printf("%s. Generiere Schwerpunktskinematik für %s\n", FormatTime("%Y-%m-%d %H:%M:%S"), robot_name):
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions", robot_name):
read sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
kin_constraints_exist := kin_constraints_exist: # nur zum Abschätzen der Komplexität
;
if not assigned(simplify_options) or simplify_options(3)=-1 then # Standard-Einstellungen:
  if not kin_constraints_exist then # normale serielle Ketten und Baumstrukturen
    use_simplify := 0: # Standardmäßig aus
  else # mit kinematischen Zwangsbedingungen
    use_simplify := 1: # standardmäßig simplify-Befehle anwenden
  end if:
else # Benutzer-Einstellungen:
  use_simplify := simplify_options(3): # dritter Eintrag ist für CoM-Kinematik
end if:

# Ergebnisse der Kinematik laden
read sprintf("../codeexport/%s/tmp/kinematics_floatb_%s_rotmat_maple.m", robot_name, base_method_name):
Trf := Trf:
Trf_c := Trf_c:

# Positions of Center of Mass
r_W_i_Si := Matrix(3, NL):
r_W_W_Si := Matrix(3, NL):
mr_W_i_Si := Matrix(3, NL):
# Es gibt NL Körper (Basis und NJ bewegliche Körper).
# r_i_i_Si(1 .. 3, i) ist der Vektor vom Ursprung des Körper-KS i zum Schwerpunkt des Körpers i ausgedrückt im Körper-KS i
# r_W_i_Si(1 .. 3, i) ist der Vektor vom Ursprung des Körper-KS i zum Schwerpunkt des Körpers i ausgedrückt im Basis-KS
# mr_W_i_Si(1 .. 3, i) ist der Vektor vom Ursprung des Körper-KS i zum Schwerpunkt des Körpers i ausgedrückt im Basis-KS multipliziert mit der Masse des Segments i
# r_W_W_Si(1 .. 3, i) ist der Vektor vom Ursprung des Basis-KS zum Schwerpunkt des Körpers i ausgedrückt im Basis-KS
# Trf_c(1 .. 3, 1 .. 3, i) ist das Körperkoordinatensystem zu Körper i im Basis KS.
for i to NL do
  r_W_i_Si(1 .. 3, i) :=  Multiply(Matrix(Trf_c(1 .. 3, 1 .. 3, i)), r_i_i_Si(1 .. 3, i)):
  if use_simplify>=1 then
    tmp_t11:=time():
    tmp_l11 := length(r_W_i_Si(1 .. 3, i)):
    printf("%s. Vereinfache Schwerpunktskoordinaten. Länge: %d (r_i_i_Si).\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l11):
    r_W_i_Si(1 .. 3, i) := simplify2(r_W_i_Si(1 .. 3, i)):
    tmp_l21 := length(r_W_i_Si(1 .. 3, i)):
    tmp_t21:=time():
  end if:
  mr_W_i_Si(1 .. 3, i) := Multiply(Matrix(Trf_c(1 .. 3, 1 .. 3, i)), mr_i_i_Si(1 .. 3, i)):
  r_W_W_Si(1 .. 3, i) :=  Matrix(Trf_c(1 .. 3, 4, i)) + Matrix(r_W_i_Si(1 .. 3, i)):
  printf("%s. Schwerpunktsposition in Weltkoordinaten für Körper %d aufgestellt.\n", FormatTime("%Y-%m-%d %H:%M:%S"), i-1):#0=Basis
  if use_simplify>=1 then
    tmp_t12:=time():
    tmp_l12 := length(mr_W_i_Si(1 .. 3, i)):
    tmp_l13 := length(r_W_W_Si(1 .. 3, i)):
    printf("%s. Vereinfache Schwerpunktskoordinaten. Länge: %d/%d (r_W_W_Si/mr_W_i_Si).\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l13, tmp_l12):
    mr_W_i_Si(1 .. 3, i) := simplify2(mr_W_i_Si(1 .. 3, i)):
    r_W_W_Si(1 .. 3, i) := simplify2(r_W_W_Si(1 .. 3, i)):
    tmp_l22 := length(mr_W_i_Si(1 .. 3, i)):
    tmp_l23 := length(r_W_W_Si(1 .. 3, i)):
    tmp_t22:=time():
    printf("%s. Terme für Schwerpunktskoord. vereinfacht. Länge: %d->%d / %d->%d / %d->%d (r_W_i_Si / mr_W_i_Si / r_W_W_Si). Rechenzeit %1.1fs und %1.1fs.\n", \
      FormatTime("%Y-%m-%d %H:%M:%S"), tmp_l11, tmp_l21, tmp_l12, tmp_l22, tmp_l13, tmp_l23, tmp_t21-tmp_t11, tmp_t22-tmp_t12):
  end if:
end do:
# Maple Export
save mr_W_i_Si, r_W_W_Si, r_W_i_Si, sprintf("../codeexport/%s/tmp/kinematics_com_worldframe_floatb_%s_par1_maple.m", robot_name, base_method_name):
printf("Maple-Ausdrücke exportiert.\n"):
# Matlab-Export
if codegen_act then
  MatlabExport(convert_t_s(r_W_W_Si), sprintf("../codeexport/%s/tmp/fkine_com_floatb_%s_matlab.m", robot_name, base_method_name), codegen_opt):
end if:
# Calculate CoM of the whole robot
c:=Vector(3):
M_ges:=0:
for i from 1 to NL do
  c:=c + r_W_W_Si(1 .. 3,i)*M[i,1]:
  M_ges:=M_ges + M[i,1]:
end do:
c:=c/M_ges:
# Maple-Export
save c, sprintf("../codeexport/%s/tmp/kinematics_com_total_worldframe_floatb_%s_par1_maple.m", robot_name, base_method_name):
# Matlab-Export
if codegen_act then
  MatlabExport(convert_t_s(c), sprintf("../codeexport/%s/tmp/com_total_worldframe_floatb_%s_par1_matlab.m", robot_name, base_method_name), codegen_opt):
end if:


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

XX := (z, xs) -> xs*opz_pow_n(z,4/3)*2^(-4/3):
YY := (z, xt, xs0, xs1) -> 2*(XX(z, xs0)^2 + XX(-z, xs1)^2) - xt^2:

f_th := (rs, z, xt, xs0, xs1) -> add(params_a_omega[i]
  * (n_spin(rs, z)^params_a_a[i] + n_spin(rs, -z)^params_a_a[i])
  * z^(2*params_a_b[i])
  * 1/2*(XX(z, xs0)^params_a_c[i] + XX(-z, xs1)^params_a_c[i])
  * YY(z, xt, xs0, xs1)^params_a_d[i], i=1..params_a_n)/n_total(rs):


# Berechne kinematische Zwangsbedingungen für den Palettierroboter MPL800-YASKAWA aus 3 Viergelenkketten
# Einleitung

# Die kinematischen Zwangsbedingungen werden als Ersetzungsausdruck für die abhängigen Winkel aufgestellt.
#
# palh1m1TE -> MPL800 II-Yaskawa, modellierung der Zwangsbedingungen mit Ausdrücken für trigonometrische Elimination
# kinematic_constraint -> Kinematische Zwangsbedingungen
# Datenblatt des Roboters unter :   https://www.motoman.com/industrial-robots/mpl800-ii
# Voraussetzung
# Viergelenkkette muss mit der Toolbox berechnet worden sein (Arbeitsblatt "fourbar1TE_kinematic_constraints.mw")
# Quelle
# SA Bejaoui: Bejaoui2018_S749; "Modellierung kinematischer Zwangsbedingungen für hybride serielle Roboter mit planaren Parallelmechanismen"
# Autor
# Abderahman Bejaoui
# Studienarbeit bei: Moritz Schappler, moritz.schappler@imes.uni-hannover.de, 2018-08
# (C) Institut fuer mechatronische Systeme, Leibniz Universitaet Hannover
# Initialisierung
# Import
interface(warnlevel=0): # Unterdrücke die folgende Warnung.
restart: # Gibt eine Warnung, wenn über Terminal-Maple mit read gestartet wird.
interface(warnlevel=3):
kin_constraints_exist := true: # Für Speicherung
;
with(StringTools): # Für Zeitausgabe
with(LinearAlgebra):
with(codegen):
with(CodeGeneration):
#with(ListTools):
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 "../helper/proc_convert_s_t":
read "../helper/proc_convert_t_s":
read "../robot_codegen_constraints/proc_subs_kintmp_exp":
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":
read sprintf("../codeexport/%s/tmp/tree_floatb_definitions",robot_name):
# Variable mit Winkeln der Nebenstruktur nur in Abhängigkeit der verallgemeinerten Koordinaten
kintmp_qs := Matrix(RowDimension(kintmp_s),1):
# Konstante Winkel bereits hineinschreiben
for i from 1 to RowDimension(kintmp_s) do
  if diff(kintmp_s(i,1), t) = 0 then
    kintmp_qs(i,1) := kintmp_s(i,1):
  end if:
end do:
# Variablen definieren für die Hilfswinkel
#
# Ersetzungsausdrücke definieren.
# Speichere Sinus und Cosinus der Winkel direkt ab, da diese in den Rotationsmatrizen direkt auftreten.
# Spalte 1: Zu suchender Ausdruck (sin oder cos eines Winkels)
# Spalte 2: Einzusetzender Ausdruck.
# Dadurch werden arctan-Ausdrücke in der direkten Kinematik reduziert.
# Ähnliches Vorgehen wie in [1].
kintmp_subsexp := Matrix(2*RowDimension(kintmp_s),2):
for i from 1 to RowDimension(kintmp_s) do
  kintmp_subsexp(2*i-1, 1) := sin(kintmp_s(i,1)):
  kintmp_subsexp(2*i,   1) := cos(kintmp_s(i,1)):
  # Initialisierung der rechten Spalte mit gleichen Werten. Später nur Ersetzung, wenn Vorteilhaft.
  kintmp_subsexp(2*i-1, 2) := kintmp_subsexp(2*i-1, 1):
  kintmp_subsexp(2*i,   2) := kintmp_subsexp(2*i,   1):
end do:

# Sicherung der aktuellen Daten
backup_kintmp_qs := kintmp_qs:
backup_kintmp_qt := kintmp_qt:
backup_kintmp_subsexp := kintmp_subsexp:

read sprintf("../codeexport/fourbar1TE/tmp/kinematic_constraints_maple_inert.m"): # mit .m datei wird es schneller
;
kintmp_subsexp_fourbar := kintmp_subsexp:
kintmp_qs_fourbar := kintmp_qs:
kintmp_qt_fourbar := kintmp_qt:
kintmp_subsexp_fourbar:
winkel(6,2):
kintmp_subsexp_fourbar(6,2):
kintmp_subsexp_fourbar(3,2):
winkel_neu := Matrix(6,2):
winkel_neu(1,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(3,2)):
winkel_neu(2,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(4,2)):
winkel_neu(3,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(1,2)):
winkel_neu(4,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(2,2)):
winkel_neu(5,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(5,2)):
winkel_neu(6,2) := subs({qJ1s=phi_s}, kintmp_subsexp_fourbar(6,2)):
# Vorherige Werte für dieses System wieder herstellen
kintmp_qs := backup_kintmp_qs:
kintmp_qt := backup_kintmp_qt:
kintmp_subsexp := backup_kintmp_subsexp:
winkel_neu(1..6,1):
# Viergelenkkette 1: A-M-L-B
winkel1:=<<sin_rho28|sin(rho28_s)>;<cos_rho28|cos(rho28_s)>;<sin_rho312|sin(rho312_s)>;<cos_rho312|cos(rho312_s)>;<sin_rho89|sin(rho89_s)>;<cos_rho89|cos(rho89_s)>>:
for i from 1 to 6 do
	winkel1(i,2):=kintmp_subsexp_fourbar(i,2):
     cos_phi_s :=-(sin(qJ3s)*cos(phi312)+cos(qJ3s)*sin(phi312)):
	sin_phi_s := -(cos(qJ3s)*cos(phi312)-sin(qJ3s)*sin(phi312)):
	winkel1(i,2):=subs({sin(qJ1s)=sin_phi_s},winkel1(i,2)):
	winkel1(i,2):=subs({cos(qJ1s)=cos_phi_s},winkel1(i,2)):
     winkel1(i,2) := subs({l1=BL}, winkel1(i,2)):
     winkel1(i,2) := subs({l2=AB}, winkel1(i,2)):
     winkel1(i,2) := subs({l3=AM}, winkel1(i,2)):
     winkel1(i,2) := subs({l4=ML}, winkel1(i,2)):
end do:
winkel1:
# Umrechnung aus Zwangsbedingugen für Winkel aus MDH-Tabelle
sin_rho28_s:=winkel1(1,2): # schon in MDH
;
cos_rho28_s:=winkel1(2,2):  # schon in MDH
;
sin_rho312_s:=winkel1(3,2):  # schon in MDH
;
cos_rho312_s:=winkel1(4,2):  # schon in MDH
;
sin_rho89_s:=winkel1(5,2):    # für MDH , am 20.11 der neuen fourbar1 angepasst
;
cos_rho89_s:=winkel1(6,2):  # für MDH , am 20.11 der neuen fourbar1 angepasst
;
#sin_rho312_s:=sin_rho3_s:  # schon in MDH
;
#cos_rho312_s:=-cos_rho3_s:  # schon in MDH
;
# Viergelenkkette 2: A-B-C-D
winkel2:=<<sin_eta1|sin(eta1_s)>;<cos_eta1|cos(eta1_s)>;<sin_eta3|sin(eta3_s)>;<cos_eta3|cos(eta3_s)>;<sin_eta4|sin(eta4_s)>;<cos_eta4|cos(eta4_s)>>:
for i from 1 to 6 do
	winkel2(i,2):=kintmp_subsexp_fourbar(i,2):  #
	cos_phi_s :=sin(qJ2s)*cos(phi2)-cos(qJ2s)*sin(phi2):
	sin_phi_s :=cos(qJ2s)*cos(phi2)+sin(qJ2s)*sin(phi2):
	winkel2(i,2):=subs({sin(qJ1s)=sin_phi_s},winkel2(i,2)):
	winkel2(i,2):=subs({cos(qJ1s)=cos_phi_s},winkel2(i,2)):
     winkel2(i,2) := subs({l1=AB}, winkel2(i,2)):
     winkel2(i,2) := subs({l2=DA}, winkel2(i,2)):
     winkel2(i,2) := subs({l3=DC}, winkel2(i,2)):
     winkel2(i,2) := subs({l4=BC}, winkel2(i,2)):
 end do:
winkel2(1..6,1):
sin_eta1_s:=winkel2(1,2):
cos_eta1_s:=winkel2(2,2):
sin_eta3_s:=winkel2(3,2):
cos_eta3_s:=winkel2(4,2):
sin_eta4_s:=winkel2(5,2):
cos_eta4_s:=winkel2(6,2):
cos_eta16_s:=cos(phi1)*cos_eta1_s-sin(phi1)*sin_eta1_s:
sin_eta16_s:=cos(phi1)*sin_eta1_s+cos_eta1_s*sin(phi1):
cos_eta711_s:=-cos_eta4_s:
sin_eta711_s:=sin_eta4_s:
cos_eta27_s:=cos(phi711)*cos_eta3_s+sin(phi711)*sin_eta3_s: # am 20.11 der neuen fourbar1 angepasst
;
sin_eta27_s:=cos(phi711)*sin_eta3_s-cos_eta3_s*sin(phi711): # am 20.11 der neuen fourbar1 angepasst
;
# Viergelenkkette 3: B-E-P-G
winkel3:=<<sin_xi1016|sin(xi1016_s)>;<cos_xi1016|cos(xi1016_s)>;<sin_xi3|sin(xi3_s)>;<cos_xi3|cos(xi3_s)>;<sin_xi2|sin(xi2_s)>;<cos_xi2|cos(xi2_s)>>:
for i from 1 to 6 do
	winkel3(i,2):=kintmp_subsexp_fourbar(i,2):
	cos_phi_s :=(cos(phi711+phi710)*(sin(qJ3s)*cos_eta3_s-cos(qJ3s)*sin_eta3_s)+sin(phi711+phi710)*(cos(qJ3s)*cos_eta3_s+sin(qJ3s)*sin_eta3_s)):
	sin_phi_s := (cos(phi711+phi710)*(cos(qJ3s)*cos_eta3_s+sin(qJ3s)*sin_eta3_s)-sin(phi711+phi710)*(sin(qJ3s)*cos_eta3_s-cos(qJ3s)*sin_eta3_s)):
	winkel3(i,2):=subs({sin(qJ1s)=sin_phi_s},winkel3(i,2)):
	winkel3(i,2):=subs({cos(qJ1s)=cos_phi_s},winkel3(i,2)):
     winkel3(i,2) := subs({l1=BG}, winkel3(i,2)):
     winkel3(i,2) := subs({l2=BE}, winkel3(i,2)):
     winkel3(i,2) := subs({l3=EP}, winkel3(i,2)):
     winkel3(i,2) := subs({l4=GP}, winkel3(i,2)):
 end do:
winkel3(1..6,1):
sin_xi1016_s:=winkel3(1,2):
cos_xi1016_s:=winkel3(2,2):
sin_xi3_s:=winkel3(3,2):  # schon in MDH
;
cos_xi3_s:=winkel3(4,2): # schon in MDH
;
sin_xi2_s:=winkel3(5,2):
cos_xi2_s:=winkel3(6,2):
cos_xi34_s:=cos_xi3_s*cos(phi413)+sin_xi3_s*sin(phi413): # am 20.11 der neuen fourbar1 angepasst
;
sin_xi34_s:=-cos_xi3_s*sin(phi413)+sin_xi3_s*cos(phi413): # am 20.11 der neuen fourbar1 angepasst
;
cos_xi413_s:=-cos_xi2_s:
sin_xi413_s:=sin_xi2_s:
# Kintmp_subsexp
kintmp_subsexp(1,2):=sin_xi34_s:
kintmp_subsexp(2,2):=cos_xi34_s:
kintmp_subsexp(3,2):=sin_eta16_s:
kintmp_subsexp(4,2):=cos_eta16_s:
kintmp_subsexp(5,2):=sin_eta27_s:
kintmp_subsexp(6,2):=cos_eta27_s:
kintmp_subsexp(7,2):=sin_rho28_s:
kintmp_subsexp(8,2):=cos_rho28_s:
kintmp_subsexp(9,2):=sin_rho89_s:
kintmp_subsexp(10,2):=cos_rho89_s:
kintmp_subsexp(11,2):=sin_xi1016_s:
kintmp_subsexp(12,2):=cos_xi1016_s:
kintmp_subsexp(13,2):=sin_eta711_s:
kintmp_subsexp(14,2):=cos_eta711_s:
kintmp_subsexp(15,2):=sin_rho312_s:
kintmp_subsexp(16,2):=cos_rho312_s:
kintmp_subsexp(17,2):=sin_xi413_s:
kintmp_subsexp(18,2):=cos_xi413_s:
kintmp_subsexp(11..18,1):
# Kintmp_qs
kintmp_qs(1,1):=%arctan(sin_xi34_s,cos_xi34_s):
kintmp_qs(2,1):=%arctan(sin_eta16_s,cos_eta16_s):
kintmp_qs(3,1):=%arctan(sin_eta27_s,cos_eta27_s):
kintmp_qs(4,1):=%arctan(sin_rho28_s,cos_rho28_s):
kintmp_qs(5,1):=%arctan(sin_rho89_s,cos_rho89_s):
kintmp_qs(6,1):=%arctan(sin_xi1016_s,cos_xi1016_s):
kintmp_qs(7,1):=%arctan(sin_eta711_s,cos_eta711_s):
kintmp_qs(8,1):=%arctan(sin_rho312_s,cos_rho312_s):
kintmp_qs(9,1):=%arctan(sin_xi413_s,cos_xi413_s):
# Export
kintmp_qt := convert_s_t(kintmp_qs):
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple", robot_name):
save kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_subsexp_maple.m", robot_name):
#printf("Ausdrücke für kintmp_subsexp gespeichert (Maple). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
for i from 1 to RowDimension(kintmp_s) do
  tmp := kintmp_qs(i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d",robot_name, i):
  save tmp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert_kintmpq_%d.m", robot_name, i):
end do:
save kin_constraints_exist, kintmp_qs, kintmp_qt,kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert" ,robot_name):
save kin_constraints_exist, kintmp_qs, kintmp_qt, kintmp_subsexp, sprintf("../codeexport/%s/tmp/kinematic_constraints_maple_inert.m", robot_name):
save kintmp_qs, sprintf("../codeexport/%s/tmp/kinematic_constraints_kintmp_qs_maple_inert", robot_name):
#printf("Ausdrücke mit Inert-Arctan exportiert (Matlab). %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):
# Liste mit abhängigen konstanten Kinematikparametern erstellen (wichtig für Matlab-Funktionsgenerierung)
read "../helper/proc_list_constant_expressions";
kc_symbols := Matrix(list_constant_expressions( kintmp_subsexp ));
#kc_symbols :=Transpose(kc_symbols);
save kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_maple", robot_name):
MatlabExport(kc_symbols, sprintf("../codeexport/%s/tmp/kinematic_constraints_symbols_list_matlab.m",robot_name),2);
#printf("Fertig. %s. CPU-Zeit bis hier: %1.2fs.\n", FormatTime("%Y-%m-%d %H:%M:%S"), time()-st):


grassmann_count := (q) -> proc(n::nonnegint,d::nonnegint)
 local i;
 return factor(mul(q^(n-i)-1,i=0..d-1)/mul(q^(d-i)-1,i=0..d-1));
end:

splitting_count := (q) -> (n::nonnegint,m::nonnegint) ->
 grassmann_count(q)(n+m,n) * q^(n*m);

`indices/twisted_product/A` := proc(r::nonnegint)
 option remember;
 local U,V,u,v,e;

 if r = 0 then return [[]]; fi;
 if not(type(r,posint)) then return FAIL; fi;

 U := `indices/twisted_product/A`(r-1);
 V := NULL;
 for u in U do
  e := d-1-`+`(op(u));
  V := V,seq([op(u),v],v=0..e);
 od;
 return [V];
end:

`is_element/twisted_product/A` := (r::nonnegint) -> proc(f)
 if not(type(f,table)) then
  return false;
 fi;

 return evalb({indices(f)} = {op(`indices/twisted_product/A`(r))});
end:

`is_equal/twisted_product/A` := (r::nonnegint) -> proc(f,g)
 local U,u;

 U := `indices/twisted_product/A`(r);

 for u in U do
  if simplify(f[op(u)]-g[op(u)]) <> 0 then
   return false;
  fi;
 od;

 return true;
end:

`to_list/twisted_product/A` := (r::nonnegint) -> proc(f)
 local u;
 return [seq(f[op(u)],u in `indices/twisted_product/A`(r))];
end:

`from_symbol/twisted_product/A` := (r::nonnegint) -> proc(f)
 local u;
 return table([seq(op(u)=f[op(u)],u in `indices/twisted_product/A`(r))]);
end:

`zero/twisted_product/A` := proc(r::nonnegint)
 option remember;
 local u;
 return table([seq(op(u)=0,u in `indices/twisted_product/A`(r))]);
end:

`one/twisted_product/A` := proc(r::nonnegint)
 option remember;
 local u;
 return table([seq(op(u)=1,u in `indices/twisted_product/A`(r))]);
end:

`delta/twisted_product/A` := proc(r::nonnegint)
 option remember;
 local u;
 return table([seq(op(u)=`if`(u=[0$r],1,0),u in `indices/twisted_product/A`(r))]);
end:

`plus/twisted_product/A` := (r::nonnegint) -> proc(f,g)
 local u;
 return table([seq(op(u) = f[op(u)] + g[op(u)],u in `indices/twisted_product/A`(r))]);
end:

`minus/twisted_product/A` := (r::nonnegint) -> proc(f,g)
 local u;
 return table([seq(op(u) = f[op(u)] - g[op(u)],u in `indices/twisted_product/A`(r))]);
end:

`dot/twisted_product/A` := (r::nonnegint) -> proc(f,g)
 local u;
 return table([seq(op(u) = f[op(u)] * g[op(u)],u in `indices/twisted_product/A`(r))]);
end:

`scalar_times/twisted_product/A` := (r::nonnegint) -> proc(c,f)
 local u;
 return table([seq(op(u) = c * f[op(u)],u in `indices/twisted_product/A`(r))]);
end:

`mu/twisted_product/A` := (r::nonnegint) -> proc(u,v)
 option remember;
 local i,j;
 mul(splitting_count(q)(u[i],v[i]),i=1..r) *
 q^add(add(u[i]*v[j]+2*u[j]*v[i],j=i+1..r),i=1..r-1);
end:

`star/twisted_product/A` := (r::nonnegint) -> proc(f,g)
 local h,X,u,v,w,x;

 h := table([seq(op(u)=0,u in `indices/twisted_product/A`(r))]);

 X := `indices/twisted_product/A`(2*r);
 for x in X do
  u := [op(1..r,x)];
  v := [op(r+1..2*r,x)];
  w := u +~ v;
  h[op(w)] := h[op(w)] + `mu/twisted_product/A`(r)(u,v) * f[op(u)] * g[op(v)];
 od;

 return eval(h);
end:


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

binstr2dec := proc(b) convert(parse(b),decimal,2) end proc:
hex2bits := proc(input) uses StringTools; local tmp := Explode(input); Join(subs([
    "0" = "0000", "1" = "0001", "2" = "0010", "3" = "0011", "4" = "0100",
    "5" = "0101", "6" = "0110", "7" = "0111", "8" = "1000", "9" = "1001",
    "A" = "1010", "B" = "1011", "C" = "1100", "D" = "1101", "E" = "1110", "F" = "1111"],
        tmp),""); end proc:

processpacket := proc( bitinput )
local vertotal, ver, pid, rest, parts, lofbits, subpak, numpaks,
    n, val, theops, thevalue;

    if length(bitinput) < 6 then
        error "error %1 is too short to be valid", bininput;
    end if;

    PRINT("Processing %d bits", length(bitinput));

    ver := binstr2dec(bitinput[1..3]);
    pid := binstr2dec(bitinput[4..6]);
    rest := bitinput[7..];
    vertotal := ver;

    if pid = 4 then # literal
        PRINT("processing literal");
        parts := NULL;
        while rest[1] <> "0" do
            parts := parts, rest[2..5];
            rest := rest[6..];
        end do;
        parts := parts, rest[2..5];

        thevalue := binstr2dec(cat(parts));
        PRINT("literal had %d parts with value=%d", nops([parts]), thevalue);
        rest := rest[6..];
        PRINT("after literal %d bits left", length(rest));
    else
        PRINT("processing operator ID=%d", pid);
        theops := NULL;
        if rest[1] = "0" then

            lofbits := binstr2dec(rest[2..16]);
            PRINT("type-0 operator with %d bits of subpackets", lofbits);
            rest := rest[17..];
            subpak := rest[1..lofbits];
            while length(subpak) > 6 do
                (n, val, subpak) := thisproc(subpak);
                vertotal += n;
                theops := theops, val;
            end do;
            rest := rest[lofbits+1..];
            PRINT("after type-0 %d bits left", length(rest));
        else
            numpaks := binstr2dec(rest[2..12]);
            PRINT("type-1 operator with %d subpackets",numpaks);
            rest := rest[13..];
            to numpaks do
                (n, val, rest) := thisproc(rest);
                theops := theops, val;
                vertotal += n;
            end do;
            PRINT("after type-1 %d bits left", length(rest));
        end if;
        if pid = 0 then thevalue := `+`(theops);
        elif pid = 1 then thevalue := `*`(theops);
        elif pid = 2 then thevalue := min(theops);
        elif pid = 3 then thevalue := max(theops);
        elif pid = 5 then thevalue := ifelse( theops[1] > theops[2], 1, 0);
        elif pid = 6 then thevalue := ifelse( theops[1] < theops[2], 1, 0);
        elif pid = 7 then thevalue := ifelse( theops[1] = theops[2], 1, 0);
        else error "bad operator pid";
        end if;
    end if;

    PRINT("returning with %d bits left", length(rest));
    return vertotal, thevalue, rest;

end proc:

# uncomment for verbose output
#PRINT := s->printf(cat(s,"\n"), _rest);

(*
# unit tests
processpacket( hex2bits("C200B40A82") )[2]=3;
processpacket( hex2bits("04005AC33890") )[2]=54;
processpacket( hex2bits("880086C3E88112"))[2]=7;
processpacket( hex2bits( "CE00C43D881120" ) )[2]=9;
processpacket( hex2bits( "D8005AC2A8F0" ))[2]=1;
processpacket( hex2bits("F600BC2D8F") )[2]=0;
processpacket( hex2bits("9C005AC2F8F0") )[2] = 0;
processpacket( hex2bits("9C0141080250320F1802104A08"))[2] = 1;
*)

# answers
(answer1, answer2, fluff) := processpacket( hex2bits( input ) ):
answer1;
answer2;