# # Comuting BGG operator and characteristic homomorphism
# # by Shizuo Kaji
# # version: 2007/12/10 12:30
# # See the included demo maple worksheet for usage
# # LIMITATION: due to computational complexity,
# #       for type-E this script deal with modulo
# #         maximal parabolic P2 by default

# require coxeter and weyl package by J.Stembridge
# http://www.math.lsa.umich.edu/~jrs/maple.html

# Data files
# E8data.m: load reduced words of E8 up to length 15, into a variable "redu"
# E8data-P2.m: load reduced words of E8/P2, into a variable "redu"
# E8gen.mpl: load definition for ring generators of E8/T

# global variables:
# R: Lie type
# B: simple roots
# redu[deg]: reduced words
# reduw: flattened list of reduced words
# w[i]: i-th weight
# a[i]: i-th root
# s[[]]: weyl group element
# X[weyl]: Schubert class corresponding to weyl
# S[weyl]: Schubert polynomial corresponding to weyl
# gam[deg],x[deg]: special generator
# rho[deg]: relation

with(coxeter); with(weyl);
with(WeylOps):

# convert poly of weights into that of e
w2e := proc (wpol::polynom) global R,B;
    return eval(wpol, [seq(w[j]=weights(R)[j], j=1..nops(B))]);
end proc;

# convert poly of special generators to that of weights "w[1..r]"
gen2w := proc (f::polynom) global R,B;
    return eval(f, [seq(G[i] = gam[i], i = [3,4,5,6,9,10,15]),
		seq(c[i] = c(i), i = 1 .. nops(B)),
		seq(T[i] = t[i], i = 0 .. 8)]);
end proc;

# listup monomials of degree "deg" consisting of "gens", whose degrees are specified by "degs"
list_monom := proc (gens::list, degs::list, deg::integer) local i, L;
 L := {};
 for i to nops(gens) do
   if 0 < deg-degs[i] then
     L := `union`(L, map2(`*`, gens[i], list_monom(gens, degs, deg-degs[i])))
   elif deg-degs[i] = 0 then
     L := `union`(L, {gens[i]});
   end if;
 end do;
 return L;
end proc:

# BGG operator for w-poly wrt any root
BGG_root := proc (vec::linear, f::polynom) global R;
    return -simplify((f - subs([seq(w[i]=e2w(reflect(vec, weights(R)[i])),i=1..rank(R))], f))
	      / e2w(vec));
end proc;

# BGG for w-poly by recursive computation using Leibniz-rule
BGG_w := proc (rt::integer, f::polynom) local i, j, term;
	if degree(f) < 1 then return 0
    elif type(f, monomial) then
		return -sum(ref_weight(rt)^i*w[rt]^(-i-1)*f, i=0..degree(f, w[rt])-1);
    elif op(0, f) = `+` then
		return expand(map2(procname, rt, f));
    elif op(0, f) = `*` then
		if type(op(1,f), 'rational') then
			return op(1,f)*procname(rt, f/op(1,f));
		end if;
		j := 1;
		for i to nops(f) do
		    if degree(op(i, f)) <= degree(op(j, f)) and length(op(i, f)) < length(op(j, f)) then
			j := i
		    end if
		end do;
		term[1] := op(j, f);
		term[2] := mul(op(i, f), i = 1 .. j-1)*mul(op(i, f), i = j+1 .. nops(f));
		return procname(rt, term[1])*term[2]+ref_rt(rt, term[1])*procname(rt, term[2]);
    elif op(0, f) = `^` then
	    term[1] := op(1, f);
	    return procname(rt, term[1])*add(term[1]^(i-1)*ref_rt(rt, term[1])^(op(2,f)-i),i=1..op(2,f));
    else
        print("cannot compute BGG:",f);
        return infinity;
    end if
end proc;

# BGG operator for e-poly
BGG_e := proc (rt::integer, f::polynom) global R;
    return -simplify((f - subs([seq(e(i)=reflect(B[rt], e(i)),i=1..dimr(R))], f))
	      / B[rt]);
end proc;

# a simple reflection on fundamental weight
ref_weight := proc (rt::integer) option remember; global R,B;
	return w[rt]-e2w(B[rt]);
end proc;

# simple reflection on Schubert cycle
ref_weyl := proc(rt::integer,weyl::list) local a,j,v,u,w,temp; global B; option remember;
	temp := X[weyl];
	w := weyl.[rt];
    if nops(w) > nops(weyl) then
		return X[weyl];
	end if;
	for a in pos_roots(B) do
       	 v := reflect(a,interior_pt(B));
     	 v := reflect(seq(B[j],j=w),v);
	  	  vec2fc(v,R,'u');    # u = w.s_a
		  if nops(u)=nops(weyl) then
			   temp := temp - iprod(2/iprod(a,a)*a,B[rt])*X[u];
          end if;
     end do;
     return temp;
