with(LinearAlgebra): with(ArrayTools): with(QuantumChemistry):
loaddata := readdata(cat(cdir,"_temp.rdm"), 8):
Flatten := proc(x) local n, a, i, j, k, l; `local`(a, n, i, j, k, l); `description`("convert chemists to numpy and flatten an array to form a matrix"); n := Size(x); a := Matrix(1 .. n[1]*n[2], 1 .. n[3]*n[4], datatype = float[8]); for i to round(n[1]) do for j to round(n[2]) do for k to round(n[3]) do for l to round(n[4]) do a[(i - 1)*n[1] + j, (k - 1)*n[3] + l] := x[i, j, k, l]; end do; end do; end do; end do; return a; end proc:
New := Array(1 .. 4, 1 .. 4, 1 .. 4, 1 .. 4, datatype = float[8]):
for i in loaddata[3 .. ()] do
    New[round(i[1]), round(i[2]), round(i[3]), round(i[4])] := i[5]:
end do:
pure := Purify2RDM(New, spin_free = false, electron_number = 4, conv_tol = 0.10000000):
ExportMatrix(cat(cdir, "_temp_purified.csv"), Flatten(pure[rdm2])):


# Step 2 of 3: computer algebra

improve := proc(lo :: LO(name, anything), {_ctx :: t_kb := empty}, opts := [], $)
local r, `&context`;
  userinfo(5, improve, "input: ", print(lo &context _ctx));
  _Env_HakaruSolve := true;
  r:= LO(op(1,lo), reduce(op(2,lo), op(1,lo), _ctx, opts));
  userinfo(5, improve, "output: ", print(r));
  r
end proc;

# Walk through integrals and simplify, recursing through grammar
# h - name of the linear operator above us
# kb - domain information
reduce := proc(ee, h :: name, kb :: t_kb, opts := [], $)
  local e, elim, subintegral, w, ww, x, c, kb1, with_kb1, dom_specw, dom_specb
       , body, dom_spec, ed, mkDom, vars, rr
       , do_domain := evalb( not ( "no_domain" in {op(opts)} ) ) ;
  e := ee;

  if do_domain then
    rr := reduce_Integrals(e, h, kb, opts);
    if rr <> FAIL then return rr end if;
  end if;
  if e :: 'applyintegrand(anything, anything)' then
    map(simplify_assuming, e, kb)
  elif e :: `+` then
    map(reduce, e, h, kb, opts)
  elif e :: `*` then
    (subintegral, w) := selectremove(depends, e, h);
    if subintegral :: `*` then error "Nonlinear integral %1", e end if;
    subintegral := convert(reduce(subintegral, h, kb, opts), 'list', `*`);
    (subintegral, ww) := selectremove(depends, subintegral, h);
    simplify_factor_assuming(`*`(w, op(ww)), kb)
      * `*`(op(subintegral));
  elif e :: Or(Partition,t_pw) then
    if e :: t_pw then e := PWToPartition(e); end if;
    e := Partition:-Simpl(e);
    e := kb_Partition(e, kb, simplify_assuming,
                      ((rhs, kb) -> %reduce(rhs, h, kb, opts)));
    e := eval(e, %reduce=reduce);
    # big hammer: simplify knows about bound variables, amongst many
    # other things
    Testzero := x -> evalb(simplify(x) = 0);
    e := Partition:-Simpl(e);
    if ee::t_pw and e :: Partition then
      e := Partition:-PartitionToPW(e);
    end if;
    e;
  elif e :: t_case then
    subsop(2=map(proc(b :: Branch(anything, anything))
                   eval(subsop(2='reduce'(op(2,b),x,c,opts),b),
                        {x=h, c=kb})
                 end proc,
                 op(2,e)),
           e);
  elif e :: 'Context(anything, anything)' then
    kb1 := assert(op(1,e), kb);
    # A contradictory `Context' implies anything, so produce 'anything'
    # In particular, 42 :: t_Hakaru = false, so a term under a false
    # assumption should never be inspected in any way.
    if kb1 :: t_not_a_kb then
        return 42
    end if;
    applyop(reduce, 2, e, h, kb1, opts);
  elif e :: 'toLO:-integrate(anything, Integrand(name, anything), list)' then
    x := gensym(op([2,1],e));
    # If we had HType information for op(1,e),
    # then we could use it to tell kb about x.
    subsop(2=Integrand(x, reduce(subs(op([2,1],e)=x, op([2,2],e)), h, kb, opts)), e)
  else
    simplify_assuming(e, kb)
  end if;
end proc;