end proc:

# simple reflection on polynomial
ref_rt := proc (rt::integer, f::polynom) local ff;
    if type(f, 'rational') then
        return f;
    else
        ff:=subs(w[rt]=ref_weight(rt), f);
        if has(f,'X') then
            if type(ff, 'indexed') and op(0,ff)='X' then return ref_weyl(rt,op(1,ff));
            elif op(0,ff) =`+` or op(0,ff)=`*` then return map2(procname, rt, ff);
            elif op(0,ff) =`^` then return procname(rt,op(1,ff))^op(2,ff);
            end if;
        end if;
        return ff;
    end if;
end proc;

# weyl group action on polynomial
ref := proc(weyl, f::polynom);
    return WeylFunc(weyl,f,ref_rt);
end proc:

# Schubert basis expansion
Char := proc (f::polynom, func::procedure, roots::set, R) local weyl;
    return add( WeylFunc(weyl, f, func)*X[weyl],
	       weyl=PReducedWd(R, roots, degree(f))[degree(f)]);
end proc;

# Schubert basis expansion for poly in special generators
Char_w := proc (f::polynom) local temp, deg; global redu; global R;
	temp:=collect(gen2w(f), {seq(w[i], i=1..rank(R))});
    if not type(temp, polynom) then
        print('not polynomial', f); return -infinity;
    end if;
    deg := degree(temp);
    if deg < 1 then return temp;
	elif deg <> ldegree(temp) then
		print("not homogeneous:", temp); return -infinity;
    elif deg>nops(redu) then return 0;
    end if;
	return add(WeylFunc(weyl, temp, BGG_w)*X[weyl], weyl=redu[deg]);
# for multi thread
#	return Threads:-Add( WeylFunc(weyl, temp)*X[weyl], weyl=redu[deg] );
end proc;

# Schubert basis expansion for poly in "X[weyl]"
Char_X := proc(f::polynom) local weyl,deg; global redu;
    deg := deg_X(f);
    if deg < 1 then return f;
    elif deg>nops(redu) then return 0;
    end if;
  return add(WeylFunc(weyl, f, BGG_X)*X[weyl], weyl=redu[deg]);
end proc:

# Schubert basis expansion for poly in "e"
Char_e := proc(f::polynom) local weyl,deg; global redu;
    deg := degree(f);
    if deg <1 then return f;
	elif deg <> ldegree(f) then
		print("not homogeneous:", f); return -infinity;
    elif deg>nops(redu) then return 0;
    end if;
  return add(WeylFunc(weyl, f, BGG_e)*X[weyl], weyl=redu[degree(f)]);
end proc:

# BGG operator for poly in "X[weyl]"
BGG_X := proc(rt::integer, f::polynom) local w,term;
    if degree(f) < 1 then return 0 end if;
    if type(f, 'indexed') and op(0,f)=`X` then
		w:=op(1,f).[rt];
		if nops(w)=0 then return 1;
			elif nops(w) < nops(op(1,f)) then return(X[w]);
			else return 0;
		end if;
    elif op(0, f) = `+` then
		return expand(map2(procname, rt, f));
    elif op(0, f) = `*` then
		if type(op(1,f), 'rational') then
			return op(1,f)*procname(rt, f/op(1,f));
		end if;
		term[1] := op(1, f);
		term[2] := mul(op(i, f), i = 2 .. nops(f));
		return expand(procname(rt, term[1])*term[2]
			+ref_rt(rt, term[1])*procname(rt, term[2]));
    elif op(0, f) = `^` then
	    term[1] := op(1, f);
	    return expand(procname(rt, term[1])*add(term[1]^(i-1)*ref_rt(rt, term[1])^(op(2,f)-i),i=1..op(2,f)));
    else
	    print("Error in BGG_X:",f)
    end if;
end proc;

# top (point) cohomology class
top := proc (roots::set := {}) local k, j, i, RP, temp, lie_type; global R,P,reduw;
	if not roots={} then
       RP := relative_roots(R,roots);
	   return (-1)^(nops(RP))*mul(i,i=RP)/nops(reduw);
    end if;
    temp := 1;
	lie_type := name_of(R);
    if lie_type = F4 then
        return (-255887*gam[3]^4*gam[4]^3+178123*gam[4]^6)/173408256000;
    elif lie_type = E7 then
		temp := mul(t[i]-t[0], i = 1 .. 7);
		for i to 6 do temp := temp*mul(t[i]-t[j], j = i+1 .. 7) end do;
	    for i to 5 do
		 for j from i+1 to 6 do
			temp := temp*mul(t[i]+t[j]+t[k]-t[0], k = j+1 .. 7);
	     end do;
		end do;
		return temp;
    elif lie_type = E8 then
		temp := mul(t[i], i = 1 .. 8);
		for i to 7 do temp := temp*mul(t[i]-t[j], j = i+1 .. 8) end do;
		for i to 7 do temp := temp*mul(t[i]+t[j]-t[0], j = i+1 .. 8) end do;
		for i to 6 do
			for j from i+1 to 7 do
				temp := temp*mul(t[i]+t[j]+t[k]-t[0], k = j+1 .. 8)
			end do;
		end do;
		return temp;
    elif lie_type = G2 then
		return (-9*w[1]^6+6*w[1]^5*w[2])/12;
    elif lie_type = cat('A',rank(R)) then
	     return mul(e(i)^(rank(R)-i+1), i = 1 .. rank(R));
	elif lie_type = cat('B',rank(R)) then
		 return (-1)^rank(R)*mul(e(i)^(2*i-1), i = 1 .. rank(R))/2^rank(R);
    elif lie_type = cat('C',rank(R)) then
		 return (-1)^rank(R)*mul(e(i)^(2*i-1), i = 1 .. rank(R));
    else
		return (-1)^(nops(P))*mul(i, i = P)/mul(i,i=degrees(R));
    end if
end proc;

# enumerate Schubert polynomials by applying BGG to the top degree class
schubertpolys := proc() global S, R, reduw; local w,func,top_class,top_weyl;
  top_class := top();
  top_weyl  := longest_elt(R);
  S[[]] := 1;
  if evalb(name_of(R) in {'G2','F4','E6','E7','E8'}) then
  	 func:='BGG_w';
  else
	func:='BGG_e';
  end if;
  for w in reduw do
  	   S[w] := WeylFunc(inv(w).top_weyl, top_class, func);
  end do;
  print("The top class is", top_weyl, top_class);
end proc:

# polynomial representatives in given generators for Schubert classes in a given degree
Schubert_Polynomials := proc (gens::list, deg::integer) local i,j,v,temp,M,L,A,V,degs;
 L:=[]; A:=[];
 degs := map(degree, map(gen2w, gens));
 M := convert(list_monom(gens, degs, deg), `list`);
 for i from 1 to nops(M) do
  temp := Char_w(M[i]);
  L:=[op(L), M[i] = temp];
  v := vector(nops(redu[deg])+nops(M), 0);
  v[nops(redu[deg])+i] := 1;
  for j to nops(redu[deg]) do
     v[j] := coeff(temp, X[redu[deg][j]]);
  end do;
  A := [op(A), convert(v, list)];
 end do;
 A := LinearAlgebra[HermiteForm](Matrix(A));
# for printing
 V := [];
 for v in convert(A, `listlist`) do
	V := [op(V),
	    add(v[i]*X[redu[deg][i]], i=1..nops(redu[deg]))
        = add(v[nops(redu[deg])+i]*M[i], i=1..nops(M))];
  end do;
  return V;
end proc:

## initialization for Lie types (using Toda-Watanabe basis for exceptional types)
setup := proc (lie_type, roots::set := {}, upto::integer := 0) local i,S;
		global R, P, B, x, u, z, t, udim, gam, rho, redu, reduw;
  forget(ref_weight);
  forget(ref_weyl);
  unassign('gam','t','x','S','rho');

# type G2
  if lie_type = G2 then
    R := lie_type;
    t[1] := -w[1];
    t[2] := -w[1]+w[2];
    t[3] := 2*w[1]-w[2];
    rho[2] := w[2]^2+3*w[1]^2-3*w[1]*w[2];
    gam[3] := (1/2)*t[1]*t[2]*t[3];
	x[3] := 1/2*(w[1]*w[2]^2-w[1]^2*w[2]); # [2,1,2]
# type F4
  elif lie_type = F4 then
    R := linalg[transpose](cartan_matrix(lie_type));
    t[1] := -w[4];
    t[2] := w[1]-w[4];
    t[3] := -w[1]+w[2]-w[4];
    t[4] := -w[2]+2*w[3]-w[4];
    t[0] := w[3]-2*w[4];
    gam[3] := (1/2)*c(3);
    gam[4] := (1/3)*c(4)-(2/3)*t[0]*c(3)+(8/3)*t[0]^4;
	rho[2] := c(2)-2*t[0]^2;
	rho[6] := gam[3]^2-3*t[0]^2*gam[4]-4*t[0]^3*gam[3]+8*t[0]^6;
	rho[8] := 3*gam[4]^2+6*t[0]*gam[3]*gam[4]-3*t[0]^4*gam[4]-13*t[0]^8;