# "Integrals" refers to any types of "integrals" understood by domain (Int,
# Sum currently)
reduce_Integrals := module()
  export ModuleApply;
  local
  # The callbacks passed by reduce_Integrals to Domain:-Reduce
    reduce_Integrals_body, reduce_Integrals_into
  # tries to evaluate a RootOf
  , try_eval_Root
  # tries to evaluate Int/Sum/Ints/Sums
  , elim_intsum;

  reduce_Integrals_body := proc(h,opts,x,kb1) reduce(x,h,kb1,opts) end proc;
  reduce_Integrals_into := proc(h,opts,kind,e,vn,vt,kb,$)
    local rr;
    rr := elim_intsum(Domain:-Apply:-do_mk(args[3..-1]), h, kb,opts);
    rr := subsindets(rr, specfunc(RootOf), x->try_eval_Root(x,a->a));
    return rr;
  end proc;

  ModuleApply := proc(expr, h, kb, opts, $)
    local rr;
    rr := Domain:-Reduce(expr, kb
      ,curry(reduce_Integrals_into,h,opts)
      ,curry(reduce_Integrals_body,h,opts)
      ,(_->:-DOM_FAIL));
    rr := kb_assuming_mb(Partition:-Simpl)(rr, kb, x->x);
    if has(rr, :-DOM_FAIL) then
      return FAIL;
    elif has(rr, FAIL) then
      error "Something strange happened in reduce_Integral(%a, %a, %a, %a)\n%a"
           , expr, kb, kb, opts, rr;
    end if;
    rr;
  end proc;

  try_eval_Root := proc(e0::specfunc(`RootOf`),on_fail := (_->FAIL), $)
    local ix,e := e0;
    try
      if nops(e)=2 or nops(e)=3
      and op(-1,e) :: `=`(identical(index),{specindex(real),nonnegint}) then
        ix := op([2,-1],e);
        if ix :: specindex(real) then ix := op(ix); end if;
        e := op(0,e)(op(1,e));
      else
        ix := NULL;
      end if;
      e := convert(e, 'radical', ix);
      if e :: specfunc(RootOf) then return on_fail(e) end if;
      return e;
    catch: return on_fail(e0); end try;
  end proc;

  # Try to find an eliminate (by evaluation, or simplification) integrals which
  # are free of `applyintegrand`s.
  elim_intsum := module ()
    export ModuleApply := proc(inert0, h :: name, kb :: t_kb, opts, $)
       local ex, e, inert := inert0;
       ex := extract_elim(inert, h, kb);
       e[0] := apply_elim(h, kb, ex);
       e[1] := check_elim(inert, e[0]);
       if e[1] = FAIL then inert
       else
         e[2] := reduce(e[1],h,kb,opts);
         if has(e[2], {csgn}) then
           WARNING("Throwing away an eliminated result result containing csgn (this "
                   "could be a bug!):\n%1\n(while running %2)", e[2], ex);
           inert;
         else e[2] end if;
       end if
    end proc;

    local known_tys := table([Int=int_assuming,Sum=sum_assuming,Ints=ints,Sums=sums]);
    local extract_elim := proc(e, h::name, kb::t_kb,$)
      local t, intapps, var, f, e_k, e_args, vs, blo, bhi;
      vs := {op(KB:-kb_to_variables(kb))};
      t := 'applyintegrand'('identical'(h), 'anything');
      intapps := indets(op(1,e), t);
      if intapps = {} then
        return FAIL;
      end if;
      e_k := op(0,e); e_args := op([2..-1],e);
      if Domain:-Has:-Bound(e) and assigned(known_tys[e_k]) then
        var := Domain:-ExtBound[e_k]:-ExtractVar(e_args);
        ASSERT(var::DomBoundVar);
        blo, bhi := Domain:-ExtBound[e_k]:-SplitRange
                    (Domain:-ExtBound[e_k]:-ExtractRange(e_args));
        if ormap(b->op(1,b) in map((q-> (q,-q)), vs) and op(2,b)::SymbolicInfinity
                ,[[blo,bhi],[bhi,blo]]) then
          return FAIL end if;
        if var :: list then var := op(1,var) end if;
        if not depends(intapps, var) then
          f := known_tys[e_k];
        else
          return FAIL;
        end if;
      end if;
      [ op(1,e), f, var, [e_args] ];
    end proc;

    local apply_elim := proc(h::name,kb::t_kb,todo::{list,identical(FAIL)})
      local body, f, var, rrest;
      if todo = FAIL then return FAIL; end if;
      body, f, var, rrest := op(todo);
      banish(body, h, kb, infinity, var,
             proc (kb1,g,$) do_elim_intsum(kb1, f, g, op(rrest)) end proc);
    end proc;

    local check_elim := proc(e, elim,$)
      if has(elim, {MeijerG, undefined, FAIL}) or e = elim or elim :: SymbolicInfinity then
        return FAIL;
      end if;
      return elim;
    end proc;

    local do_elim_intsum := proc(kb, f, ee, v::{name,name=anything})
      local w, e, x, g, t, r;
      w, e := op(Domain:-Extract:-Shape(ee));
      w := Domain:-Shape:-toConstraints(w);
      e := piecewise_And(w, e, 0);
      e := f(e,v,_rest,kb);
      x := `if`(v::name, v, lhs(v));
      g := '{sum, sum_assuming, sums}';
      if f in g then
        t := {'identical'(x),
              'identical'(x) = 'Not(range(Not({SymbolicInfinity, undefined})))'};
      else
        g := '{int, int_assuming, ints}';
        t := {'identical'(x),
              'identical'(x) = 'anything'};
        if not f in g then g := {f} end if;
      end if;
      for r in indets(e, 'specfunc'(g)) do
        if 1<nops(r) and op(2,r)::t then return FAIL end if
      end do;
      e
    end proc;
  end module; # elim
end module; # reduce_Integrals

int_assuming := proc(e, v::name=anything, kb::t_kb, $)
  simplify_factor_assuming('int'(e, v), kb);
end proc;

sum_assuming := proc(e, v::name=anything, kb::t_kb)
  simplify_factor_assuming('sum'(e, v), kb);
end proc;

# Int( .., var=var_ty ) == var &X var_ty
isBound_IntSum := kind -> module()
  option record;
  export MakeKB := (`if`(kind=Sum,KB:-genSummation,KB:-genLebesgue));
  export ExtractVar := (e->op(1,e));
  export ExtractRange := (e->op(2,e));
  export MakeRange := `..`;
  export SplitRange := (e->op(e));
  export Constrain := `if`(kind=Sum,`<=`,`<`);
  export DoMk := ((e,v,t)->kind(e,v=t));
  export Min := `min`; export Max := `max`;
  export VarType := 'name';
  export RangeType := 'range';
  export MapleType := 'And'('specfunc'(kind), 'anyfunc(anything,name=range)');
  export BoundType := `if`(kind=Sum,'integer','real');
  export RecogBound := `if`(kind=Sum,
            (proc(k,b)
               if   k = `<=` then (x->subsop(2=b,x))
               elif k = `>=` then (x->subsop(1=b,x))
               elif k = `<`  then (x->subsop(2=(b-1),x))
               elif k = `>`  then (x->subsop(1=b+1,x))
               end if;
             end proc),
            (proc(k,b)
               if   k in {`<=`,`<`} then (x->subsop(2=b,x))
               elif k in {`>=`,`>`} then (x->subsop(1=b,x))
               end if;
             end proc));