# type E6 / P2
  elif lie_type = E6 then
    R := linalg[transpose](cartan_matrix(lie_type));
    t[1] := -w[1]+w[2];
    t[2] := w[1]+w[2]-w[3];
    t[3] := w[2]+w[3]-w[4];
    t[4] := w[4]-w[5];
    t[5] := w[5]-w[6];
    t[6] := w[6]; t[0] := w[2];
    gam[3] := c(3);
    gam[4] := c(4)+2*t[0]^4;
# type E7 / P2
  elif lie_type = E7 then
    R := linalg[transpose](cartan_matrix(lie_type));
    t[1] := -w[1]+w[2];
    t[2] := w[1]+w[2]-w[3];
    t[3] := w[2]+w[3]-w[4];
    t[4] := w[4]-w[5];
    t[5] := w[5]-w[6];
    t[6] := w[6]-w[7];
    t[7] := w[7];
    t[0] := w[2];
    gam[3] := 1/2*c(3);
    gam[4] := 1/3*(c(4)+2*t[0]^4);
    gam[5] := 1/2*(c(5)-t[0]*c(4)+t[0]^2*c(3)-2*t[0]^5);
    gam[9] := 1/2*(c(6)*c(3)+t[0]^2*c(7)-3*t[0]^3*c(6));
# type E8 / P2
  elif lie_type = E8 then
    R := linalg[transpose](cartan_matrix(lie_type));
	read "E8data-p2.m";
	read "E8gen.mpl";
  else
    R := lie_type;
  end if;

  B := base(R);
  P := pos_roots(lie_type);
  udim := `if`(upto>0,upto,nops(P));
  if not lie_type = E8 then
      redu := PReducedWd(R, roots, udim);
  end if;
  reduw := [[],seq(op(i),i=redu)];
  print(lie_type, "mod the parabolic w.r.t", roots);
  return diagram(R);
end proc;


# Let E be the surjection operad, as explained by Berger and Fresse
# following McClure.  We represent a basis element of E(A) by
# expressions S(...), where the arguments are elements of A,
# each element appears at least once, and no two adjacent elements
# are the same.

`is_element/surjections` := (A::set) -> proc(x)
 global reason;
 local i,y,z;

 if x = 0 then return true; fi;

 if type(x,`+`) then
  return `and`(op(map(`is_element/surjections`(A),[op(x)])));
 fi;

 if type(x,`*`) then
  y,z := selectremove(type,[op(x)],integer);
  return (nops(z) = 1 and `is_element/surjections`(A)(z[1]));
 fi;

 if not type(x,specfunc(S)) then return false; fi;
 if {op(x)} <> A then return false; fi;

 for i from 1 to nops(x) - 1 do
  if x[i] = x[i+1] then return false; fi;
 od;

 return true;
end:

`is_equal/surjections` := (A::set) -> (x0,x1) -> evalb(expand(x0 - x1) = 0);

`is_equal_unsigned/surjections` := (A::set) -> (x0,x1) -> evalb(modp(expand(x0 - x1),2) = 0);

`random_basis_element/surjections` := (A) -> proc(m_)
 local n,m,i,x,ok;

 n := nops(A);

 if n = 0 then return FAIL; fi;

 if n = 1 then
  if nargs = 0 or m_ = 1 then
   return S(op(A));
  else
   return FAIL;
  fi;
 fi;

 if nargs > 0 then
  m := m_;
 else
  m := rand(0..5)();
 end:

 ok := false;
 while not(ok) do
  x := [op(A),seq(random_element_of(A),i=1..m)];
  x := combinat[randperm](x);
  ok := true;
  for i from 1 to n + m - 1 do
   if x[i] = x[i+1] then
    ok := false;
    break;
   fi;
  od;
 od;
 x := S(op(x));
 return x;
end:

`random_element/surjections` := (A) -> proc(coeff_range_,num_terms_)
 local coeff_range,num_terms;

 coeff_range := -3..3;
 num_terms := 5;
 if nargs > 0 then coeff_range := args[1]; fi;
 if nargs > 1 then num_terms := args[2]; fi;

 add(rand(coeff_range)() * `random_basis_element/surjections`(A)(),i=1..num_terms);
end:

# Let u be a basis element of E(A), of length n say.  A gap means
# a pair (i,i+1) with 1 <= i < i+1 <= n.  The gap is bound if
# u[i] = u[j] for some j > i.  Here we represent a bound gap
# (i,i+1) by its initial index i.  The following function
# returns the ordered list of bound gaps.

`bound_gaps/surjections` := (A) -> proc(u)
 local G,N,M,a;
 G := NULL;
 N := [seq(i,i=1..nops(u))];
 for a in A do
  M := select(i -> op(i,u) = a,N);
  G := G,op(1..-2,M);
 od:
 G := sort([G]);
 return(G);
end:

# Auxiliary function feeding into `diff/surjections`

`diff0/surjections` := (A::set) -> proc(x)
 local i,j,m,y,z,s,ss,t,l,r;

 i := [op(x)];
 m := nops(i);

 y := 0;
 s := 1;
 ss := table();

 for j from 1 to m do
  l := [op(1..j-1,i)];
  r := [op(j+1..m,i)];
  if member(i[j],r) then
   t := s;
   ss[i[j]] := t;
   s := -s;
  elif member(i[j],l) then
   t := -ss[i[j]];
   ss[i[j]] := t;
  else
   t := 0;
  fi;
  if 1 < j and j < m and op(j-1,i) = op(j + 1,i) then
   t := 0;
  fi;
  y := y + t * S(op(1..j-1,i),op(j+1..m,i));
 od:
end:

# Differential on the surjection chain complex

`diff/surjections` := (A::set) -> apply_linear(`diff0/surjections`(A));

# Auxilary function feeding into `deg/surjections`
`deg0/surjections` := (A) -> (u) -> nops(u) - nops(A);

# Degree function for the surjection chain complex.
`deg/surjections` := (A) -> apply_deg(`deg0/surjections`(A));

`reflect/surjections` := (A) -> proc(u)
 local c,v;

 if type(u,`+`) then
  return map(`reflect/surjections`(A),u);
 fi;

 c,v := op(coeff_split(u));

 if not(type(v,specfunc(S))) then return FAIL; fi;

 return (-1)^(nops(v) - nops(A)) * u;
end:

# This is the circle product for the operad structure.
# It is assumed that B is a subset of A and u is in E(A/B) and v is in E(B),
# where A/B is implemented as A \ B u {B}.

`o0/surjections` := (A,B) -> proc(u,v)
 local AB,nu,nv,Nu,Nv,M,l,m,JJ,w,J,k,p,i,j,s;

 AB := A minus B union {B};

 nu := nops(u);
 nv := nops(v);
 Nu := [seq(i,i=1..nu)];
 Nv := [seq(i,i=1..nv)];
 M := select(i -> op(i,u) = B,Nu);
 m := nops(M);
 JJ := combinat[choose]([seq(i,i=2..nv+m-1)],m-1);
 JJ := map(J -> [1,seq(J[i]-i,i=1..m-1),nv],JJ);

 w := 0;
 for J in JJ do
  k := NULL;
  l := NULL;
  p := 1;
  for i from 1 to nu do
   if op(i,u) = B then
    k := k,seq(op(j,v),j=J[p]..J[p+1]);
    l := l,seq([i,j],j=J[p]..J[p+1]);
    p := p+1;
   else
    k := k,op(i,u);
    l := l,[i,0];
   fi;
  od;
  l := [l];
  s := NULL;
  for i in `bound_gaps/surjections`(AB)(u) do
   j := nops(l);
   while j > 1 and l[j][1] <> i do j := j - 1; od;
   s := s,j;
  od;
  for i in `bound_gaps/surjections`(B)(v) do
   j := nops(l);
   while j > 1 and l[j][2] <> i do j := j - 1; od;
   s := s,j;
  od;
  w := w + sgn([s]) * S(k);
 od:

 return w;
end:

`o/surjections` := (A,B) -> apply_bilinear(`o0/surjections`(A,B));

`gamma0/surjections` := (A::set,B::set) -> (p) -> proc(y,x)
 local F,J,I0,J0,b,L,m,n,S0,s;

 F := fibres(A,B)(p);
 J := [seq(i,i=0..nops(y)-1)];
 I0 := table():
 J0 := table():
 for b in B do
  I0[b] := [seq(i,i=0..nops(x[b])-1)];
  J0[b] := select(j -> op(j+1,y) = b,J);
 od:
 L := [[]];

 for b in B do
  m := nops(J0[b]) - 1;
  n := nops(I0[b]) - 1;
  S0 := map(`to_grid_path/shuffles`(m,n),`list_elements/shuffles`(m,n));
  S0 := map(s -> [seq(s[i],i=0..n+m)],S0);
  S0 := map(s -> map(ji -> [J0[b][ji[1]+1],ji[2]],s),S0);
  L := [seq(seq([op(l),op(s)],s in S0),l in L)];
 od:
 L := map(sort,L);
 L := map(l -> S(op(map(ji -> op(ji[2]+1,x[op(ji[1]+1,y)]),l))),L);
 return `+`(op(L));