end module;

# Ints( .., var::name, var_ty::range, dims::list(name=range) ) ==
#        [ var   , map(lhs,dims) ] :: list(name)  &X
#        [ var_ty, map(rhs,dims) ] :: list(range)
isBound_IntsSums := kind -> module()
  option record;
  export MakeKB := proc(vars, lo, hi, kb, $)
    local var, dims, ty, rngs, x, kb1;
    var  := op(1, vars);
    rngs := zip(`..`,lo,hi);
    ty   := op(1, rngs);
    dims := subsop(1=NULL,zip(`=`,vars,rngs));
   x, kb1 := genType(var,
                      mk_HArray(`if`(kind=Ints,
                                     HReal(open_bounds(ty)),
                                     HInt(closed_bounds(ty))),
                                dims),kb);
    if nops(dims) > 0 then
      kb1 := assert(size(x)=op([-1,2,2],dims)-op([-1,2,1],dims)+1, kb1);
    end if;
    x, kb1;
  end proc;
  export ExtractVar   := ((v,t,d)->[v,map(lhs,d)[]]);
  export ExtractRange := ((v,t,d)->[t,map(rhs,d)[]]);
  export MakeRange    := ((a,b)->zip(`..`,a,b));
  export SplitRange   := (rs->(map(x->op(1,x),rs), map(x->op(2,x),rs)));
  export Constrain    := ((a,b)->zip(`if`(kind=Ints, `<`, `<=`),a,b)[]);
  export DoMk         := ((e,v,t)->kind( e,op(1,v),op(1,t), subsop(1=NULL,zip(`=`,v,t)) ));
  export Min          := ((a,b)->zip(`min`,a,b));
  export Max          := ((a,b)->zip(`max`,a,b));
  export VarType      := 'And(list(name),satisfies(x->x<>[]))';
  export RangeType    := 'And(list(range),satisfies(x->x<>[]))';
  export MapleType    := 'And'('specfunc'(kind),'anyfunc'('anything', 'name', 'range', 'list(name=range)'));
  export BoundType    := TopProp;
  export RecogBound   := (_->NULL);
end module;


(*
    以代表元为核心的对象
    主要以con划分对象，isol和tsol仅做参考作用
    保证RepSol对象的所有属性的相关变量都是global的。
*)
$ifndef _REPSOL_
$define _REPSOL_

RepSol:=module()
    option object;
    local
            # 局部函数
            getDisplayDcon::static, # 合并显示成立条件
            apList::static,         # 拓展list
            rmlist::static;         # 去除一层嵌套list
    export
            # 导出变量
            rep,                    # 代表元
            dcon:=[],               # 不变量方程
            acon:=[],               # 附加约束
            isol:=[],               # 代表元的通解
            tsol:=[],               # 代表元通解和特解的转化
            osol:=[],               # 对应的InvSol对象
            sid:=1,                 # 选择的最简条件
            # 导出函数
            ## 设置相关
            appendSol::static,      # 扩充一个RepSol对象成立的条件
            getCon::static,         # 获取一个RepSol对象成立的条件
            sortCon::static,        # 对成立条件进行排序
            selectCon::static,      # 选择最简成立条件
            rmCon::static,          # 删除某个成立条件的一部分
            ## 输出相关
            printRep::static,       # 简要显示代表元和所有可能的成立条件
            fullPrintRep::static,   # 显示代表元和完整的成立条件以及对应的不变量方程和变换方程的解
            ModulePrint::static,    # 简要显示代表元
            uniqueAndSort::static;      # 删去重复条件

    # 用于拓展一个代表元对象所能代表的区域
    appendSol:=proc(r::RepSol,s::InvSol)
        local ieq,sieq,isol,icon,tsols,tcons,i,n;
        if not assigned(r:-rep) then
            r:-rep:=getRep(s);
        end if;
        ieq:=s:-ieq;
        sieq:={ieq[]};
        isol:=s:-isol;
        icon:=s:-icon;
        tsols:=rmlist(s:-tsol);
        tcons:=rmlist(s:-tcon);
        n:=numelems(tsols);
        for i from 1 to n do
            apList(r:-dcon,ieq);
            apList(r:-acon,classifySolve({icon[],tcons[i][]}) minus sieq);
            apList(r:-isol,isol);
            apList(r:-tsol,tsols[i]);
            apList(r:-osol,s);
        end do;
        return;
    end proc:

    # 拓展list
    apList:=proc(lst::evaln)
        lst:=[eval(lst)[],_rest];
        return;
    end proc:

    # 获取一个RepSol对象成立的条件
    getCon:=proc(r::RepSol)
        return zip((x,y)->[getDisplayDcon(x)[],y[]],r:-dcon,r:-acon);
    end proc:

    # 不变量方程的简化显示
    getDisplayDcon:=proc(dcon)
        local n;
        n:=numelems(dcon);
        return [seq(Delta[i]=rhs(dcon[i]),i=1..n)];
    end proc:

    # 去掉一层嵌套list
    rmlist:=proc(x)
        return map(y->y[],x);
    end proc:

    # 对成立条件进行排序
    sortCon:=proc(r::RepSol)
        local con,ind;
        con:=getCon(r);
        ind:=sortByComplexity(con,index);
        r:-dcon:=r:-dcon[ind];
        r:-acon:=r:-acon[ind];
        r:-isol:=r:-isol[ind];
        r:-tsol:=r:-tsol[ind];
        r:-osol:=r:-osol[ind];
    end proc:

    # 选择最简成立条件
    selectCon:=proc(r::RepSol,sid)
        r:-sid:=sid;
        return;
    end proc:

    # 删除某个成立条件的一部分
    rmCon:=proc(r::RepSol,id::posint,con::set)
        r:-acon[id]:=r:-acon[id] minus con;
    end proc:

    # 简要显示代表元和所有可能的成立条件
    printRep:=proc(r::RepSol)
        print(r:-rep);
        print~(getCon(r));
        return ;
    end proc:

    # 显示代表元和完整的成立条件以及对应的不变量方程和变换方程的解
    fullPrintRep:=proc(r::RepSol)
        local i,n,con;
        print(r:-rep);
        con:=getCon(r);
        n:=numelems(con);
        for i from 1 to n do
            printf("[%d]------------------------------------------------------",i);
            print(con[i]);
            print(r:-isol[i]);
            print(r:-tsol[i]);
        end do;
        return;
    end proc:

    # 删去重复条件
    uniqueAndSort:=proc(r::RepSol)
        local id,con,fun,ind;
        fun:=(x,y,z)->[x,y,z];
        con:=getCon(r);
        id:=fun~(con,r:-isol,r:-tsol);
        ind:=uniqueObj(id,key=(x->x),'index');
        r:-dcon:=r:-dcon[ind];
        r:-acon:=r:-acon[ind];
        r:-isol:=r:-isol[ind];
        r:-tsol:=r:-tsol[ind];
        r:-osol:=r:-osol[ind];
        sortCon(r);
        return r;
    end proc:

    # 简要显示代表元
    ModulePrint:=proc(r::RepSol)
        return r:-rep;
    end proc:
end module:

$endif


`is_element/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 local TT1,B,C,P,T,U;
 global reason;

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

 P := sort(map(sort,map(op,{indices(Q)})));
 TT1 := select(T -> nops(T) > 1,TT);

 if P <> TT1 then
  reason := [convert(procname,string),"Q is not indexed by the big sets in TT",P,TT1];
  return false;
 fi;

 C := children_map(A)(TT);

 for T in P do
  if not(`is_element/SCP`(N)(T)(Q[T])) then
   reason := [convert(procname,string),"Q[T] is not in SCP(N)(T)",eval(Q[T]),N,T,reason];
   return false;
  fi;

  for U in C[T] do
   if nops(U) > 1 and not(`is_element/SCP2`(N)(T,U)([Q[T],Q[U]])) then
    reason := [convert(procname,string),"(Q[T],Q[U]) is not in SCP2(N)(T,U)",eval(Q[T]),eval(Q[U]),N,T,U,reason];
    return false;
   fi;
  od;
 od;

 return true;
end;

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

`random_element/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc()
 `mu/tree_Fbar/tree_FFbar`(N)(A)(TT)(`random_element/tree_Fbar`(N)(A)(TT)());
end;

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

`is_equal/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(P,Q)
 local T,TT1;
 global reason;

 TT1 := select(T -> nops(T) > 1,TT);

 for T in TT1 do
  if not(`is_equal/SCP`(N)(T)(P[T],Q[T])) then
   reason := [convert(procname,string),"P[T] <> Q[T]",T,P[T],Q[T],reason];
   return false;
  fi;
 od;

 return true;
end;

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

`is_leq/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(P,Q)
 local T,TT1;
 global reason;

 TT1 := select(T -> nops(T) > 1,TT);

 for T in TT1 do
  if not(`is_leq/SCP`(N)(T)(P[T],Q[T])) then
   reason := [convert(procname,string),"P[T] is not <= Q[T]",T,P[T],Q[T],reason];
   return false;
  fi;
 od;

 return true;
end;

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

`is_interior/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 return `is_element/ICP`(N)(A)(Q[A]);
end;

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

`inc/ICP/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q0)
 local Q,TT1,T,t;

 Q := table();
 TT1 := select(T -> nops(T) > 1,TT);
 for T in TT1 do
  Q[T] := `top/autorel`(T) intersect Q0;
 od;

 return eval(Q);
end:

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

`res/tree_FFbar/ICP` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 if not(`is_interior/tree_FFbar`(N)(A)(TT)(Q)) then
  return FAIL;
 fi;

 return Q[A];
end;

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

`res/FFbar/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 local TT1,Q1,T;

 TT1 := select(T -> nops(T) > 1,TT);

 Q1 := table():
 for T in TT1 do Q1[T] := eval(Q[T]); od;

 return eval(Q1);
end:

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

`ext/tree_FFbar/FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 local TT1,UU,TU,T,U,m,Q1,i;

 TT1 := select(T -> nops(T) > 1,TT);
 UU := `list_elements/big_subsets`(A);

 Q1 := table():

 for U in UU do
  TU := select(T -> U minus T = {},TT1);
  m := min(op(map(nops,TU)));
  TU := select(U -> nops(U) = m,TU);
  T := TU[1];
  Q1[U] := [seq(`top/autorel`(U) intersect Q[T][i],i=1..N)];
  if not(`is_element/SCP`(N)(U)(Q1[U])) then
   return FAIL;
  fi;
 od;

 return eval(Q1);
end:

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