end:

`gamma/surjections` := eval(extend_gamma_linear(`gamma0/surjections`)):

# We now have various functions related to an interesting filtration
# of the surjections operad.

`flip_count/surjections` := (A::set) -> proc(u,s_)
 local r,m,a,b,c,u0,i;
 if nargs > 1 then
  r := `rank_table/ord`(A)(s_);
 else
  r := NULL;
 fi;

 m := table():
 for a in A do
  for b in A do
   m[a,b] := 0;
   u0 := select(p -> p = a or p = b,[op(u)]);
   for i from 1 to nops(u0) - 1 do
    if u0[i+1] <> u0[i] then m[a,b] := m[a,b] + 1; fi;
   od;

   if m[a,b] > 0 and r <> NULL then
    c := `if`(r[a] < r[b],a,b);
    if u0[-1] = c then m[a,b] := m[a,b] + 1; fi;
   fi;
  od;
 od;

 return eval(m);
end:

`flip_count_matrix/surjections` := (A::set) -> proc(u,s_)
 local m;
 m := `flip_count/surjections`(A)(args);
 return Matrix([seq([seq(m[a,b],b in A)],a in A)]);
end:

`max_flip_count/surjections` := (A::set) -> proc(u)
 local m,mm,a,b;

 m := `flip_count/surjections`(A)(u);

 mm := 0;
 for a in A do
  for b in A do
   mm := max(mm,m[a,b]);
  od;
 od;

 return mm;
end:

`is_cell_member/surjections` := (A::set) -> (ms) -> proc(u)
 local m0,m1,s,r,i,j,a,b,c,u0,k,l,y,z;

 if x = 0 then return true; fi;
 if type(x,`+`) then
  return `and`(seq(`is_cell_member/surjections`(A)(ms)(y),y in x));
 fi;
 if type(x,`*`) then
  y,z := selectremove(type,[op(x)],integer);
  if nops(z) = 1 then
   return `is_cell_member/surjections`(A)(ms)(z[1]);
  else
   return false;
  fi;
 fi;

 m0,s := op(ms);
 m1 := `flip_count/surjections`(A)(u,s);

 for a in A do
  for b in A do
   if m1[a,b] > m0[a,b] then return false; fi;
  od;
 od;

 return true;
end:

`filtration0/surjections` := (A::set) -> proc(u)
 local m,m_max,s,rr,k,i,r0,r1,a,b;

 if type(u,integer) then return 0; fi;

 return 1 + `max_flip_count/surjections`(A)(u);
end:

`filtration/surjections` := (A::set) ->
 apply_max_deg(`filtration0/surjections`(A));

`rho0/barratt_eccles/surjections` := (A::set) -> proc(x)
 local rr,d,R,r,y,z,z0,ok,i,m;

 rr := nops(A);
 d := nops(x) - 1;
 R := combinat[choose]([seq(i,i=1..d+rr-1)],d);
 R := map(r -> [0,op(r),d+rr],R);
 R := map(r -> [seq(r[i+1]-r[i],i=1..d+1)],R);
 y := 0;
 for r in R do
  z := NULL;
  z0 := NULL;
  ok := true;
  for i from 1 to d+1 do
   m := select(j -> not(member(j,[z0])),op(i,x));
   if nops(m) >= r[i] and ([z] = [] or [z][-1] <> m[1]) then
    z := z,op(1..r[i],m);
    z0 := z0,op(1..r[i]-1,m);
   else
    ok := false;
    break;
   fi;
  od;
  if ok then y := y + S(z); fi;
 od;
 return y;
end:

`rho/barratt_eccles/surjections` := (A::set) ->
 apply_linear(`rho0/barratt_eccles/surjections`(A));

# We now define a map from the surjections operad to the
# Barratt-Eccles operad.  This is not an operad morphism,
# but it is a section of the map in the opposite direction.

`sigma0/surjections/barratt_eccles` := (A::set) -> proc(x)
 local i,j,k,l,r,t,p,m,d,w,ww;

 i := [op(x)];
 m := nops(i);
 d := m - nops(A);

 ww := NULL;

 for k from 0 to d do
  w := NULL;

  p := 0;

  for j from 1 to m do
   l := [op(1..j-1,i)];
   r := [op(j+1..m,i)];
   if member(i[j],r) then
    t := false;
    p := p + 1;
   else
    t := true;
   fi;

   if not(member(i[j],[w])) then
    if t or (p > k) then
     w := w,i[j];
    fi;
   fi;
  od:
  w := [w];
  ww := ww,w;
 od;

 return T(ww);