`C/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 local L,TT1,T,G,i,ab;
 L := NULL;
 TT1 := select(T -> nops(T) > 1,TT);
 for T in TT1 do
  G := `gamma/SCP`(N)(T)(Q[T]);
  L := L,seq(seq([i,op(ab)],ab in G[i]),i=1..N);
 od;
 return {L};
end:

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

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

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

`mu/tree_Fbar/tree_FFbar` := (N::posint) -> (A::set) -> (TT) -> proc(x)
 local Q,TT1,T;

 TT1 := select(T -> nops(T) > 1,TT);

 Q := table();

 for T in TT1 do
  Q[T] := `mu/W/ACP`(N)(T)(x[T]);
 od;

 return eval(Q);
end;

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

`sigma/tree_FFbar/tree_Fbar` := (N::posint) -> (A::set) -> (TT) -> proc(Q)
 local x,TT1,T;

 TT1 := select(T -> nops(T) > 1,TT);

 x := table();

 for T in TT1 do
  x[T] := `sigma/ACP/W`(N)(T)(Q[T]);
 od;

 return eval(x);
end;


# Class: RealAlgebraicNumber
#
# Description:
#  Implementation of real algebraic numbers together with their comparison.
#  This implementation is inspired by the implementation in CGAL 4.7.
#
# Author:
#  Kacper Pluta - kacper.pluta@esiee.fr
#  Laboratoire d'Informatique Gaspard-Monge - LIGM, A3SI, France
#
# Date:
#  11/12/2015
#
# License:
#  Simplified BSD License
#
# Copyright (c) 2015, Kacper Pluta
# All rights reserved.

# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#   * Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#   * Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL Kacper Pluta BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
module RealAlgebraicNumber()
  option object;
  (* Univariete polynomaial *)
  local poly::polynom;
  (* Lower bound of the range in which exists only one real root of poly. *)
  local a::rational;
  (* Upper bound of the range in which exists only one real root of poly. *)
  local b::rational;
  (* Real algebraic number is rational when a = b and sign of poly at a/b is 0. *)
  local isRational_;
  (* Note that isolating interval has to be open iff a real algebraic number is not rational and
  closed, a = b, otherwise.*)

# Method: ModuleCopy
#   Standard constructor / copy constructor
#
# Parameters:
#   self::RealAlgebraicNumber     - a new object to be constructed
#   proto::RealAlgebraicNumber    - a prototype object from which self is derived
#   poly::polynom                 - a univariate polynomial
#   a::rational                   - a lower bound of the range in which exists only one real root of poly
#   b::rational                   - an upper bound of the range in which exists only one real root of poly
#
# Output:
#   An object of type RealAlgebraicNumber.
#
# Exceptions:
#  "Invalid range. A range is valid when: a <= b."
#  "Degree of %1 is invalid."
#
  export ModuleCopy::static := proc( self::RealAlgebraicNumber,
                                     proto::RealAlgebraicNumber,
                                     poly::polynom,
                                     a::rational,
                                     b::rational, $ )
    local signAtA, signAtB;
    if _passed = 2 then
      self:-poly := proto:-poly;
      self:-a := proto:-a;
      self:-b := proto:-b;
      self:-isRational_ := proto:-isRational_;
    else
      if upperbound( indets( poly ) ) > 1 then
        error "%1 is not univariate!", poly;
      end if;
      if a > b then
        error "Invalid range. A range is valid when: a <= b.";
      end if;
      if gcd( poly, diff( poly, op( indets( poly ) ) ) ) <> 1 then
        error "Polynomial: %1 is not square-free.", poly;
      end if;
      self:-poly := poly;
      if degree(poly) >= 1 then
        signAtA := signum( eval( poly, indets( poly )[1] = a ) );
        signAtB := signum( eval( poly, indets( poly )[1] = b ) );
        self:-a := a;
        self:-b := b;
        self:-isRational_ := evalb( self:-a = self:-b and signAtA = 0 );
        if signAtA = 0 and signAtB <> 0 then
          WARNING("Incorrect interval. Sign of univariate polynomial on one side of the interval"
          " evaluated to zero but not on the another. Interval fixed.");
          self:-b := self:-a;
          self:-isRational_ := true:
        elif signAtB = 0 and signAtA <> 0 then
          WARNING("Incorrect interval. Sign of univariate polynomial on one side of the interval"
          " evaluated to zero but not on the another. Interval fixed.");
          self:-a := self:-b;
          self:-isRational_ := true:
        elif signAtA = signAtB and self:-a <> self:-b then
          error "Interval incorrect! No root in the interval: (%1, %2), for %3 .", self:-a, self:-b,
          self:-poly;
        fi:
      elif degree( poly ) = 0 then
        self:- denom( poly ) * 'a'  - numer( poly );
        self:-a := poly;
        self:-b := poly;
        self:-isRational_ := true;
      else
        error "Degree of %1 is invalid.", poly;
      end if;
    end if;
    return self;
  end proc:

# Method: ModulePrint
#   Standard printout of an object of type RealAlgebraicNumber.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#
  export ModulePrint::static := proc( self::RealAlgebraicNumber )
    if(self:-a = self:-b) then
        nprintf( "( %a, [%a, %a] )", self:-poly, self:-a, self:-b );
    else
        nprintf( "( %a, ]%a, %a[ )", self:-poly, self:-a, self:-b );
    end if;
  end proc;

# Method: ModuleApply
#   Define standard constructor.
#
  export ModuleApply::static := proc()
   Object(RealAlgebraicNumber, args)
  end proc;

# Method: ModuleDeconstruct
#   Provides information how to recreate an object after being serialized.
#
# Parameters:
#   self::RealAlgebraicNumber        - a real algebraic number
#
  export ModuleDeconstruct := proc( self::RealAlgebraicNumber )
    ('RealAlgebraicNumber')(self:-poly, self:-a, self:-b)
  end proc;

# Method: GetPolynomial
#   A getter method to access the univariate polynomial of RealAlgebraicNumber.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   Univariate polynomial stored in self.
#
  export GetPolynomial::static := proc( self::RealAlgebraicNumber )
    return self:-poly;
  end proc:

# Method: GetInterval
#   A getter method to access the range isolating a root of univariate polynomial.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   The range isolating a root of univariate polynomial -- self:-poly.
#   Upper and lower bounds of a range are rationals. When lower = upper
#   then a real algebraic number is rational.
#
  export GetInterval::static := proc( self::RealAlgebraicNumber )
    return [ self:-a, self:-b ];
  end proc:

# Method: IsRational
#   A method to check if a real algebraic number is rational.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   True when a real algebraic number is rational, false
#   otherwise. A real algebraic number is meant as rational when a = b and
#   when sign of poly at a/b is zero.
#
  export IsRational::static := proc( self::RealAlgebraicNumber )
    return self:-isRational_;
  end proc:

# Method: CompareRational
#   A method used to compare a real algebraic number with a
#   rational number.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#   m::rational                    - a rational number
#
# Output:
#   -1 when a real algebraic number is smaller than a rational
#    number, 0 when they are equal and 1 when a real algebraic
#    number is bigger than a rational.
#
  local CompareRational::static := proc( self::RealAlgebraicNumber, m::rational )
    local refined:
    refined := StrongRefineAt(self,m);
    if evalb( refined:-a < m ) then
      return -1;
    elif evalb( refined:-a > m ) then
      return 1;
    elif evalb( signum( eval( refined:-poly, op( indets( refined:-poly ) ) = m ) ) = 0 ) then
      return 0;
    end if;
  end proc:

# Method: RefineAt
#   A method used to refine a real algebraic number using a rational
#   number for adaptation of a range isolating a root of poly.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#   m::rational                    - a rational number
#
# Output:
#   A RealAlgebraicNumber obtaind from self refined at m.
#
# Comment:
#   Not that the type can change to rational.
#
  local RefineAt::static := proc( self::RealAlgebraicNumber, m::rational )
    local signAtM, f::polynom, g::polynom;
    local var := op( indets( self:-poly ) );
    if self:-isRational_ or m <= self:-a or self:-b <= m then
      return self;
    end if;
    signAtM := signum( eval( self:-poly, var = m ) );
    if evalb( signAtM = 0 ) then
     g := denom( m ) * var  - numer( m );
     return Object( RealAlgebraicNumber, g, m, m );
    elif evalb( signum( eval( self:-poly, var = self:-a ) ) = signAtM ) then
      return Object( RealAlgebraicNumber, self:-poly, m, self:-b );
    elif evalb( signum( eval( self:-poly, var = self:-b ) ) = signAtM ) then
      return Object( RealAlgebraicNumber, self:-poly, self:-a, m );
    else
      return self;
    end if;
  end proc:

# Method: BisectRange
#   A method used to compare a real algebraic number with a
#   rational number.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   Refine an isolating range at ( self:-a + self:-b ) / 2
#
  local BisectRange::static := proc( self::RealAlgebraicNumber )
    return RefineAt( self, ( self:-a + self:-b ) / 2 );
  end proc:

# Method: StrongRefineAt
#   A method used to refine a real algebraic number using a rational
#   number for adaptation of a range isolating a root of poly.
#
# Parameters:
#   self::RealAlgebraicNumber      - a real algebraic number
#   m::rational                    - a rational number
#
  local StrongRefineAt::static := proc( self::RealAlgebraicNumber, m::rational )
    local refined:
    if self:-isRational_ or signum( eval( self:-poly, indets( self:-poly )[1] = m ) ) = 0 then
      return self;
    fi:
    refined := self;
    while refined:-a <= m and m <= refined:-b do
      refined := BisectRange(refined);
    od:
    return refined:
  end proc:

  export DisjointRanges::static := proc(a::RealAlgebraicNumber, b::RealAlgebraicNumber)
    local ll := a, rr := b, i;

    (* No intersection.*)
    if evalb( ll:-b < rr:-a ) or evalb( ll:-a > rr:-b ) then
      return [a,b];
    fi:

    for i from 1 while 1 = 1 do
      ll := BisectRange( ll ):
      rr := BisectRange( rr ):

      (* No intersection.*)
      if evalb( ll:-b < rr:-a ) or evalb( ll:-a > rr:-b ) then
        return [ll,rr];
      fi:
    od:
  end proc:

# Method: Compare
#   A method used to compare two real algebraic numbers.
#
# Parameters:
#   l::RealAlgebraicNumber      - a real algebraic number
#   r::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   -1 when l is smaller than r, 0 when they are equal and 1 when l is bigger than r.
#
  export Compare::static := proc( l::RealAlgebraicNumber, r::RealAlgebraicNumber, $ )
    local i::integer, a::rational, b::rational, F1::polynom, F2::polynom, G::polynom;
    local ll::RealAlgebraicNumber, rr::RealAlgebraicNumber;

    if indets(l:-poly) <> indets(r:-poly) then
      error "Univariate polynomials have different variables: %1 and %2.", indets(l:-poly),
      indets(r:-poly);
    fi;

    if evalb( l:-poly = r:-poly and l:-a = r:-a and l:-b = r:-b ) then
        return 0;
    end if;

    (* When rationals *)
    if r:-isRational_ then
      return CompareRational( l, r:-a );
    elif l:-isRational_ then
      return -CompareRational( r, l:-a );
    end if;

    (* Check if there is no intersection of the ranges *)
    if evalb( l:-b < r:-a ) then
      return -1;
    elif evalb( l:-a > r:-b ) then
      return 1;
    end if:

    (* Get the intersecting interval *)
    if evalb( l:-a > r:-a ) then
      a := l:-a;
    else
      a := r:-a;
    end if;
    if evalb( l:-b < r:-b ) then
      b := l:-b;
    else
      b := r:-b;
    end if;

    (* refine at the intersecting interval *)
    ll := RefineAt( l, a ):
    ll := RefineAt( ll, b ):
    rr := RefineAt( r, a ):
    rr := RefineAt( rr, b ):

    (* Refiment can change type to rational. *)
    if rr:-isRational_ then
      return CompareRational( ll, rr:-a );
    elif ll:-isRational_ then
      return -CompareRational( rr, ll:-a );
    end if;

    (* Check if there is no intersection after refiment. *)
    if evalb( ll:-b < rr:-a ) then
      return -1;
    elif evalb( ll:-a > rr:-b ) then
      return 1;
    end if;

    (* The number of roots of the GCD of two polynomials is equal to the number of common roots.
       use this to simplify the problem in the intersecting range.*)
    G := gcd( ll:-poly, rr:-poly );
    F1 := simplify( ll:-poly / G );
    F2 := simplify( rr:-poly / G );

    if evalb( signum( eval( G, op( indets( G ) ) = ll:-a ) ) <> signum( eval( G,
      op( indets( G ) ) = ll:-b ) ) ) then
      ll := Object( ll, G, ll:-a, ll:-b ):
    else
      ll := Object( ll, F1, ll:-a, ll:-b ):
    end if:

    if evalb( signum( eval( G, op( indets( G ) ) = rr:-a ) ) <> signum( eval( G,
      op( indets( G ) ) = rr:-b ) ) ) then
      rr := Object( rr, G, rr:-a, rr:-b ):
    else
      rr := Object( rr, F2, rr:-a, rr:-b ):
    end if:

    (* Use of GCD can change type to rational. *)
    if rr:-isRational_ then
      return CompareRational( ll, rr:-a );
    elif ll:-isRational_ then
      return -CompareRational( rr, ll:-a );
    end if;

    (* Check for equality. *)
    if evalb( signum( eval( G, op( indets( G ) ) = a ) ) <> signum( eval( G,
      op( indets( G ) ) = b ) ) ) then
      return 0;
    end if;

    (* Refiment until disjoitness. *)
    for i from 1 while 1 = 1 do
      ll := BisectRange( ll ):
      rr := BisectRange( rr ):

      (* Rationals after refiment. *)
      if rr:-isRational_ then
        return CompareRational( ll, rr:-a );
      elif ll:-isRational_ then
        return -CompareRational( rr, ll:-a );
      end if;

      (* No intersection after refiment. *)
      if evalb( ll:-b < rr:-a ) then
        return -1;
      elif evalb( ll:-a > rr:-b ) then
        return 1;
      end if:
    end do:
  end proc:

# Method: < operator
#   A method used to compare two real algebraic numbers.
#
# Parameters:
#   l::RealAlgebraicNumber      - a real algebraic number
#   r::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   true when l is smaller than r and false otherwise.
#
  export `<`::static := proc( l, r, $ )
   if ( _npassed <> 2 or not l::RealAlgebraicNumber or not r::RealAlgebraicNumber ) then
    return false;
  end if;
  if Compare( l, r ) = -1 then
    return true;
  else
    return false;
  end if;
  end proc:

# Method: <= operator
#   A method used to compare two real algebraic numbers.
#
# Parameters:
#   l::RealAlgebraicNumber      - a real algebraic number
#   r::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   true when l is smaller or equal to r and false otherwise.
#
  export `<=`::static := proc( l, r, $ )
   if ( _npassed <> 2 or not l::RealAlgebraicNumber or not r::RealAlgebraicNumber ) then
    return false;
  end if;
  if Compare( l, r ) <= 0 then
    return true;
  else
    return false;
  end if;
  end proc:

# Method: = operator
#   A method used to compare two real algebraic numbers.
#
# Parameters:
#   l::RealAlgebraicNumber      - a real algebraic number
#   r::RealAlgebraicNumber      - a real algebraic number
#
# Output:
#   true when l is equal to r and false otherwise.
#
  export `=`::static := proc( l, r, $ )
    if Compare( l, r ) = 0 then
      return true;
    else
      return false;
    end if;
  end proc:

end module:


`type/pN2spart` := proc(spart)
    return isSpartValid(spart);
end proc:

`type/a_indet` := proc(a) local bool;
	if convert(a,string)[1] = "a" and type(a,indexed) then bool:=true; else bool:=false; end if;
	return bool;
end proc:

`type/b_indet` := proc(a) local bool;
	if convert(a,string)[1] = "b" and type(a,indexed) then bool:=true; else bool:=false; end if;
	return bool;
end proc:
`type/z_var` := proc(expr) local bool;
	bool:=false;
	if convert(expr, string)[1]= "z" and type(expr, commutative) and nops(indets(expr)) <2 and degree(expr)=1 then bool:=true; end if;
	return bool;
end proc:

`type/AC_phi` := proc(expr) local bool;
	bool:=false;
	if convert(expr, string)[1..3] = "phi" and type(expr, anticommutative) and nops(indets(expr)) <2 then bool:= true; end if;
	return bool;
end proc:

`type/AC_theta` := proc(expr) local bool;
	bool:=false;
	if convert(expr, string)[1..3] = "the" and type(expr, anticommutative) and nops(indets(expr)) <2 then bool:= true; end if;
	return bool;
end proc:

`type/powersum_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "p[" and type(expr,indexed) then bool := true; else bool:= false; end if;
    return bool;
end proc:

`type/monomial_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "m[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/homogeneous_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "h[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/elementary_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "e[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:
`type/g_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "g[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/schur_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "s[" and convert(expr,string)[2] <> "b" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/schurEtoile_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..4] = "sEt[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/schurbar_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..5] = "sbar[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:
`type/schurbarEtoile_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..7] = "sbarEt[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/ep_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..3] = "ep[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/ph_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..3] = "ph[" and type(expr, indexed) then bool := true; else bool := false; end if;
    return bool;
end proc:

`type/jack_symbolic` := proc(expr) local bool;
	if convert(expr,string)[1..2] = "P[" and type(expr, indexed) then bool := true; else bool := false; end if;
end proc:

`type/superbase` := proc(expr) local bool;
	bool:= type(expr, monomial_symbolic) or type(expr, powersum_symbolic) or type(expr, elementary_symbolic) or type(expr, homogeneous_symbolic) or type(expr, g_symbolic) or type(expr, schur_symbolic) or type(expr, schurEtoile_symbolic) or type(expr, schurbar_symbolic) or type(expr, schurbarEtoile_symbolic) or type(expr, ep_symbolic) or type(expr, ph_symbolic) or type(expr, jack_symbolic);
	return bool;
end proc:

`type/superindexed`:= proc(expr) local bool;
	bool:= type(expr, indexed) and type([op(expr)], pN2spart);
	return bool;
end proc:

super_whattype:= proc(expr)
	local element_of_basis, sample, types, which_one, the_one;
	element_of_basis:= indets(expr, superbase);
	if nops(element_of_basis) = 0 then return other; end if;
	sample:= element_of_basis[1];
	types:= [
				powersum_symbolic,
				monomial_symbolic,
				homogeneous_symbolic,
				elementary_symbolic,
				g_symbolic,
				schur_symbolic,
				schurEtoile_symbolic,
				schurbar_symbolic,
				schurbarEtoile_symbolic,
				ep_symbolic,
				ph_symbolic,
				jack_symbolic
			];
	which_one:= map(x-> type(sample, x), types);
	the_one:= ListTools:-Search(true, which_one);
	return types[the_one];
end proc:


# This defines the chain complex version of the Barratt-Eccles operad.
# Basis elements of E(A) are represented by expressions T(...), where
# there is at least one argument, each argument is a list containing
# each element of A precisely once, and no two adjacent arguments are
# the same.

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

 if x = 0 then return true; fi;

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

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

 if not type(x,specfunc(T)) then return false; fi;

 if nops(T) = 0 then return false; fi;

 for i from 1 to nops(x) do
  if not(`is_element/ord`(A)(op(i,x))) then
   return false;
  fi;
 od;

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

 return true;
end:

# Auxiliary function feeding into `diff/barratt_eccles`

`diff0/barratt_eccles` := (A::set) -> proc(x)
 local y,n,i;

 y := 0;
 n := nops(x);

 for i from 1 to n do
  if 1 < i and i < n and op(i-1,x) = op(i,x) then
   continue;
  fi;

  y := y + (-1)^(i-1) * T(op(1..i-1,x),op(i+1..n,x));
 od;

 return y;
end:

# Differential on the chain complex
`diff/barratt_eccles` := (A::set) -> apply_linear(`diff0/barratt_eccles`(A));

# Auxiliary function feeding into `deg/barratt_eccles`
`deg0/barratt_eccles` := (A) -> (x) -> nops(x) - 1;

# Degree function
`deg/barratt_eccles` := (A) -> apply_deg(`deg0/barratt_eccles`(A));

# 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/barratt_eccles` := (A,B) -> proc(u,v)
 local d,e,SS,x,s,p,w,u0,v0,w0,i;

 d := nops(u) - 1;
 e := nops(v) - 1;
 SS := `list_elements/shuffles`(d,e);

 x := 0;

 for s in SS do
  p := `to_grid_path/shuffles`(d,e)(s);
  w := NULL;
  for i from 0 to d+e do
   u0 := op(p[i][1]+1,u);
   v0 := op(p[i][2]+1,v);
   w0 := subs(B = op(v0),u0);
   w := w,w0;
  od:
  x := x + `sgn/shuffles`(d,e)(s) * T(w);
 od:

 return x;
end:

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

# We now have various functions related to an interesting filtration
# of the operad.
`flip_count/barratt_eccles` := (A::set) -> proc(x)
 local m,a,b,k,rr,i,r0,r1;

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

 k := nops(x);
 rr := map(`rank_table/ord`(A),[op(x)]);

 for i from 1 to k-1 do
  r0 := rr[i];
  r1 := rr[i+1];

  for a in A do
   for b in A do
    if (r1[b] - r1[a]) * (r0[b] - r0[a]) < 0 then
     m[a,b] := m[a,b] + 1;
    fi;
   od;
  od;
 od;

 return eval(m);
end:

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

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

 m := `flip_count/barratt_eccles`(A)(x);

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

 return mm;
end:

`is_member/barratt_eccles_cells` := (A::set) -> proc(ms)
 local m,s,AA,a,b;

 if not(type(ms,list) and nops(ms) = 2) then return false; fi;

 m,s := op(ms);

 if not(`is_element/ord`(A)(s)) then return false; fi;
 if not(type(m,table)) then return false; fi;

 AA := {seq(seq([a,b],b in A),a in A)};
 if {indices(m)} <> AA then return false; fi;

 for a in A do
  for b in A do
   if not(type(m[a,b],nonnegint)) then return false; fi;
  od:
 od:

 for a in A do
  if m[a,a] <> 0 then return false; fi;
  for b in A do
   if m[a,b] <> m[b,a] then return false; fi;
  od;
 od;

 return true;
end:

`is_cell_member/barratt_eccles` := (A::set) -> (ms) -> proc(x)
 local m0,m1,s,a,b,y,z;

 if x = 0 then return true; fi;
 if type(x,`+`) then
  return `and`(seq(`is_cell_member/barratt_eccles`(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/barratt_eccles`(A)(ms)(z[1]);
  else
   return false;
  fi;
 fi;

 m0,s := op(ms);
 m1 := `flip_count/barratt_eccles`(A)(T(op(x),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/barratt_eccles` := (A::set) -> proc(x)
 local m,m_max,s,rr,k,i,r0,r1,a,b;

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

 return 1 + `max_flip_count/barratt_eccles`(A)(x);
end:

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