end:

`sigma/surjections/barratt_eccles` := (A::set) ->
 apply_linear(`sigma0/surjections/barratt_eccles`(A));

# The cut operation construction gives a morphism from the surjection
# operad to the Eilenberg-Zilber operad.  Unfortunately the EZ operad
# cannot be represented properly in our framework because each set
# EZ(A) is an infinite product over the natural numbers.  To deal with
# this we insert natural number indices in various places.

`cut_operation0/surjections` := (n::nonnegint) -> (A::set) -> proc(x)
 local A0,m,d,N,J,p,q,r,j,c,t,a,is_degen;

 A0 := sort([op(A)]);
 m := nops(A);
 d := nops(x) - m;
 N := [seq(i,i=0..n)];
 J := [[0]];
 for p from 1 to m + d - 1 do
  J := [seq(seq([op(j),q],q=j[-1]..n),j in J)];
 od:
 J := map(j -> [op(j),n],J);

 c := 0;

 for j in J do
  t := table():
  for a in A0 do t[a] := []: od:
  for p from 1 to m+d do
   a := op(p,x);
   t[a] := [op(t[a]),seq(r,r=j[p]..j[p+1])];
  od:

  is_degen := false;

  for a in A0 do
   if nops(t[a]) > nops({op(t[a])}) then
    is_degen := true;
    break;
   fi;
  od:

  if not(is_degen) then
   c := c + `detranspose/eilenberg_zilber`(A)(t);
  fi;
 od:

 return c;
end:

`cut_operation1/surjections` := (n::nonnegint) -> (A::set) -> proc(x)
 add(`cut_operation0/surjections`(k)(A)(x),k=0..n);
end:

`cut_operation/surjections` := (n::nonnegint) -> (A::set) ->
 apply_linear(`cut_operation1/surjections`(n)(A));

`multiplicity_table/surjections` := (A::set) -> proc(x)
 local t,a;

 t := table():
 for a in A do t[a] := 0; od:
 for a in [op(x)] do
  t[a] := t[a] + 1;
 od:
 return eval(t);
end:
`max_multiplicity/surjections` := (A::set) -> proc(x)
 local t,m,a;
 t := `multiplicity_table/surjections`(A)(x);
 m := 0;
 for a in A do m := max(m,t[a]); od;
 return m;
end:
`is_biased/surjections` := (A::set) -> proc(x,a0_)
 local a,a0,t;

 a0 := NULL;
 if nargs > 1 then a0 := a0_; fi;

 t := `multiplicity_table/surjections`(A)(x);

 for a in A do
  if t[a] > 1 then
   if a0 = NULL then
    a0 := a;
   else
    if a0 <> a then
     return false;
    fi;
   fi;
  fi;
 od:

 return true;
end:
`is_strongly_biased/surjections` := (A::set) -> proc(x,a0_)
 local a,a0,t;

 a0 := NULL;
 if nargs > 1 then a0 := a0_; fi;

 t := `multiplicity_table/surjections`(A)(x);

 for a in A do
  if t[a] > 1 then
   if a0 = NULL then
    a0 := a;
   else
    if a0 <> a then
     return false;
    fi;
   fi;
  fi;
 od:

 if a0 = NULL or t[a0] <= 1 then return false; fi;

 return true;
end:


sort([3,2,4,5],output = permutation);


# Step 1 of 3: from Hakaru to Maple LO (linear operator)

toLO := module()
  export
  ModuleApply := proc(m, $)
    local h;
    h := gensym('h');
    _Env_HakaruSolve := false;
    LO(h, integrate(m, h, []))
  end proc;

  export
  integrate := proc(m, h, loops :: list(name = range) := [], $)
    local x, n, i, res, l, br, m0;

    if m :: known_continuous then
      integrate_known(Int, Ints, 'xx', m, h, loops)
    elif m :: known_discrete then
      integrate_known(Sum, Sums, 'kk', m, h, loops)
    elif m :: 'Ret(anything)' then
      applyintegrand(h, mk_ary(op(1,m), loops))
    elif m :: 'Bind(anything, name, anything)' then
      res := eval(op(3,m), op(2,m) = mk_idx(op(2,m), loops));
      res := eval(Integrand(op(2,m), 'integrate'(res, x, loops)), x=h);
      integrate(op(1,m), res, loops);
    elif m :: 'specfunc(Msum)' and (nops(loops) = 0 or nops(m) = 1) then
      `+`(op(map(integrate, [op(m)], h, loops)))
    elif m :: 'Weight(anything, anything)' then
      foldl(product, op(1,m), op(loops)) * integrate(op(2,m), h, loops)
    elif m :: t_pw_or_part then
      Partition:-AppPartOrPw
                 ( proc(p)
                       if not Partition:-ConditionsDepend(p, lhs~(loops)) then
                           Partition:-Pmap(z->integrate(z,h,loops),p)
                       end if;
                   end proc
                 , m);
    elif m :: t_case and not depends(op(1,m), map(lhs, loops)) then
      subsop(2=map(proc(b :: Branch(anything, anything))
                     eval(subsop(2='integrate'(op(2,b), x, loops),b), x=h)
                   end proc,
                   op(2,m)),
             m);
    elif m :: 'LO(name, anything)' then
      eval(op(2,m), op(1,m) = h)
    elif m :: 'Plate(nonnegint, name, anything)' then
      # Unroll Plate when the bound is known. We unroll Plate here (instead
      # of unrolling Ints in reduce, for example) because we have no other
      # way to integrate certain Plates, namely those whose bodies' control
      # flows depend on the index.
      x := mk_sym('pp', h);
      x := [seq(cat(x,i), i=0..op(1,m)-1)];
      if op(1,m) = 0 then
        res := undefined;
      else
        if op(1,m) = 1 then
          res := op(1,x);
        else
           res := idx(x,op(2,m));
#          res := piecewise(seq(op([op(2,m)=i-1, op(i,x)]), i=2..op(1,m)),
#                         op(1,x));
        end if;
        res := mk_idx(res, loops);
      end if;
      res := applyintegrand(h, mk_ary('ary'(op(1,m), op(2,m), res), loops));
      for i from op(1,m) to 1 by -1 do
        res := integrate(eval(op(3,m), op(2,m)=i-1),
                         Integrand(op(i,x), res), loops);
      end do;
      res
    elif m :: 'Plate(anything, name, anything)' then
      integrate(op(3,m), h, [op(2,m)=0..op(1,m)-1, op(loops)])
    elif m :: 'Context(anything, anything)' then
      applyop(integrate, 2, m, h, loops)
    elif h :: appliable then
      x := gensym('xa');
      'integrate'(m, Integrand(x, h(x)), loops)
    else
      'procname(_passed)'
    end if
  end proc;

  local
  integrate_known := proc(make, makes, var, m, h, loops :: list(name=range), $)
    local x, dens, bds;
    x := mk_sym(var, h);
    dens := density[op(0,m)](op(m));
    bds := bounds[op(0,m)](op(m));
    if loops = [] then
      make(dens(x) * applyintegrand(h, x), x = bds);
    else
      makes(foldl(product, dens(mk_idx(x,loops)), op(loops))
              * applyintegrand(h, x),
            x, bds, loops)
    end if;
  end proc;
end module; #toLO


kernelopts(printbytes=false);
with(RigidMotionsRecoverNMM);
LaunchFindDistinctSamplePoints([a,b,c], "N2", [-2, -1, 0, 1, 2], "__REPLACE__");
done


# Maple Code Generator

##
## Copyright (C) 2015-2017 Maplesoft
## Authors:    Behzad Samadi <bsamadi@maplesoft.com>
## Created:    September 2017
## Version:    0.2
## Keywords:   Maple, Code Generation, Model Predictive Control (MPC)
##
## Procedures:
##             CGMRES
##

MapleCodeGenerator := module()
description "Maple code generation for numerical optimization";
option package;

export DotProduct,
       GMRES,
       GradientDescent,
       LMGMRES,
       Minimize1D,
       NewName,
       NewtonsMethod,
       NewtonsMethodGMRES,
       nfGMRES,
       Norm2;

$include "DotProduct.mm"
$include "GMRES.mm"
$include "GradientDescent.mm"
$include "LMGMRES.mm"
$include "Minimize1D.mm"
$include "NewName.mm"
$include "NewtonsMethod.mm"
$include "NewtonsMethodGMRES.mm"
$include "nfGMRES.mm"
$include "Norm2.mm"

end module; # MCG


 # a function returning unary(i + j) * -998
 func $foo (
  var %i i32,
   var %j i32) f32 {
   return (
     recip f32(
       sqrt f32(
      cvt f32 i32(
        mul i32 (
         extractbits i32 1 23 ( add i32 ( bnot i32 (dread i32 %i), lnot i32 (dread i32 %j))),
         neg i32 ( constval i32 -998))))))}

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