# Copyright (c) 2018-2021, Carnegie Mellon University
# See LICENSE for details

# Eventually, PowerOpt should grow into a general
# loop induction variable optimization pass

ModMultOpt := code -> SubstBottomUp(code,
    [mul, @(1,Value), [imod, @r, @N]],
    e -> let(k := @(1).val.v, imod(k * @r.val, k * @N.val)));

PowerOpt := function(code)
    local powers, p, pvar, pmap;
    powers := Set(Collect(code, powmod));
    #loops := TabList( Flat(List(Collect(code, loop), l->[l.var.id, l]) ));
    #loopvars := NSFields(loops);
    for p in powers do
	if IsValue(p.args[2]) and IsVar(p.args[3]) and IsLoopIndex(p.args[3]) then
	    #Print("---", p, "---\n");
	    pvar := var.fresh("p", TInt, p.args[4].v);
	    code := SubstBottomUp(code, [powmod,
		    @(1).cond(e->e=p.args[1]),
		    @(2,Value,e->e.v=p.args[2].v),
		    @(3,var,  e->Same(e,p.args[3])),
		    @(4,Value,e->e.v=p.args[4].v)], e->pvar);

	    code := SubstBottomUp(code, @(1,loop,e->Same(e.var,p.args[3])),
		e -> decl([pvar],
		    chain(
			assign(pvar, p.args[1]),
			loop(@(1).val.var, @(1).val.range,
			    chain(@(1).val.cmd,
				assign(pvar, imod(mul(pvar, p.args[2]), p.args[4])))))));
	fi;
    od;
    return code;
end;

RangeProp := c->SubstBottomUp(c, [assign, @(1, var), @(2, var, e->IsBound(e.range))],
    e -> assign(@(1).val.setRange(@(2).val.range), @(2).val));


#
# cls 15: A_2
#
handle15char2:=function()
    local tmp1,tmp2,o,info,rep,cent,u;
    o:=AllClasses(orbs)[15];
    info:=infos[15];

    rep:=Representative(o);
    #pr[7]=[0,0,1,1]-->[0,1,1,0]
    #pr[13]=[0,1,2,1]-->[1,1,2,0]
    tmp1:=ApplyRootsReflections(rep,[7,13]);
    u:=Unipotent(algebraicU(orbs),[[4,1]]);
    tmp1:=Conj(tmp1,u);

    cent:=FromPositiveBorel(o,info[2]);
    tmp2:=ApplyRootsReflections(cent,[7,13]);
    tmp2:=Conj(tmp2,u);

    return [tmp1,tmp2];
end;

#
# cls 14: \tilde A_2
#
handle14char2:=function()
    local tmp1,tmp2,o,info,rep,cent,u;
    o:=AllClasses(orbs)[14];
    info:=infos[14];

    rep:=Representative(o);
    #pr[8]=[1,0,1,1]-->[0,1,1,1]
    #pr[10]=[0,0,2,1]-->[0,1,2,0]
    # merge si [13,11],[19,20]
    tmp1:=ApplyRootsReflections(rep,[8,10]);
    u:=Unipotent(chevalleyAdj(rep),[[3,1]],Ordering(rep));
    tmp1:=Conj(tmp1,u);

    cent:=FromPositiveBorel(o,info[2]);
    tmp2:=ApplyRootsReflections(cent,[8,10]);
    u:=Unipotent(chevalleyAdj(rep),[[3,1]],Ordering(cent));
    tmp2:=Conj(tmp2,u);

    return [tmp1,tmp2];
end;

#
# cls 12: B_2
#
handle12char2:=function()
    local tmp1,tmp2,o,info,rep,cent;
    o:=AllClasses(orbs)[12];
    info:=infos[12];

    rep:=Representative(o);
    tmp1:=ApplyRootsReflections(rep,[9]);#pr[9]=[0,1,1,1]-->[1,1,1,0]
    cent:=FromPositiveBorel(o,info[2]);
    tmp2:=ApplyRootsReflections(cent,[9]);#pr[9]=[0,1,1,1]-->[1,1,1,0]
    return [tmp1,tmp2];
end;

#
# cls 11: B_2^{(2)} [6,12,22]
#
# here there is no component group
#
handle11char2:=function()
    local rep,cc,zz,uu;

    rep:=Unipotent(alg,[[6,1],[12,1],[22,1]]);
    cc:=UnipotentCentralizer(rep);
    zz:=Zentrum(cc[1]);
    uu:=Unipotent(alg,[[1,1]],Ordering(rep));# A_1 the reductive part of the Levi

    return [rep,cc,zz,uu,TorusWeights(zz,[1])];
end;

#
# cls 8: C_3(a_1)
#
# here there is no component group
#
handle8char2:=function()
    local o,rep,cc,ccc,zz,zzz,uu,dist_par;

    o:=AllClasses(orbs)[8];
    rep:=BorelRep(o);
    vals:=ShallowCopy(avars);
    vals[1]:=Zero(APR);
    vals[2]:=Zero(APR);
    vals[5]:=Zero(APR);
    vals[6]:=Zero(APR);
    vals[8]:=Zero(APR);
    vals[12]:=vals[11];
    vals[15]:=vals[9];
    vals[18]:=vals[13];
    vals[20]:=vals[16];
    cc:=Value(generic,avars,vals);
    # a_9+a_9^2+a_11^2=0
    #ccc:=Value(cc,[avars[9]],[Zero(APR)]); NU: a_9=0 <=> a_11=0

    zz:=Zentrum(infos[8][1]); # centrul centralizatorului calculat inainte
    dist_par:=ToPositiveBorel(o,0Level(DistinguishedParabolic(o)));
    zzz:=Subword(zz,dist_par);
#    uu:=Unipotent(alg,[[1,1]],Ordering(rep));# A_1 the reductive part of the Levi

    return [cc,zz,zzz];
end;

##
## cls 7: C_3(a_1)
##
#handle7char3:=function()
#    local tmp1,tmp2,o,info,rep,cent;
#    o:=AllClasses(orbs)[7];
#    info:=infos[7];
#
#    rep:=Representative(o);
#    tmp1:=ConjugateByTorus(rep,1,-1);# h_1 --> h_4
#    cent:=FromPositiveBorel(o,info[5]);
#    tmp2:=ConjugateByTorus(cent,1,-1);# h_1 --> h_4
#    return [tmp1,tmp2];
#end;

#
# cls 6: F_4(a_3) [4,6,10,18] (finished?)
#
handle6char2:=function()
    local tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,o,info,rep,cent,uu;
    o:=AllClasses(orbs)[6];
    info:=infos[6];

    rep:=Representative(o);
    tmp1:=ApplyRootsReflections(rep,[3]);#pr[3]=[0,0,1,0]-->[0,0,1,0]
    uu:=Unipotent(chevalleyAdj(rep),[[2,-1],[6,1]],Ordering(rep));
    tmp1:=Conj(tmp1,uu);
    #tmp1:=ConjugateByTori(tmp1,[1,2,3,4],[1,-1,aaa,aaa^2]);

    tmp3:=ApplyRootsReflections(rep,[5,1]);
    uu:=Unipotent(chevalleyAdj(rep),[[2,1]],Ordering(rep));#[1..24]);
    tmp3:=Conj(tmp3,uu);
    tmp3:=ConjNegUa(tmp3,2,1);
    uu:=Unipotent(chevalleyAdj(rep),[[6,1],[4,1]],Ordering(rep));
    tmp3:=Conj(tmp3,uu);

    #tmp5:=ConjugateByTori(rep,[3],[-1]);

    cent:=FromPositiveBorel(o,info[2]);
    tmp2:=ApplyRootsReflections(cent,[3]);#pr[3]=[0,0,1,0]-->[0,0,1,0]
    uu:=Unipotent(chevalleyAdj(cent),[[2,-1],[6,1]]);
    tmp2:=Conj(tmp2,uu);
    #tmp2:=ConjugateByTori(tmp2,[1,2,3,4],[1,-1,aaa,aaa^2]);

    tmp4:=ApplyRootsReflections(cent,[5,1]);
    uu:=Unipotent(chevalleyAdj(rep),[[2,1]],Ordering(cent));#[1..24]);
    tmp4:=Conj(tmp4,uu);
    tmp4:=ConjNegUa(tmp4,2,1);
    uu:=Unipotent(chevalleyAdj(rep),[[6,1],[4,1]],Ordering(cent));
    tmp4:=Conj(tmp4,uu);
    #tmp4:=ConjugateByTori(tmp4,[3],[aaa]);

    #tmp6:=ConjugateByTori(cent,[3],[-1]);

    return [tmp1,tmp3,tmp2,tmp4];
end;

#
# cls 3: F_4(a_2) (finished?)
#
handle3char2:=function()
    local tmp1,tmp2,o,info,rep,cent,uu,
    avars,vals,comp1,comp2;
    o:=AllClasses(orbs)[3];
    info:=infos[3];

    rep:=Representative(o);
    tmp1:=ApplyRootsReflections(rep,[2,3]);
    uu:=Unipotent(chevalleyAdj(rep),[[1,1],[10,1]],Ordering(rep));
    tmp1:=Conj(tmp1,uu);

    cent:=FromPositiveBorel(o,info[2]);
    tmp2:=ApplyRootsReflections(cent,[2,3]);
    uu:=Unipotent(chevalleyAdj(cent),[[1,1],[10,1]],Ordering(cent));
    tmp2:=Conj(tmp2,uu);

    avars:=IndeterminatesOfPolynomialRing(ring(chevalleyAdj(rep)));
    vals:=ShallowCopy(avars);
    vals[1]:=One(APR);
    vals[2]:=Zero(APR);
    vals[3]:=Zero(APR);
    vals[4]:=vals[7];
    vals[6]:=vals[7]+One(APR);
    vals[9]:=vals[7];
    vals[5]:=vals[6]+vals[9];
    vals[10]:=One(APR)+vals[7];
    vals[11]:=vals[16]+vals[7]+vals[7]^2;
    vals[12]:=vals[7]*vals[9]+vals[7]+vals[16];
    vals[13]:=vals[9];
    vals[15]:=vals[16]+vals[7]^2;
    vals[17]:=vals[19]+vals[16]+vals[7]+vals[7]^2;
    vals[18]:=vals[16]+vals[7]+vals[7]^2;
    vals[20]:=vals[16]^2+vals[7]+vals[7]^4;
    vals[22]:=vals[7]^4+vals[7]^2+vals[16]^2+vals[7]+vals[16];
    comp1:=Value(generic,avars,vals);

    vals:=ShallowCopy(avars);
    vals[1]:=Zero(APR);
    vals[2]:=Zero(APR);
    vals[3]:=Zero(APR);
    vals[7]:=vals[4];
    vals[6]:=vals[7];
    vals[9]:=vals[7];
    vals[5]:=vals[6]+vals[9];
    vals[10]:=vals[7];
    vals[13]:=vals[9];
    vals[12]:=vals[7]*vals[9]+vals[16];
    vals[11]:=vals[16]+vals[7]^2;
    vals[15]:=vals[16]+vals[7]^2;
    vals[17]:=vals[19]+vals[16]+vals[7]^2;
    vals[18]:=vals[16]+vals[7]^2;
    vals[20]:=vals[16]^2+vals[7]^4;
    vals[22]:=vals[7]^4+vals[7]^2+vals[16]^2+vals[16];
    comp2:=Value(generic,avars,vals);

    return [comp1,comp2,tmp1,tmp2];
end;
#vals:=ShallowCopy(avars);
#vals[1]:=One(APR);
#vals[2]:=Zero(APR);
#vals[3]:=Zero(APR);
#vals[4]:=vals[7];
#vals[6]:=vals[7]+One(APR);
#vals[9]:=vals[7];
#vals[5]:=vals[6]+vals[9];
#vals[10]:=One(APR)+vals[7];
#vals[11]:=vals[16]+vals[7]+vals[7]^2;
#vals[12]:=vals[7]*vals[9]+vals[7]+vals[16];
#vals[13]:=vals[9];
#vals[15]:=vals[16]+vals[7]^2;
#vals[17]:=vals[19]+vals[16]+vals[7]+vals[7]^2;
#vals[18]:=vals[16]+vals[7]+vals[7]^2;
#vals[20]:=vals[16]^2+vals[7]+vals[7]^4;
#vals[22]:=vals[7]^4+vals[7]^2+vals[16]^2+vals[7]+vals[16];
#
#xx:=Value(generic,avars,vals);
#vals:=List([1..Length(avars)],i->Zero(APR));
#vals[7]:=One(APR);
#xx0:=Value(xx,avars,vals);
#xxx:=Value(cc[1],[avars[1],avars[2],avars[3],avars[4],avars[5]],[Zero(APR),Zero(APR),Zero(APR),avars[7]^2+avars[8]*avars[7]+a#vars[7]*avars[14]+One(APR),One(APR)]);
#
#vals:=ShallowCopy(avars);
#vals[1]:=Zero(APR);
#vals[2]:=Zero(APR);
#vals[3]:=Zero(APR);
#vals[7]:=vals[4];
#vals[6]:=vals[7];
#vals[9]:=vals[7];
#vals[5]:=vals[6]+vals[9];
#vals[10]:=vals[7];
#vals[13]:=vals[9];
#vals[12]:=vals[7]*vals[9]+vals[16];
#vals[11]:=vals[16]+vals[7]^2;
#vals[15]:=vals[16]+vals[7]^2;
#vals[17]:=vals[19]+vals[16]+vals[7]^2;
#vals[18]:=vals[16]+vals[7]^2;
#vals[20]:=vals[16]^2+vals[7]^4;
#vals[22]:=vals[7]^4+vals[7]^2+vals[16]^2+vals[16];
##Print("ok");
#yy:=Value(generic,avars,vals);
#vals[8]:=avars[1];#
#vals[16]:=avars[2];#
#vals[14]:=avars[3];#
#vals[19]:=avars[5];#
#vals[21]:=avars[6];#
#vals[23]:=avars[9];#
#vals[24]:=avars[10];#
##vals:=ShallowCopy(avars);
#yy0:=Value(yy,avars,vals);
#yyy:=Value(cc[1],[avars[1],avars[2],avars[3],avars[4],avars[5]],[Zero(APR),Zero(APR),Zero(APR),avars[8]*avars[7]+avars[7]*avars[14],Zero(APR)]);
#
#vals:=List([1..Length(avars)],i->Zero(APR));
#vals[4]:=One(APR);
#vals[16]:=One(APR);
#yy1:=Value(yy,avars,vals);

#
# cls 2: F_4(a_1)
#
handle2char2:=function()
    local tmp1,tmp2,o,info,rep,cent,uu;
    o:=AllClasses(orbs)[2];
    info:=infos[2];

    rep:=Representative(o);
    tmp1:=ConjugateByTori(rep,[3,1],[-1,-1]);# h_1 --> h_4, h_3 --> h_3
    uu:=Unipotent(chevalleyAdj(rep),[[3,-1]],Ordering(rep));#pr[3]=[0,0,1,0]-->[0,0,1,0]
    tmp1:=Conj(tmp1,uu);

    cent:=FromPositiveBorel(o,info[5]);
    tmp2:=ConjugateByTori(cent,[3,1],[-1,-1]);# h_1 --> h_4, h_3 --> h_3
    uu:=Unipotent(chevalleyAdj(cent),[[3,-1]],Ordering(cent));#pr[3]=[0,0,1,0]-->[0,0,1,0]
    tmp2:=Conj(tmp2,uu);

    return [tmp1,tmp2];
end;


########################################################################
#
# walrus: Computational Methods for Finitely Generated Monoids and Groups
#
# WARNING
#
########################################################################
#
# TODO (documentation)
#  - Examples
#  - notes on the implementation (design decisions etc)
#
# TODO (technical)
#  - MakeIsReducedDiagram an operation
#  - Sort out families of elements etc
#  - what to do about the __ID hack?
#  - What to do about float vs rational?
#  - provide a way to label generators
#  - Introduce an InfoLevel and log things with info levels, remove Print
#    statements
#  - Put relators of different presentations into different families
#  - Check whether some sub-functions could be cleaned out from functions
#    and would become more generally useful
#  - Better indexing of locations on relator/places
#  - Better datastructure for storing one step reachables
#    (basically a hashmap from orb I think) plus wrapper functions
#  - PlaceQuadruples should be an object or a record
#  - Add proper error messages for "This shouldn't happen" with a pointer
#    towards the github issue tracker
#  - Make a reasonably standard format (and exporter/importer) to exchange
#    pregroup presentations so we can move them between GAP/other
#    implementations for cross-checking

#
# TODO (mathematical/functional)
#  - Write tests
#  - Interleaving
#  - Preparing the presentation (User choosing Pregroup/removing generators, relators)
#  - check LocationBlobGraph + distances
#  - Make the distance computation in LBG more efficient?
#  - Check OneStepReachables
#  - Check RSymTest
#
########################################################################
#
# Some notes on the implementation
#
# - Stored curvature is always "negative curvature", so in most cases a
#   positive value.
# - Curvature values are stored as rationals at first, later converted to
#   floats. This might not be the best way to do this (we might want to
#   always use rationals or always use floats)
#

# Alternative to LocationBlobGraph, only has pairs, coloured Green for location pair
# and red for intermult pair
# a bit hacky though
InstallMethod(VertexGraph, "for a pregroup presentation",
              [IsPregroupPresentation and IsPregroupPresentationRep],
function(pres)
    local mat, v, vd, vg, e, loc, loc2, pg, p, ploc, ploc2, imp, i, backmap, len, li, labels;

    pg := Pregroup(pres);

    li := LocationIndex(pres);

    # Green vertices [[a, b], 0] correspond to locations
    v := List(Keys(li), l -> [l, 0]);
    # Red vertices correspond to intermult pairs
    Append(v, List(IntermultPairs(pg), p -> [p, 1]));

    e := function(a,b)
        if (a[2] = 0) and (b[2] = 0) then              # both vertices are green
            if PregroupInverse(a[1][2]) = b[1][1] then # There are locations R(i,a,b) and R'(j,b^-1,c)
                ploc := li[a[1]];
                ploc2 := li[b[1]];
                for loc in ploc do
                    for loc2 in ploc2 do
                        if CheckReducedDiagram(loc, loc2) then
                            return 1;
                        fi;
                    od;
                od;
                return infinity;
            fi;
        elif (a[2] = 0) and (b[2] = 1) then            # a is green, b is red
            if PregroupInverse(a[1][2]) = b[1][1] then # There is location R(i,a,b)
                return 1;
            fi;
        elif (a[2] = 1) and (b[2] = 0) then            # a is red, b is green
            if PregroupInverse(a[1][2]) = b[1][1] then #
                return 0;
            fi;
        fi;
        return infinity;
    end;

    backmap := HashMap();
    for i in [1..Length(v)] do
        backmap[ [__ID(v[i][1][1]), __ID(v[i][1][2]), v[i][2] ] ] := i;
    od;

    vg := Digraph(v, {i,j} -> e(i,j) <> infinity);
    SetDigraphVertexLabels(vg, v);

    mat := List(DigraphVertices(vg), i -> List(DigraphVertices(vg), j -> e(v[i], v[j]) ) );
    vg!.mat := mat;
    vg!.backmap := backmap;

    return vg;
end);

InstallMethod(VertexGraphDistances, "for a pregroup presentation",
              [IsPregroupPresentation and IsPregroupPresentationRep],
function(pres)
    local vg, wt, f, vertices, n, mat, i, j, k, a, b, t, out;

    vg := VertexGraph(pres);
    vertices := DigraphVertices(vg);
    mat := vg!.mat;

#    SC_FLOYD_WARSHALL(mat);

    for k in vertices do
        for i in vertices do
            for j in vertices do
                t := mat[i, k] + mat[k, j];
                if t < mat[i,j] then
                    mat[i,j] := t;
                fi;
            od;
        od;
    od;
    # Can there be more than one such entry?
    return mat;
end);

InstallMethod(VertexTriples, "for a pregroup presentation",
            [IsPregroupPresentation and IsPregroupPresentationRep],
function(pres)
    local v, v1, v2, v1l, v2l, vl, vg, lv, vgd, dist, vtl;

    vg := VertexGraph(pres);
    vgd := VertexGraphDistances(pres);
    vtl := HashMap(16384);

    for v in DigraphVertices(vg) do

        vl := DigraphVertexLabel(vg, v);
        # Only green vertices
        if (vl[2] = 0) then
          for v1 in InNeighboursOfVertex(vg, v) do
              v1l := DigraphVertexLabel(vg, v1);
              for v2 in OutNeighboursOfVertex(vg, v) do
                  v2l := DigraphVertexLabel(vg, v2);
                  dist := vgd[v2][v1];
                  if (v1l[2] = 0) and (v2l[2] = 0) then
                      if dist = 1 then
                          vtl[ [v, v1, v2 ] ] := 1/6;
                      elif dist = 2 then
                          vtl[ [ v, v1, v2 ] ] := 1/4;
                      elif dist = 3 then
                          vtl[ [ v, v1, v2 ] ] := 3/10;
                      elif dist > 3 then
                          vtl[ [ v, v1, v2 ] ] := 1/3;
                      else
                          Error("this shouldn't happen");
                      fi;
                  elif (v1l[2] = 0) and (v2l[2] = 1) then
                      if dist = 0 then
                          vtl[ [ v, v1, v2 ] ] := 0;
                      elif dist = 1 then
                          vtl[ [ v, v1, v2 ] ] := 1/6;
                      elif dist > 1 then
                          vtl[ [ v, v1, v2 ] ] := 1/4;
                      else
                          Error("this shouldn't happen");
                      fi;
                  elif (v1l[2] = 1) and (v2l[2] = 0) then
                      if dist = 1 then
                          vtl[ [ v, v1, v2 ] ] := 0;
                      elif dist = 2 then
                          vtl[ [ v, v1, v2 ] ] := 1/6;
                      elif dist > 2 then
                          vtl[ [ v, v1, v2 ] ] := 1/4;
                      else
                          Error("this shouldn't happen");
                      fi;
                  elif (v1l[2] = 1) and (v2l[2] = 1) then
                      vtl[ [ v, v1, v2 ] ] := 0;
                      # what if dist=infinity (i.e. no path)
                  else
                      Error("this should not happen");
                  fi;
              od;
          od;
        fi;
    od;
    return vtl;
end);

InstallGlobalFunction(Vertex,
function(pres, v1, v, v2)
    local vt, t;

    t := VertexTriples(pres)[ [v, v1, v2] ];
    if t <> fail then
        return t;
    else
        return 1/3;
    fi;
end);

#XXX Computes triples (a,b,c) that are infixes
#    of strings found here with appropriate numbers
InstallMethod(ShortRedBlobIndex, "for a pregroup presentation",
              [IsPregroupPresentation],
function(pres)
    local pg, n, imm, index, nrl, cand, word, nonrletts, len, c;

    pg := Pregroup(pres);
    n := Size(pg);
    imm := IntermultMapIDs(pg);

    # TODO: This would be better done by a tree structure
    index := HashMap();

    cand := [[2..n]];

    nonrletts := [];
    word := [];

    len := 1;

    # minimum length 3
    while (len > 0) and (len < 7) do
        if Length(cand[len]) > 0 then
            c := Remove(cand[len], 1);
            word[len] := pg[c];
            nonrletts[len] := not IsRLetter(pres, pg[c]);
            # Possible not go further if we have too many R-letters?
            if IsIntermultPair(word[len], word[1]) and
               ReduceUPregroupWord(word{ [1..len] }) = [] then
                nrl := SizeBlist(nonrletts{[1..len]});
                if len = 3 then
                    # if len = 3 then no proper subword can be equal to 1
                    # because we only look at intermult pairs, and pairs
                    # of inverses are explicitly not intermult pairs
                    if nrl = 0 then
                        EnterAllSubwords(index, word{[1..len]}, 1/6);
                    elif nrl = 1 then
                        EnterAllSubwords(index, word{[1..len]}, 1/4);
                    else
                        # Print("? nrl", nrl, "\n");
                    fi;
                elif len = 4 then
                    if nrl = 0 then
                        EnterAllSubwords(index, word{[1..len]}, 1/4);
                    elif nrl = 1 then
                        EnterAllSubwords(index, word{[1..len]}, 1/3);
                    else
                        # Print("? nrl", nrl, "\n");
                    fi;
                elif len = 5 then
                    if (nrl = 0) then
                        EnterAllSubwords(index, word{[1..len]}, 3/10);
                    fi;
                elif (len = 6)
                     and (ReduceUPregroupWord(word{[2,3,4]}) <> [])
                     and (ReduceUPregroupWord(word{[3,4,5]}) <> []) then
                    if nrl = 0 then
                        EnterAllSubwords(index, word{[1..len]}, 1/3);
                    else
                        # Print("? nrl", nrl, "\n");
                    fi;
                fi;
                # We have entered, so backtrack
                len := len - 1;
            else
                if (len = 6) then
                    len := len - 1;
                else
                    len := len + 1;
                    cand[len] := ShallowCopy(imm[c]);
                fi;
            fi;
        else
            len := len - 1;
        fi;
    od;
    return index;
end);

# This should become an operation
InstallMethod(Blob, "for a pregroup presentation, an element, an element, and an element"
              , [ IsPregroupPresentation
                , IsElementOfPregroup
                , IsElementOfPregroup
                , IsElementOfPregroup ],
function(pres, a, b, c)
    local it, v, n;

    n := Size(Pregroup(pres));
    it := ShortRedBlobIndex(pres);
    v := it[ [__ID(a), __ID(b), __ID(c)] ];

    if v <> fail then
        return v;
    fi;
    return 5/14;
end);

# TODO: Use a map
InstallGlobalFunction(VertexFor,
function(vg, trip)
    return vg!.backmap[ [ __ID(trip[1]), __ID(trip[2]), trip[3] ] ];
end);

# Compute a list of
#  - places reachable from loc1 on Relator(loc1), and
#  - the corresponding location on Relator(loc2)
# by a consolidated edge between Relator(loc1) and Relator(loc2)
InstallGlobalFunction(ConsolidatedEdgePlaces,
function(loc1, loc2)
    local res, length, r1_loc, r2_loc, r1_length;

    res := [];
    length := 0;

    r1_loc := loc1;
    r2_loc := loc2;
    r1_length := Length(Relator(loc1));

    if OutLetter(r1_loc) <> PregroupInverse(InLetter(r2_loc)) then
        Error("This shouldn't happen");
#        return [];
    fi;

    repeat
        r1_loc := NextLocation(r1_loc);
        r2_loc := PrevLocation(r2_loc);
        length := length + 1;
        Append(res, List(Places(r1_loc), x -> [x, r2_loc, length]));
    until (OutLetter(r1_loc) <> PregroupInverse(InLetter(r2_loc)))
          or (length = r1_length);

    # Meh.
    if (length = r1_length) or
       (length = Length(Relator(loc2))) then
        return [];
    else
        return res;
    fi;
end);

# Helper function to add or update
# a "place quadruple"
AddOrUpdatePQ := function(L, pq)
    local pp;

    pp := PositionProperty(L, x -> x[1] = pq[1] and x[2] = pq[2]);
    if pp = fail then
        Add(L, Immutable(pq));
    else
        if L[pp][4] < pq[4] then
            L[pp] := Immutable(pq);
        fi;
    fi;
end;

# The RSym tester
# The epsilon is chosen by the user
InstallMethod(RSymTestOp, "for a pregroup presentation, and a rational",
              [IsPregroupPresentation, IsRat],
function(pres, eps)
    local i, j, rel, R, pplaces,
          places, Ps, P, Q, Pq,
          osrp, # a one-step reachable place
          osrpp,
          L,
          zeta,
          xi, psip, pp;
    # Make sure epsilon is a float
    # FIXME: To experiment and find out about rounding errors
    #        we try running this thing with rationals
    eps := Rat(eps);
    # FIXME: CAREFUL, if the zeta value is wrong, the RSymTester
    #        does not work correctly
    zeta := Minimum(Int(6 * (1 + eps) + 1) - 1,
                    LengthLongestRelator(pres));
    Info(InfoWalrus, 10
         , "RSymTest start");
    Info(InfoWalrus, 10
         , "zeta: ", zeta);

    # Precompute some things so it doesn't show up in weird places
    # in the profiling data
    # Some of this we might want to compute on demand?
    VertexGraphDistances(pres);
    pplaces := Places(pres);
    if not IsEmpty(pplaces) then
        OneStepReachablePlaces(pplaces[1]);
    fi;

    for rel in Relators(pres) do
        Info(InfoWalrus, 20
             , "relator: ", ViewString(rel), "\n");
        places := Places(rel);
        for Ps in places do
            Info(InfoWalrus, 20
                 , "  start place: "
                 , ViewString(Ps)
                 , "\n" );
            L := [ [__ID(Ps), 0, 0, 0] ]; # This list is called L in the paper
            # This is the list of possible decompositions
            # The meaning of the components of the quadruples q is
            # - q[1] is a place
            # - q[2] is the distance of q[1] from Ps
            # - q[3] is the number of steps that q[1] is from Ps
            # - q[4] is a curvature value
            for i in [1..zeta] do
                Info(InfoWalrus, 30
                     , STRINGIFY("L = ", ViewString(L)), ", i = ", i);
                for Pq in L do      # Pq is for "PlaceQuadruple", which is
                                    # a silly name
                    Info(InfoWalrus, 30,
                         STRINGIFY("Considering: ", Pq));
                    if Pq[3] = i - 1 then  # Reachable in i - 1 steps
                        osrpp := OneStepReachablePlaces(pplaces[Pq[1]]);
                        for osrp in Keys(osrpp) do
                            Info(InfoWalrus, 30,
                                 STRINGIFY("OneStepReachable: ", osrp));
                            if Pq[2] + osrp[2] <= Length(rel) then
                                psip := Pq[4]
                                        + osrp[2] * (1 + eps) / Length(rel)
                                        # storing positive values -> subtract here
                                        - osrpp[osrp];
                                Info(InfoWalrus, 30
                                     , STRINGIFY("psi' = "
                                                , Pq[4], " + "
                                                , osrp[2] * (1+eps) / Length(rel), " - "
                                                , osrpp[osrp], " = "
                                                , psip, "\n")
                                    );
                                if psip < 0 then
                                elif (Pq[4] > 0) and
                                     (osrp[1] = __ID(Ps)) and
                                     (Pq[2] + osrp[2] = Length(rel)) then
                                    # Add the place that caused the failure
                                    Add( L, Immutable( [ osrp[1], Pq[2] + osrp[2], i, psip ] ) );
                                    return [fail, L, Pq];
                                else
                                    AddOrUpdatePQ(L, [osrp[1], Pq[2] + osrp[2], i, psip]);
                                fi;
                            fi;
                        od;
                    fi;
                od;
            od;
        od;
    od;
    return true;
end);

InstallGlobalFunction(RSymTest,
function(args...)
    local pg, pgp, rgreen, inv;

    if Length(args) >= 2 then
        if IsPregroupPresentation(args[1]) then
            return RSymTestOp(args[1], args[2]);
        fi;
        if IsFreeGroup(args[1]) then
            pgp := PregroupPresentationFromFp(args[1], args[2], args[3]);
            return RSymTestOp(pgp, args[4]);
        fi;
    else
        # TODO: Usage message
    fi;
end);

InstallMethod(IsHyperbolic, "for a free group, a list, a list, and a rational number",
              [IsFreeGroup, IsObject, IsObject, IsRat],
              {freeg, rrel, grel, eps} -> RSymTest(freeg, rrel, grel, eps));

InstallMethod(IsHyperbolic, "for a pregroup presentation, and a rational number",
              [IsPregroupPresentation, IsRat],
              {pres, eps} -> RSymTest(pres,eps));


# Copyright (c) 2018-2021, Carnegie Mellon University
# See LICENSE for details

# Don't forget to Import(platforms.cellSPU)

_svctSizes := (N, p, v) -> Filtered([1..N], i->ForAll(Factors(i), j->j<=p) and IsInt(i/v^2));
_defaultSizes := (func, default) -> ((arg) -> When(Length(arg) = 1, func(When(IsList(arg[1]), arg[1], [arg[1]])), func(default)));

Class(altivecOpts, rec(
            4x32f := rec(
                dft_sc := rec(
                    small := rec(verify:=true, interleavedComplex := false, stdTTensor := false, globalUnrolling:=10000),
                    medium := rec(tsplRader:=false, tsplBluestein:=false, tsplPFA:=false, oddSizes:=false, interleavedComplex := false),
                ),
                dft_ic := rec(
                    small := rec(verify:=true, interleavedComplex := true, stdTTensor := false, globalUnrolling:=10000),
                    medium := rec(tsplRader:=false, tsplBluestein:=false, tsplPFA:=false, oddSizes:=false, interleavedComplex := true),
                )
            )
));

benchAltiVec := function()
    if LocalConfig.cpuinfo.SIMD().hasAltiVec then
        return rec(
            4x32f := rec(
                1d := rec(
                    dft_sc := rec(
                        small := _defaultSizes(s->doSimdDft(s, altivec_4x32f, altivecOpts.4x32f.dft_sc.small), [ 2..64 ]),
                        medium := _defaultSizes(s->doSimdDft(s, altivec_4x32f, altivecOpts.4x32f.dft_sc.medium), _svctSizes(1024, 16, 4)),
#                        medium := spiral.libgen.doParSimdDft(altivec_4x32f, 1, _svctSizes(1024, 16, 4), false, true, false, false),
#                        large := spiral.libgen.doParSimdDft(altivec_4x32f, 1, List([4..20], i->2^i), false, true, false, false)

                    ),
                    dft_ic := rec(
                        small := _defaultSizes(s->doSimdDft(s, altivec_4x32f, altivecOpts.4x32f.dft_ic.small), [ 2..64 ]),
                        medium := _defaultSizes(s->doSimdDft(s, altivec_4x32f, altivecOpts.4x32f.dft_ic.medium), _svctSizes(1024, 16, 4))
#                        medium := spiral.libgen.doParSimdDft(altivec_4x32f, 1, _svctSizes(1024, 16, 4), false, true, false, true),
#                        large := spiral.libgen.doParSimdDft(altivec_4x32f, 1, List([4..20], i->2^i), false, true, false, true)
                    ),
                    rdft := _defaultSizes(s->doSimdSymDFT(TRDFT, s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dht  := _defaultSizes(s->doSimdSymDFT(TDHT,  s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dct2 := _defaultSizes(s->doSimdSymDFT(TDCT2, s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dct3 := _defaultSizes(s->doSimdSymDFT(TDCT3, s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dct4 := _defaultSizes(s->doSimdSymDFT(TDCT4, s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dst2 := _defaultSizes(s->doSimdSymDFT(TDST2, s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dst3 := _defaultSizes(s->doSimdSymDFT(TDST3, s, altivec_4x32f, rec(verify :=true)), 32*[1..12]),
                    dst4 := _defaultSizes(s->doSimdSymDFT(TDST4, s, altivec_4x32f, rec(verify :=true)), 32*[1..12])
                ),

                2d := rec(
                    dft_ic := rec(
                        medium := _defaultSizes(s->doSimdMddft(s, altivec_4x32f, rec(interleavedComplex := true,
                                    oddSizes := false, svct := true, splitL := false, pushTag := true, flipIxA := false, stdTTensor := true, tsplPFA := false)),
                                    16*List([1..5], i->[i,i])),
                        small := _defaultSizes(s->doSimdMddft(s, altivec_4x32f, rec(verify:=true, interleavedComplex := true, globalUnrolling:=10000,
                                    tsplPFA := false, pushTag:= false, oddSizes := true, svct := true, splitL := false)),
                                    List([2..16], i->[i,i]))
                    ),
                    dft_sc := rec(
                        medium := _defaultSizes(s->doSimdMddft(s, altivec_4x32f, rec(interleavedComplex := false,
                                    oddSizes := false, svct := true, splitL := false, pushTag := true, flipIxA := false, stdTTensor := true, tsplPFA := false)),
                                    16*List([1..5], i->[i,i])),
                        small := _defaultSizes(s->doSimdMddft(s, altivec_4x32f, rec(verify:=true, interleavedComplex := false, globalUnrolling:=10000,
                                    tsplPFA := false, pushTag:= false, oddSizes := true, svct := true, splitL := false)),
                                    List([2..16], i->[i,i]))
                    ),
                    dct2 := _defaultSizes(s->doSimdSymMDDFT(DCT2, s, altivec_4x32f, rec(verify := true)), [4, 8, 12, 16]),
                    dct3 := _defaultSizes(s->doSimdSymMDDFT(DCT3, s, altivec_4x32f, rec(verify := true)), [4, 8, 12, 16]),
                    dct4 := _defaultSizes(s->doSimdSymMDDFT(DCT4, s, altivec_4x32f, rec(verify := true)), [4, 8, 12, 16]),
                    dst2 := _defaultSizes(s->doSimdSymMDDFT(DST2, s, altivec_4x32f, rec(verify := true)), [4, 8, 12, 16]),
                    dst3 := _defaultSizes(s->doSimdSymMDDFT(DST3, s, altivec_4x32f, rec(verify := true)), [4, 8, 12, 16]),
                    dst4 := _defaultSizes(s->doSimdSymMDDFT(DST4, s, altivec_4x32f, rec(verify := true)), [4, 8, 12, 16])
                )
            ),
        );
    else
        return false;
    fi;
end;


# Copyright (c) 2018-2021, Carnegie Mellon University
# See LICENSE for details

Import(rewrite);

VectorStrategySum := [
    MergedRuleSet(JoinDirectSums,StretchRaderMid),
    MergedRuleSet(StandardSumsRules, RulesPropagate),
    # when to terminate Grp() has become an issue: too early -> diags go the wrong way; too late->Rader stretch breaks
	RulesSMP,
    MergedRuleSet(StandardSumsRules, RulesPropagate, StretchRaderMid, JoinDirectSums, RulesTermGrp),
    MergedRuleSet(StandardSumsRules, RulesPropagate, StretchRaderMid, JoinDirectSums, RulesTermGrp, RulesVDiag),
    MergedRuleSet(StandardSumsRules, RulesPropagate, StretchRaderMid, JoinDirectSums, RulesTermGrp, RulesSMP, RulesVec),
    RulesKickout
];

VectorStrategyTerm := [
#    MergedRuleSet(RulesConjTerm, RulesFuncSimp),
    MergedRuleSet(StretchRaderMid, JoinDirectSums),
    RulesTerm, RulesTermGrp, RulesKickout,
];

VectorStrategyTerm2 := [
#    RulesConjTerm,
    TerminateDirectSums, TerminateRaderMid, TerminateDirectSums, TerminateSymSPL, TerminateDPrm,
];

VectorStrategyVDiag := [
    RulesVDiag, RulesVec, RulesSMP, RulesPropagate,
    StandardSumsRules
#   MergedRuleSet(RulesVDiag, StandardSumsRules)
];

VectorStrategyRC := [
    MergedRuleSet(RulesSMP, RulesSplitComplex),
    RulesKickout,
    RulesVBlkInt,
    RulesVDiag,
    MergedRuleSet(RulesPropagate, RulesSMP, RulesSplitComplex, RulesVRC, RulesSums),
    MergedRuleSet(RulesPropagate, RulesVRC, RulesCxRC, RulesVRCTerm, RulesSMP, RulesVec, TerminateSymSPL, RulesRC, RulesSplitComplex),
    RulesTerm,
    RulesTermGrp,
    RulesSMP,
    RulesVec,
    RulesPropagate,
    StandardSumsRules,
    RulesKickout
];

VectorStrategyRCUnterm := [
    MergedRuleSet(RulesVRC, RulesCxRC, RulesRC),
    MergedRuleSet(RulesSMP, RulesVec, RulesCxRC, RulesPropagate)
];

# VectorStrategy := [
#     MergedRuleSet(StandardSumsRules)
#     MergedRuleSet(RulesVec, RulesPropagate, RulesDiag),
#     RulesVDiag,
#     MergedRuleSet(RulesVec, RulesPropagate),
#     MergedRuleSet(StandardSumsRules)
#     MergedRuleSet(RulesVRC, RulesCxRC, RulesRC), RulesVec,
#     RulesKickout,
#     MergedRuleSet(StandardSumsRules)
# ];

VectorStrategyRCRec := [
    MergedRuleSet(RulesVRC, RulesCxRC, RulesRC),     RulesKickout,
    MergedRuleSet(RulesSMP, RulesVec, RulesPropagate),
    StandardSumsRules
];

fix_fAdd := [
    MergedRuleSet(StandardSumsRules, Rules_fAdd),
];


#
# crypting: Hashes and Crypto in GAP
#
# Implementations
#

BindGlobal("CRYPTING_SHA256_State_Family",
           NewFamily("CRYPTING_SHA256_State_Family"));

BindGlobal("CRYPTING_SHA256_State_Type",
           NewType(CRYPTING_SHA256_State_Family,
                   IsSHA256State) );

InstallGlobalFunction( CRYPTING_HexStringIntPad,
function(i, len, pad)
    local result;

    result := HexStringInt(i);
    if Length(result) < len then
        result := Concatenation(RepeatedString(pad,len - Length(result)), result);
    fi;
    return result;
end);

InstallGlobalFunction( CRYPTING_HexStringIntPad8,
    i -> CRYPTING_HexStringIntPad(i, 8, '0'));

InstallMethod( ViewString, "for a SHA256 state",
               [ IsSHA256State ], x -> "<sha256 state>");

InstallGlobalFunction( SHA256String,
function(str)
    local s;

    if not IsString(str) then
        ErrorNoReturn("usage: str has to be a string");
    fi;

    str := CopyToStringRep(str);
    s := CRYPTING_SHA256_INIT();
    CRYPTING_SHA256_UPDATE(s, str);
    return CRYPTING_SHA256_FINAL(s);
end);

InstallGlobalFunction( HMACSHA256,
function(key, str)
    if not IsString(key) then
        ErrorNoReturn("usage: key has to be a string");
    fi;
    if not IsString(str) then
        ErrorNoReturn("usage: str has to be a string");
    fi;
    key := CopyToStringRep(str);
    str := CopyToStringRep(str);
    return CRYPTING_SHA256_HMAC(key, str);
end);


# Copyright (c) 2018-2021, Carnegie Mellon University
# See LICENSE for details

#Class(RulesConj, RuleSet);
RewriteRules(RulesVDiag, rec(
#    conj_LR_L := ARule(Compose, [@(1,ConjLR), @(2,ConjL)],
#                    e -> let(c1:=@(1).val.children(), c2:=@(2).val.children(),
#                    [ ConjL(c1[1] * Prm(fCompose(c1[3], c2[2])) * c2[1], c1[2]) ])),
#
#    conj_LR_LR := ARule(Compose, [@(1,ConjLR), @(2,ConjLR)],
#                    e -> let(c1:=@(1).val.children(), c2:=@(2).val.children(),
#                    [ ConjLR(c1[1] * Prm(fCompose(c1[3], c2[2])) * c2[1], c1[2], c2[3]) ])),
#
#    conj_R_LR := ARule(Compose, [@(1,ConjR), @(2,ConjLR)],
#                    e -> let(c1:=@(1).val.children(), c2:=@(2).val.children(),
#                    [ ConjR(c1[1] * Prm(fCompose(c1[2], c2[2])) * c2[1], c2[3]) ])),

    #--------------------------------------------------
    # handle RCDiag

    VGath_Conj_RCDiag := ARule(Compose, [@(1,VGath), [@(2,ConjDiag), @(3,RCDiag), @(4), @(5) ]],
       e -> let(f:=@(1).val.func, d:=@(3).val.element, v:=@(1).val.v, prm:=@(4).val,
                [ VRCDiag(VData(fCompose(d, prm, fTensor(f, fId(v))), v), v),@(1).val ] )),

    Conj_RCDiag_VScat := ARule(Compose, [[@(1,ConjDiag), @(2,RCDiag), @(3), @(4) ], @(5,VScat)],
       e -> let(f:=@(5).val.func, d:=@(2).val.element, v:=@(5).val.v, prm:=@(3).val,
                [ @(5).val, VRCDiag(VData(fCompose(d, prm, fTensor(f, fId(v))), v), v) ] )),

    VTensor_Conj_RCDiag := ARule(Compose, [@(1,VTensor), [@(2,ConjDiag), @(3,RCDiag), @(4, L, e->e.params[2] = e.params[1]/@(1).val.vlen), @(5, L,e->e.params[2] = @(1).val.vlen) ]],
        e -> let(d:=@(3).val.element, v:=@(1).val.vlen, prm:=@(4).val,
                [ @(1).val, VRCDiag(VData(fCompose(d, prm), v), v) ] )),

    PullInRightConjDiag := ARule( Compose,
        [ @(1, ConjDiag),
            @(2, [RecursStep, Grp, BB, SUM, Buf, ISum, Data, COND]) ],
        e -> [ CopyFields(@(2).val, rec(
                _children :=  List(@(2).val._children, c -> @(1).val * c),
                dimensions := [Rows(@(1).val), Cols(@(2).val)] )) ]),

    PullInLeftConjDiag := ARule( Compose,
        [ @(1, [RecursStep, Grp, BB, SUM, SUMAcc, Buf, ISum, ISumAcc, Data, COND]),
            @(2, ConjDiag) ],
        e -> [ CopyFields(@(1).val, rec(
                _children := List(@(1).val._children, c -> c * @(2).val),
                dimensions := [Rows(@(1).val), Cols(@(2).val)] )) ])
));

#_leftPerm := (m,n,v) -> Compose(VTensor(Tensor(I(m/(2*v)),L(n, v)), v), Tensor(I(m*n/(2*v^2)), VL(v^2, v)), VTensor(L(m*n/(2*v), m/v), v)).sums();
#_rightPerm := (m,n,v) -> VTensor(Tensor(I(n/2), L(m/v,m/(2*v))), v).sums();
#
#Class(RulesConjTerm, RuleSet);
#RewriteRules(RulesConjTerm, rec(
#    ConjR_VRC_Diag := ARule(Compose, [ [ConjR, @(1), @(2,L)], [@(3,VRC), @(4,Diag) ] ],
#                    e -> let(l := @(2).val, mn_by_2:=l.params[1], m:=l.params[2], n:=2*mn_by_2/m, v:=@(3).val.v,
#                        [ @(1).val * _leftPerm(m,n,v) * VRCL(@(3).val.child(1), v) ])),
#
#    VRCL_VRC := ARule(Compose, [ @(1, VRCL), @(2, VRC) ],
#                    e -> let(v:=@(1).val.v, [ VRCLR(@(1).val.child(1), v), VRCL(@(2).val.child(1), v) ])),
#
#    VRCL_L_ConjL := ARule(Compose, [ [ @(1,VRCL), [Prm, @(5), @(2,L), @(6)] ], [ ConjL, @(3),
#                        @(4,L, e->let(m2:=e.params[2], n2:=@(2).val.params[2], m2*n2 = @(2).val.params[1])) ] ],
#                    e -> let(lbar := @(2).val, n:= 2*lbar.params[2], m:=2*@(4).val.params[2], v:=@(1).val.v,
#                            [ _rightPerm(m,n,v) * @(3).val]))
#));


#
# Pregroup of free groups is special (at the moment at least)
#
InstallGlobalFunction(PregroupOfFreeGroup,
function(n)
    local i, r, e, inv, enams;

    #T maybe for n <= 26 just use a,b,c,?
    enams := [1..2*n+1];
    for i in [1..n] do
        enams[2 * i] := Concatenation("x", String(i));
        enams[2 * i + 1] := Concatenation("X", String(i));
    od;

    inv := function(x)
        if x = 1 then
            return 1;
        elif IsEvenInt(x) then
            return x + 1;
        else
            return x - 1;
        fi;
    end;

    r := rec( rank := n );

    r.fam := NewFamily( "PregroupElementsFamily", IsElementOfPregroup );
    r.elt_t := NewType( r!.fam, IsElementOfPregroupOfFreeGroupRep );
    r.elts := List( [ 1 .. (2*n + 1) ], i -> Objectify(r.elt_t, rec(parent := r, elt := i)));
    r.invs := [];
    for e in [1..Length(r.elts)] do
        r.elts[e]!.inv := r.elts[inv(e)];
    od;
    Objectify(PregroupOfFreeGroupType, r);
    SetPregroupElementNames(r, enams);
    return r;
end);

InstallMethod(ViewString
             , "for a pregroup of a free group"
             , [IsPregroupOfFreeGroupRep],
             function(pg)
                 return STRINGIFY("<pregroup of free group of rank ", pg!.rank, ">");
             end);

InstallMethod(Size
             , "for a pregroup of a free group"
             , [IsPregroupOfFreeGroupRep],
             pg -> 2 * pg!.rank + 1);

InstallMethod(\[\]
             , "for a pregroup of a free group"
             , [IsPregroupOfFreeGroupRep, IsInt],
             function(f,a)
                 return f!.elts[a];
             end);

InstallMethod(Iterator
             , "for a pregroup of a free group"
             , [IsPregroupOfFreeGroupRep],
             function(pgp)
                 local r;

                 r := rec( pgp := pgp
                         , pos := 0
                         , length := Size(pgp)
                         , NextIterator := function(iter)
                             if iter!.pos < iter!.length then
                                 iter!.pos := iter!.pos + 1;
                                 return iter!.pgp[iter!.pos];
                             else
                                 return fail;
                             fi;
                         end
                         , IsDoneIterator := iter -> iter!.pos = iter!.length
                         , ShallowCopy := iter -> rec( pgp := iter!.pgp, pos := iter!.pos )
                         );

                 return IteratorByFunctions(r);
             end);

InstallMethod(PregroupElementNames
             , "for a pregroup"
             , [IsPregroupOfFreeGroupRep]
             , p -> p!.elementnames );

InstallMethod(SetPregroupElementNames
             , "for a pregroup"
             , [IsPregroupOfFreeGroupRep, IsList]
             , function(p, n)
                 p!.elementnames := n;
             end );

InstallMethod(IntermultPairs
             , "for a pregroup in table rep"
             , [IsPregroupOfFreeGroupRep],
             pg -> []);

InstallMethod(IntermultPairsIDs
             , "for a pregroup in table rep"
             , [IsPregroupOfFreeGroupRep],
             pg -> []);

InstallMethod(IntermultMapIDs
             , "for a pregroup in table rep"
             , [IsPregroupOfFreeGroupRep],
             pg -> ListWithIdenticalEntries(Size(pg), []));

InstallMethod(IntermultMap
             , "for a pregroup in table rep"
             , [IsPregroupOfFreeGroupRep],
             pg -> ListWithIdenticalEntries(Size(pg), []));

InstallMethod(One, "for a pregroup",
              [IsPregroupOfFreeGroupRep],
              pg -> pg!.elts[1]);

#
# PregroupOfFreeGroup elements
#
InstallMethod(IntermultMap
             , "for a pregroup element"
             , [IsElementOfPregroupOfFreeGroupRep],
             pge -> []);

InstallMethod(ViewString
             , "for a pregroup element"
             , [IsElementOfPregroupOfFreeGroupRep],
function(pge)
    if pge!.elt > 0 then
        return PregroupElementNames(pge!.parent)[pge!.elt];
    else
        return "undefined";
    fi;
end);

InstallMethod(String
             , "for a pregroup element"
             , [IsElementOfPregroupOfFreeGroupRep],
function(pge)
    if pge!.elt > 0 then
        return PregroupElementNames(pge!.parent)[pge!.elt];
    else
        return "undefined";
    fi;
end);

#XXX Is fail as a result for multiplication acceptable?
InstallMethod(\*
             , "for pregroup elements"
             , IsIdenticalObj
             , [IsElementOfPregroupOfFreeGroupRep, IsElementOfPregroupOfFreeGroupRep]
             , 0,
function(x,y)
    if x!.elt = 1 then
        return y;
    elif y!.elt = 1 then
        return x;
    elif x!.inv = y then
        return One(PregroupOf(x));
    else
        return fail;
    fi;
end);

InstallMethod(\=
             , "for pregroup elements"
             , IsIdenticalObj
             , [IsElementOfPregroupOfFreeGroupRep, IsElementOfPregroupOfFreeGroupRep]
             , 0,
function(x,y)
    return x!.elt = y!.elt;
end);

# Artificial ordering on pregroup to make sets work
InstallMethod(\<
             , "for pregroup elements"
             , IsIdenticalObj
             , [ IsElementOfPregroupOfFreeGroupRep, IsElementOfPregroupOfFreeGroupRep]
             , 0,
function(x,y)
    return x!.elt < y!.elt;
end);

InstallMethod(PregroupOf
             , "for pregroup elements"
             , [ IsElementOfPregroupOfFreeGroupRep ]
             , 0,
function(a)
    return a!.parent;
end);

InstallMethod(PregroupInverse
             , "for pregroup elements"
             , [ IsElementOfPregroupOfFreeGroupRep ]
             , 0,
             a -> a!.inv);

InstallMethod(PregroupElementId
             , "for pregroup elements"
             , [ IsElementOfPregroupOfFreeGroupRep ]
             , 0,
             a -> a!.elt);

InstallMethod(__ID
             , "for pregroup elements"
             , [ IsElementOfPregroupOfFreeGroupRep ]
             , 0,
             x -> x!.elt);

InstallMethod(IsDefinedMultiplication
             , "for pregroup elements"
             , IsIdenticalObj
             , [ IsElementOfPregroupOfFreeGroupRep, IsElementOfPregroupOfFreeGroupRep ]
             , 0,
function(a,b)
    return (a!.elt = 1) or (b!.elt = 1) or (a!.inv = b);
end);

# We could cache intermult pairs,
# or predetermine them, depending
# on the number of intermult lookups
# that could benefit runtime
InstallMethod(IsIntermultPair
             , "for pregroup elements"
             , IsIdenticalObj
             , [IsElementOfPregroupOfFreeGroupRep, IsElementOfPregroupOfFreeGroupRep]
             , 0,
function(a,b)
    return false;
end);


#
# walrus: Computational Methods for Finitely Generated Monoids and Groups
#
#### Utility functions

# Pregroup presentation for triangle group
InstallGlobalFunction(pg_word,
                      {pg, l} -> List(l, x->pg[x]) );

InstallGlobalFunction(Repeat,
                      {n, l} -> ShallowCopy(Flat(ListWithIdenticalEntries(n,l))));

# MaxPowerK: Input a word (relator) v over X, output w such that w^k = v, k
# maximal with this property InstallGlobalFunction(MaxPowerK,
InstallGlobalFunction(MaxPowerK,
function(rel)
    local len, d, divs, isrep,
          checkrep;

    len := Length(rel);
    divs := ShallowCopy(DivisorsInt(len));
    Remove(divs, 1);

    checkrep := function(d)
        local j,k;
        for j in [1..d] do
            for k in [1..(len / d) - 1] do
                if rel[j] <> rel[j + k*d] then
                    return false;
                fi;
            od;
        od;
        return true;
    end;

    for d in divs do
        if checkrep(d) then
            return [ rel{[1..d]}, len / d ];
        fi;
    od;

    return [ rel, 1 ];
end);

InstallGlobalFunction(WalrusTestStandard,
function()
    List(DirectoriesPackageLibrary("walrus", "tst/standard"), TestDirectory);
end);


#
# walrus: Computational Methods for Finitely Generated Monoids and Groups
#

## Presentations
InstallGlobalFunction(NewPregroupPresentation,
function(pg, rels)
    local res;

    res := rec( pg := pg );
    res.rels := List([1..Length(rels)], x -> NewPregroupRelator(res, rels[x], x));
    # Orgh. Make sure Locations and Places are all computed for the moment
    Objectify(PregroupPresentationType, res);
    Locations(res);
    Places(res);
    SetVertexTripleCache(res, HashMap());

    return res;
end);

InstallGlobalFunction(PregroupPresentationFromFp,
function(F, rred, rgreen)
    local inv, pg, rgreens, inv_test;

    inv_test := function(x)
        local lr;
        if Length(x) = 2 then
            lr := LetterRepAssocWord(x);
            return lr[1] = lr[2];
        fi;
        return false;
    end;

    # Get the involutions
    inv := Filtered(rgreen, inv_test);
    rgreens := Filtered(rgreen, x -> not inv_test(x));
    pg := PregroupByRedRelators(F, rred, List(inv, x -> LetterRepAssocWord(x)[1]));

    rgreens := List(rgreens, pg!.convert_word);

    return NewPregroupPresentation(pg, rgreens);
end);

InstallMethod(ViewString
             , "for a pregroup presentation"
             , [IsPregroupPresentationRep],
function(pgp)
    # Note that we do not really regard 1 as a generator
    local res;

    return STRINGIFY("<pregroup presentation with "
                    , Size(pgp!.pg)-1, " generators and "
                    , Length(pgp!.rels), " relators>");
end);

InstallMethod(Pregroup
             , "for a pregroup presentation"
             , [IsPregroupPresentation],
             pgp -> pgp!.pg);

InstallMethod(Generators
             , "for a pregroup presentation"
             , [IsPregroupPresentation],
function(pres)
    local gens;

    gens := List(Pregroup(pres), x->x);
    Remove(gens, 1);
    return gens;
end);

InstallMethod(Relators
             , "for a pregroup presentation"
             , [IsPregroupPresentation],
             pgp -> pgp!.rels);

InstallMethod(RelatorsAndInverses
             , "for a pregroup presentation"
             , [IsPregroupPresentation],
function(pgp)
    local r;
    r := Relators(pgp);
    return Concatenation(r, List(r, Inverse));
end);

InstallMethod(Powers
             , "for a pregroup presentation"
             , [IsPregroupPresentation],
             x -> x!.powers);

InstallMethod(RLetters
             , "for a pregroup presentation"
             , [IsPregroupPresentation],
function(pres)
    local rels, gens, x, r, rlett;

    rels := RelatorsAndInverses(pres);
    gens := Generators(pres);
    rlett := Set([]);
    for r in rels do
        for x in gens do
            if x in r then AddSet(rlett, x); fi;
        od;
    od;
    return rlett;
end);

# An R-letter is a letter that occurs in any (interleave) of
# a relation (Definition 7.4)
# XXX: Note that the code below does not do interleaves yet!
InstallGlobalFunction(IsRLetter,
function(pres, x)
    # determine whether x occurs in I(R)
    return x in RLetters(pres);
end);

InstallMethod(Locations, "for a pregroup presentation",
              [IsPregroupPresentation and IsPregroupPresentationRep],
function(pres)
    local rel, locs, w, i, index;

    locs := [];

    for rel in RelatorsAndInverses(pres) do
        Append(locs, Locations(rel));
    od;

    # Hack
    # In particular this ID is ID within presentation
    index := HashMap(x -> HashBasic([__ID(x[1]), __ID(x[2])]));
    for i in [1..Length(locs)] do
        locs[i]![6] := i;

        if IsBound( index[ [ InLetter(locs[i]), OutLetter(locs[i]) ] ] ) then
            Add( index[ [ InLetter(locs[i]), OutLetter(locs[i]) ] ], locs[i] );
        else
            index[ [ InLetter(locs[i]), OutLetter(locs[i]) ] ] := [ locs[i] ];
        fi;
    od;
    SetLocationIndex(pres, index);
    return locs;
end);

# For a location R(i,a,b) find a matching location
# R'(j,b^(-1),c) such that a reduced diagram only
# containing R and R' exists
FindMatchingLocation := function(loc, c)
    local locs, b, binv, loc2;

    b := OutLetter(loc);
    binv := PregroupInverse(b);
    locs := LocationIndex(PregroupPresentationOf(loc));
    locs := locs[ [binv, c] ];

    if locs <> fail then
        for loc2 in locs do
            if CheckReducedDiagram(loc, loc2) then
                return loc2;
            fi;
        od;
    fi;
    return fail;
end;

# Given a pregroup presentation as the input, find all places
# B is true if a place will always occur on the boundary
InstallMethod(Places, "for a pregroup presentation",
              [IsPregroupPresentation and IsPregroupPresentationRep],
function(pres)
    local loc, loc2,
          places, a, b, c,
          rels,
          locs, i;

    # rels := RelatorsAndInverses(pres);
    rels := Relators(pres);
    locs := Locations(pres);
    places := [];

    for loc in locs do
        a := InLetter(loc);
        b := OutLetter(loc);
        for c in Generators(pres) do
            # Colour is "red"
            if IsIntermultPair(PregroupInverse(b), c) then
                Add(places, NewPlace(loc, c, "red"));
            fi;
            # Colour is "green"
            # find location R'(j,b^(-1),c) and check that a diagram that
            # meets at the edge b doesn't collapse.

            if FindMatchingLocation(loc, c) <> fail then
                Add(places, NewPlace(loc, c, "green"));
            fi;
        od;
    od;
    # Hack
    for i in [1..Length(places)] do
        places[i]![5] := i;
    od;
    return places;
end);

InstallMethod(LengthLongestRelator, "for a pregroup presentation",
              [IsPregroupPresentation and IsPregroupPresentationRep],
function(pres)
    return Maximum(List(Relators(pres), Length));
end);

# Definition 3.3: A diagram is semi-reduced, if no distinct adjacent faces
# are labelled by ww_1 and w_1^{-1}w for a relator ww_1 and have a common
# consolidated edge labelled by w and w^-1
# it is reduced if this also holds for a face incident with itself.
#
# test whether label on Relator(l2) beginning at b^(-1) is equal to inverse
# of label on Relator(l1) ending at b
InstallGlobalFunction(CheckReducedDiagram,
function(l1, l2)
    local i, j, r1, r2, iend, jend;

    r1 := Relator(l1);
    i := Position(l1);
    iend := i + 1;
    if iend > Length(r1) then iend := iend - Length(r1); fi;

    r2 := Relator(l2);
    j := Position(l2) - 1;
    jend := j - 1;
    if jend < 0 then jend := jend + Length(r2); fi;

    # Here inverses should match, or otherwise the passed
    # locations are already incompatible
    if r1[i] <> PregroupInverse(r2[j]) then
        Error("loc1 and loc2 are not compatible");
        return fail;
    fi;

    repeat
        i := i - 1;
        if i = 0 then i := Length(r1); fi;
        j := j + 1;
        if j > Length(r2) then j := 1; fi;

#        # Print("r1[", i, "] = ", r1[i], " r2[", j, "] = ", r2[j], "\n");
        if r1[i] <> PregroupInverse(r2[j]) then
            return true;
        fi;
    until (i = iend) or (j = jend);

    return false;
end);

InstallGlobalFunction(PregroupPresentationToFpGroup,
function(pres)
    local d, F, rels, gens, pg, p, i, j;

    # By Definition 2.2 of the paper
    d := Size(Pregroup(pres)) - 1;
    F := FreeGroup(d);
    pg := Pregroup(pres);

    rels := [];
    # rels := List([1..d], x -> [ F.(x) * F.(pg!.inv(x+1)-1), One(F) ]);
    for i in [2..d+1] do
        for j in [2..d+1] do
            p := pg[i] * pg[j];
            if p <> fail then
                if p = One(pg) then
                    Add(rels, [F.(i-1) * F.(j-1), One(F)]);
                else
                    Add(rels, [F.(i-1) * F.(j-1) * F.(__ID(PregroupInverse(p))-1), One(F)]);
                fi;
            fi;
        od;
    od;
    Append(rels, List(Relators(pres), x -> [Product(List(List(x), y -> F.(__ID(y)-1))), One(F)]));

    return F / rels;
end);

#T Put pregroup relations in (if pregroup is not the pregroup of the free group)
#T Choose sensible generator names and print them (maybe just use x1,x2,... or a,b,c))
if WALRUS_kbmag_available then

InstallGlobalFunction(PregroupPresentationToKBMAG,
    pres -> KBMAGRewritingSystem(PregroupPresentationToFpGroup(pres)));

fi;

# Writes out pregroup as a multiplication table
# and then the relators, intended as a simple exchange
# format
InstallGlobalFunction(PregroupPresentationToSimpleStream,
function(stream, pres)
    local row, col, table, n, i, rel;

    table := MultiplicationTableIDs(Pregroup(pres));
    n := Length(table);
    AppendTo(stream, "pregroup:\n" );

    for row in [1..n] do
        AppendTo(stream, "  ");
        for col in [1..n-1] do
            AppendTo(stream, String(table[row][col]));
            AppendTo(stream, " ");
        od;
        AppendTo(stream, String(table[row][n]));
        AppendTo(stream, "\n");
    od;

    AppendTo(stream, "relators:\n");
    for rel in Relators(pres) do
        AppendTo(stream, "  ");
        for i in [1..Length(rel)-1] do
            AppendTo(stream, String(__ID(rel[i])));
            AppendTo(stream, " ");
        od;
        AppendTo(stream, String(__ID(rel[Length(rel)])));
        AppendTo(stream, "\n");
    od;
end);

# Serialises a pregroup presentation as a GAP record
# that GAP can read back easily
InstallGlobalFunction(PregroupPresentationToStream,
function(stream, pres)
    local res, rel, rels;

    res := rec( table := MultiplicationTableIDs(Pregroup(pres)),
                rels := List(Relators(pres), r -> List(r, x -> __ID(x))));

    PrintTo(stream, res, ";\n");
end);

InstallGlobalFunction(PregroupPresentationFromStream,
function(stream)
    local res, r, pg, rels;
    res := READ_ALL_COMMANDS(stream, false, false, IdFunc);

    if Length(res) = 1
       and res[1][1] = true
       and IsBound(res[1][2])
       and IsRecord(res[1][2]) then
        # FIXME: Store element names, at least don't put arbitarary
        #        restriction o nnumber of pregroup elts here
        r := res[1][2];
        pg := PregroupByTable("1abcdefghijklmnopqrstuvwxyz"{[1..Length(r.table)]}, r.table);
        return NewPregroupPresentation(pg, List(r.rels, x -> pg_word(pg, x)));
    else
        Error("Could not read pregroup presentation from stream");
    fi;
end);

InstallGlobalFunction(PregroupPresentationToFile,
function(filename, pres)
    local outs;

    outs := OutputTextFile(filename, false);
    SetPrintFormattingStatus(outs, false);
    PregroupPresentationToStream(outs, pres);
    CloseStream(outs);
end);

InstallGlobalFunction(PregroupPresentationToSimpleFile,
function(filename, pres)
    local outs;

    outs := OutputTextFile(filename, false);
    SetPrintFormattingStatus(outs, false);
    PregroupPresentationToSimpleStream(outs, pres);
    CloseStream(outs);
end);


#############################################################################
##
#M  GraphicSubgroupLattice(<G>) . . . . displays subgroup lattice graphically
#M  GraphicSubgroupLattice(<G>,<def>)  . . . . . . . . . . same with defaults
##
##  Displays a graphic poset which shows (parts of) the subgroup lattice of
##  the group <group>. Normally only the whole group and the trivial group are
##  shown (behaviour of "InteractiveLattice" in xgap3). Returns a
##  IsGraphicSubgroupLattice object. Calls DecideSubgroupLatticeType. See
##  there for details.
##
InstallMethod(GraphicSubgroupLattice,
    "for a group, and a record",
    true,
    [IsGroup, IsRecord],
    0,
function(G, def)
  local latticeType, graph, poset, cls, vmath, v2, v1, menu, m, knownArgs, cb;

  latticeType := DecideSubgroupLatticeType(G);
  # we do some heuristics to avoid the trivial group:
  # if we know all levels, we probably can calc. Size, if we shall generate
  # a vertex for the trivial subgroup, we should also know Size!
  if latticeType.knowsLevels or latticeType.trivial then
    # no trivial case:
    if Size(G) = 1 then
      return Error( "<G> must be non-trivial" );
    fi;
  fi;

  # create a new canvas
  poset := Canvas("GraphicSubgroupLattice");
  # and make it a GraphicSubgroupLattice
  SetFilterObj(poset, IsGraphicSubgroupLattice);

  poset!.latticeType := latticeType;

  if HasName(G) then
    SetTitle(poset, Concatenation(Title(poset)," of ", Name(G)));
  elif HasIdGroup(G) then
    SetTitle(poset, Concatenation(Title(poset)," of ", String(IdGroup(G))));
  fi;

  if IsBound(def.width) then SetWidth(poset, def.width); fi;
  if IsBound(def.height) then SetHeight(poset, def.height); fi;
  if IsBound(def.title) then SetTitle(poset, def.title); fi;

  # now the other filters, depending on type:
  if latticeType.knowsLevels then SetFilterObj(poset, KnowsAllLevels); fi;
  if latticeType.hasse then SetFilterObj(poset, HasseProperty); fi;
  if latticeType.canCompare then SetFilterObj(poset, CanCompareSubgroups); fi;

  if KnowsAllLevels(poset) then
    # we know how many levels so we can show the user
    Add(poset, FrancyMessage(Concatenation("There are ",
      String(Length(DivisorsInt(Size(G)))), " levels in this Group.")));
  else
    # we don't know how many levels so we try to compute them
    if latticeType.trivial then
      if CanComputeSize(G) and Size(G) <> infinity then
        Add(poset, FrancyMessage(Concatenation("There are ", String(Size(G)), " levels in this Group.")));
      else
        Add(poset, FrancyMessage("We don't know how many levels there are on this group."));
      fi;
    else
      # we really don't know
      Add(poset, FrancyMessage("We don't know how many levels there are on this group."));
    fi;
  fi;

  # create an undirected graph to represent the poset
  # by adding layers later, the undirected graph turns
  # into an Hasse diagram
  graph := Graph(GraphType.DIRECTED);
  Add(poset, graph);

  cls:=ConjugacyClassesSubgroups(G);

  # create one or two initial vertices (G itself and trivial subgroup):
  v2 := Shape(ShapeType.DIAMOND, "G");
  SetLayer(v2, -4);
  for m in latticeType.contextMenus do
    knownArgs := [poset, Representative(cls[Length(cls)])];
    if m.group = true then
      Add(knownArgs, G);
    fi;
    cb := Callback(m.func, knownArgs);
    Add(v2, Menu(m.name, cb));
  od;
  Add(graph, v2);

  if latticeType.trivial then
    v1 := Shape(ShapeType.DIAMOND, "1");
    SetLayer(v1, 0);
    for m in latticeType.contextMenus do
      knownArgs := [poset, Representative(cls[1])];
      if m.group = true then
        Add(knownArgs, G);
      fi;
      cb := Callback(m.func, knownArgs);
      Add(v1, Menu(m.name, cb));
    od;
    Add(graph, v1);

    # connect the two vertices
    Add(graph, Link(v1, v2));
  fi;

  # <G> is selected at first
  v2!.selected := true;

  # create menus:
  menu := Menu("Subgroup Lattice");
  for m in latticeType.menus do
    knownArgs := [poset];
    if m.group = true then
      Add(knownArgs, G);
    fi;
    cb := Callback(m.func, knownArgs);
    Add(menu, Menu(m.name, cb));
  od;
  Add(poset, menu);

  return Draw(poset);
end);

##
## without defaults record:
##
InstallOtherMethod(GraphicSubgroupLattice,
    "for a group",
    true,
    [IsGroup],
    0,
function(G)
  return GraphicSubgroupLattice(G, rec());
end);

#############################################################################
##
##  Decision function for subgroup lattice type:
##
#############################################################################

#############################################################################
##
#M  DecideSubgroupLatticeType(<grp>)  . . decides about the type of a lattice
##
##  This operation is called while creation of a new graphic subgroup lattice.
##  It has to decide about the type of the lattice. That means it has to
##  decide 5 questions:
##   1) Are all levels known right from the beginning?
##   2) Has the lattice the HasseProperty?
##   3) Can we test two subgroups for equality reasonably cheaply?
##   4) Shall we create a vertex for the trivial subgroup at the beginning?
##   5) What menu operations are possible?
##   6) What information is displayed on RightClick?
##  Returns a record. The first four entries are boolean values for  questions
##  1-4. Note that if the answer to 2 is true, then the answer to 3 must also
##  be true. The fifth and sixth entry are configuration lists as explained
##  in the configuration section of "ilatgrp.gi" for menu operations and
##  info displays respectively.
##
##  The following is the default "fallback" method suitable for reasonably
##  small finite groups.
##
InstallMethod(DecideSubgroupLatticeType,
    "for a group",
    true,
    [IsGroup],
    0,
function(G)
  local knowslevels, menus;
  menus:=[];
  Append(menus, MenuOpsForFiniteGroups);
  Append(menus, MenuOpsCommon);
  if Size(G) > 10^17 then # that is just heuristic!
    knowslevels := false;
  else
    knowslevels := Length(DivisorsInt(Size(G))) < 50;
  fi;
  return rec(
    knowsLevels  := knowslevels,
    hasse        := true, # we assume HasseProperty
    canCompare   := true, # we assume we can compare groups
    trivial      := true, # we want the trivial subgroup
    menus        := menus,
    contextMenus := ContextMenusForFiniteGroups,
  );
end);

## for finitely presented groups:
InstallMethod(DecideSubgroupLatticeType,
    "for a group",
    true,
    [IsGroup and IsFpGroup],
    0,

function(G)
  local menus;
  menus:=[];
  Append(menus, MenuOpsForFpGroups);
  Append(menus, MenuOpsCommon);
  return rec(
    knowsLevels  := false, # we create levels dynamically
    hasse        := false, # we assume HasseProperty
    canCompare   := false, # we assume we can compare groups
    trivial      := false, # we want the trivial subgroup
    menus        := menus,
    contextMenus := ContextMenusForFpGroups,
  );
end);


#############################################################################
##
#W    pcpgrp3.gi                                                Karel Dekimpe
#W                                                               Bettina Eick
##
##    This file contains the 3-dimensional almost crystallographic groups
##    as pcp groups. There are 17 types groups.
##

ACPcpGroupDim3Nr01 := function (k1)
local FTL;
  FTL := FromTheLeftCollector( 3 );
  SetConjugate( FTL, 2, 1, [2,1,  3,k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr02 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [2,0,  3,0,  4,k4] );
  SetConjugate( FTL, 2, 1, [2,-1,  3,0,  4,k2] );
  SetConjugate( FTL, 3, 1, [2,0,  3,-1,  4,k3] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr03 := function (k1, k2)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [2,0,  3,0,  4,0] );
  SetConjugate( FTL, 2, 1, [2,1,  3,0,  4,-k2] );
  SetConjugate( FTL, 3, 1, [2,0,  3,-1,  4,0] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,-1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr04 := function (k1, k2)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [2,1,  3,0,  4,k2] );
  SetConjugate( FTL, 2, 1, [2,1,  3,0,  4,2*k2] );
  SetConjugate( FTL, 3, 1, [2,0,  3,-1,  4,-k1] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,-1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,2*k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr05 := function (k1, k2)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [2,0,  3,0,  4,0] );
  SetConjugate( FTL, 2, 1, [2,0,  3,1,  4,-k2] );
  SetConjugate( FTL, 3, 1, [2,1,  3,0,  4,-k2] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,-1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr06 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 1 ,  3,0,  4,0,  5,-k4] );
  SetConjugate( FTL, 3, 1, [3,1,  4,0,  5,-k2] );
  SetConjugate( FTL, 4, 1, [3,0,  4,-1,  5,0] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 2 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,-1,  4,0,  5,k2] );
  SetConjugate( FTL, 4, 2, [3,0,  4,-1,  5,k3] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr07 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 1 ,  3,0,  4,-1,  5,-2*k3 - k4] );
  SetConjugate( FTL, 3, 1, [3,1,  4,0,  5,k1 - k2] );
  SetConjugate( FTL, 4, 1, [3,0,  4,-1,  5,0] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 2 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k3] );
  SetConjugate( FTL, 3, 2, [3,-1,  4,0,  5,k2] );
  SetConjugate( FTL, 4, 2, [3,0,  4,-1,  5,-2*(k3 + k4)] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,2*k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr08 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,1,  4,0,  5,-k3] );
  SetConjugate( FTL, 2, 1, [2, 1 ,  3,1,  4,-1,  5,-2*k1 + k2 - 2*k3 - k4] );
  SetConjugate( FTL, 3, 1, [3,1,  4,0,  5,-2*k3] );
  SetConjugate( FTL, 4, 1, [3,0,  4,-1,  5,-k1] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 2 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,-1,  4,0,  5,k1 + 2*k3] );
  SetConjugate( FTL, 4, 2, [3,0,  4,-1,  5,-k1 + 2*k2 - 2*k3] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,2*k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr09 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 1 ,  3,0,  4,0,  5,-k4] );
  SetConjugate( FTL, 3, 1, [3,0,  4,1,  5,-k3] );
  SetConjugate( FTL, 4, 1, [3,1,  4,0,  5,-k3] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 2 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,-1,  4,0,  5,k2] );
  SetConjugate( FTL, 4, 2, [3,0,  4,-1,  5,-k2 + 2*k3] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr10 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 4 );
  SetPower( FTL, 1, [2,0,  3,0,  4,k4] );
  SetConjugate( FTL, 2, 1, [2,0,  3,-1,  4,k3] );
  SetConjugate( FTL, 3, 1, [2,1,  3,0,  4,-k2] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr11 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 3 ,  3,0,  4,0,  5,-k4] );
  SetConjugate( FTL, 3, 1, [3,1,  4,0,  5,-k2 - k3] );
  SetConjugate( FTL, 4, 1, [3,0,  4,-1,  5,0] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 4 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,0,  4,-1,  5,k3] );
  SetConjugate( FTL, 4, 2, [3,1,  4,0,  5,-k2] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr12 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,1,  4,0,  5,k3] );
  SetConjugate( FTL, 2, 1, [2, 3 ,  3,0,  4,-1,  5,-k2 - k3 - k4] );
  SetConjugate( FTL, 3, 1, [3,1,  4,0,  5,2*k3] );
  SetConjugate( FTL, 4, 1, [3,0,  4,-1,  5,-k1] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 4 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,0,  4,-1,  5,k1 - k2 - 2*k3] );
  SetConjugate( FTL, 4, 2, [3,1,  4,0,  5,-k2] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,2*k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr13 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 3 );
  SetPower( FTL, 1, [2,0,  3,0,  4,k4] );
  SetConjugate( FTL, 2, 1, [2,-1,  3,-1,  4,k2 + k3] );
  SetConjugate( FTL, 3, 1, [2,1,  3,0,  4,-k2] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr14 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 2 ,  3,0,  4,0,  5,-k4] );
  SetConjugate( FTL, 3, 1, [3,0,  4,-1,  5,-k2] );
  SetConjugate( FTL, 4, 1, [3,-1,  4,0,  5,k2] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 3 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,-1,  4,-1,  5,k2 + k3] );
  SetConjugate( FTL, 4, 2, [3,1,  4,0,  5,-k2] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr15 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 2 ,  3,0,  4,0,  5,-k4] );
  SetConjugate( FTL, 3, 1, [3,0,  4,1,  5,-k2] );
  SetConjugate( FTL, 4, 1, [3,1,  4,0,  5,-k2] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 3 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,-1,  4,-1,  5,k1 + 3*k2 - k3] );
  SetConjugate( FTL, 4, 2, [3,1,  4,0,  5,-k1 - 3*k2 + 2*k3] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,k1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr16 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 4 );
  SetRelativeOrder( FTL, 1, 6 );
  SetPower( FTL, 1, [2,0,  3,0,  4,k4] );
  SetConjugate( FTL, 2, 1, [2,0,  3,-1,  4,k3] );
  SetConjugate( FTL, 3, 1, [2,1,  3,1,  4,k1 - k2 - k3] );
  SetConjugate( FTL, 4, 1, [2,0,  3,0,  4,1] );
  SetConjugate( FTL, 3, 2, [3,1,  4,k1] );
  SetConjugate( FTL, 4, 2, [3,0,  4,1] );
  SetConjugate( FTL, 4, 3, [4,1] );
return PcpGroupByCollector(FTL);
end;

ACPcpGroupDim3Nr17 := function (k1, k2, k3 , k4)
local FTL;
  FTL := FromTheLeftCollector( 5 );
  SetRelativeOrder( FTL, 1, 2 );
  SetPower( FTL, 1, [3,0,  4,0,  5,0] );
  SetConjugate( FTL, 2, 1, [2, 5 ,  3,0,  4,0,  5,-k4] );
  SetConjugate( FTL, 3, 1, [3,0,  4,1,  5,-k3] );
  SetConjugate( FTL, 4, 1, [3,1,  4,0,  5,-k3] );
  SetConjugate( FTL, 5, 1, [3,0,  4,0,  5,-1] );
  SetRelativeOrder( FTL, 2, 6 );
  SetPower( FTL, 2, [3,0,  4,0,  5,k4] );
  SetConjugate( FTL, 3, 2, [3,0,  4,-1,  5,k3] );
  SetConjugate( FTL, 4, 2, [3,1,  4,1,  5,k1 - k2 - k3] );
  SetConjugate( FTL, 5, 2, [3,0,  4,0,  5,1] );
  SetConjugate( FTL, 4, 3, [4,1,  5,k1] );
return PcpGroupByCollector(FTL);
end;

#############################################################################
##
## some small helpers
##
ACPcpDim3Funcs := [ ACPcpGroupDim3Nr01, ACPcpGroupDim3Nr02,
ACPcpGroupDim3Nr03,
ACPcpGroupDim3Nr04, ACPcpGroupDim3Nr05, ACPcpGroupDim3Nr06,
ACPcpGroupDim3Nr07, ACPcpGroupDim3Nr08, ACPcpGroupDim3Nr09,
ACPcpGroupDim3Nr10, ACPcpGroupDim3Nr11, ACPcpGroupDim3Nr12,
ACPcpGroupDim3Nr13, ACPcpGroupDim3Nr14, ACPcpGroupDim3Nr15,
ACPcpGroupDim3Nr16, ACPcpGroupDim3Nr17 ];
MakeReadOnlyGlobal( "ACPcpDim3Funcs" );


# Copyright (c) 2018-2020, Carnegie Mellon University
# See LICENSE for details
#
# qEmbed Object, qJunc Object
# All objects and helpers needed to embed a logical transform onto a physical mesh
#

##
#F qJunc( <qubit_order>, <n>, <dir>) Object
##
#F Given architecture ordering qubit_order and number of qubits n
#F reorder logical qubit vector to achieve the relative ordering
#F dir = 1 is a forward reordering, dir = -1 is a backward reordering
Class(qJunc, TaggedNonTerminal, rec(
  abbrevs   := [ (l, n, dir) -> Checked(IsPosInt(n) , [l, n, dir])],
  dims      := self >> let(size := 2^self.params[2], [size, size]),
  terminate := self >> (JuncTerm(self.params[1], self.params[2], self.params[3])),
  isReal    := self >> false,
  rChildren := self >> self.params,
  from_rChildren := (self, rch) >> self.__bases__[1](rch[1], rch[2], rch[3]),
  SmallRandom := () -> Random([2..5]),
  LargeRandom := () -> Random([6..15]),
  normalizedArithCost := self >> Error("ArithCost not implemented"),
  TType := T_Complex(64)
));

##
#F GrowGroup( <arch>, <groups>, <bad> )
##
#F given an architecture and a list of qubit groupings, grow each grouping by 1,
#F not using any qubits in the bad set. Used as a helper function to grab
#F all sections of n connected qubits
##
GrowGroup := function(arch, groups, bad)
    local newgroups, g, q, es, newqs, newlocalgroups, n, group;
    newgroups := [];
    for g in groups do
        # for each group
        for q in g do
            #for each qubit in each group
            #get a list of edges
            es := GetEdges(arch, q);
            newqs := ListDifference(es, g);
            #newqs is the list of new qubits we can add to this group
            newqs := ListDifference(newqs, bad);
            # dont use any bad qubits
            newlocalgroups := Map(newqs, i -> Concatenation(g, [i]));
            Append(newgroups, newlocalgroups);
        od;
    od;
    return newgroups;
end;

##
#F FindAllSectionsOfn( <arch>, <n>, <bad> )
##
#F given an architecture and a set of off-limits qubits,
#F finds all possible size-n connected components in the architecture
#F using none of the bad qubits
FindAllSectionsOfn := function(arch, n, bad)
    local l, qub, groups, count, g;
    l := [];
    qub := 0;
    groups := [0..(Length(arch)-1)];
    groups := ListDifference(groups, bad);
    groups := Map(groups, i -> [i]);
    count := 1;
    while count < n do
        groups := GrowGroup(arch, groups, bad);
        count := count + 1;
    od;
    return groups;
end;

##
#F GenAllPartitions(<arch>, <S>)
##
#F given a list of different partitions sizes, for example S = [[3,3], [3,2]]
#F returns a list of all possible partitionings
#F for example S = [[3,3], [3,2]] will yield a list of 2 sublists,
#F the first sublist contains all possible ways of getting two connected components of 3
#F the second sublist contains all possible ways of getting a connected component of size 3 and size 2
GenAllPartitions := function (arch, S)
    local parts, groupings, s, sects, r, fact, groups, ss, result, g, idx, newgroups, bad, k;
    parts := S.groups();
    groupings := [];
    for s in parts do
        # now s is a list that contains all the needed connected subsets for the transform
        # a.k.a [3, 3]
        sects := FindAllSectionsOfn(arch, s[1], []);
        idx := 2;
        result := Map(sects, i ->[i]);
        while idx <= Length(s) do
            newgroups := [];
            # need to add a group of size g to every list in list groups
            for r in result do
                # add a size g grouping to this list
                # r is [ [1,2,3], ... ]
                bad := Flat(r);
                # don't use anything already used
                sects := FindAllSectionsOfn(arch, s[idx], bad);
                for k in sects do
                    Add(newgroups, Concatenation(r, [k]));
                od;
            od;
            result := newgroups;
            idx := idx + 1;
        od;
        #finished preparing all possible groups to satisfy the current partition
        Append(groupings, result);
    od;
    return groupings;
end;

##
#F PruneArch(<arch>, <in_use>)
##
#F take all rows and columns out of the arch adjmatrix that are not in in_use
#F and reorder rows and columns so that in_use[1] is qubit 0, in_use[2] is qubit 1, etc...
#F to achieve our recursive reordering
PruneArch := function(arch, in_use)
    local idcs, idx, j, row, newarch, u, r, newrow;
    idcs := [0..(Length(in_use)-1)];
    idx := 1;
    newarch := [];
    for u in in_use do
        row := arch[u+1]; # keep only the rows we need
        newrow := [];
        j := [1..Length(in_use)];
        j := Map(j, i -> in_use[i]);
        for r in j do
            # need to add columns back in order of in_use, and only those columns
            Add(newrow, row[r+1]);
        od;
        Add(newarch, newrow); # add rows back in the order listed
    od;
    return newarch;
end;

##
#F ReordIdx(<t>, <o>, <n>)
##
#F Helper to create all possible reorderings of the qubits, where o is the original ordering, and where
#F the qubits in list t are positioned at the upper indices of the new orderings
ReordIdx := function (t, o, n)
    local idcs, orderings, children, idx, e, diff, r, avail_idcs, reorderings, temp_orderings, tmp, child, a;
    idcs := [0..n-1];
    orderings := [];
    children := [];
    for i in idcs do # initialize
        idcs[i+1] := -1;
    od;
    idx := 1;
    for e in o do
        idcs[t[idx]+1] := o[idx];
        idx := idx + 1;
    od;
    # now need to generate all possible orderings of the rest of the qubits
    diff := ListDifference([0..n-1], o);
    avail_idcs := ListDifference([0..n-1], t);
    temp_orderings := Arrangements(diff, Length(diff));
    for tmp in temp_orderings do
        # fill in the remaining slots
        idx := 1;
        child := [];
        for e  in idcs do
            Add(child, e);
        od;
        for a in avail_idcs do
            child[a+1] := tmp[idx];
            idx := idx + 1;
        od;
        Add(orderings, child);
    od;
    return orderings;
end;

##
#F GenChild(<l>, <n>, <arch>, <S>)
##
#F Given a list of of affected qubits (l), the number of qubits in the system (n)
#F the architecture (arch) and the non-terminal to apply (S)
#F generate all possible embeddings
GenChild := function (l, n, arch, S)
    local children, possible_qubits, r, reorderings, possible, newarch, factor, mats, basequbit, forswapmat, backswapmat, subset, original_qubits, target_qubits, forjunction, backjunction, child, children;
    children := [];
    possible_qubits := GenAllPartitions(arch, S);
    # possible qubits is a list of all possible ways we can factor S into arch
    # so possible qubits, if need groups of 3 and 2 = [  [[0,1], [2,3,4]] , [[2,3], [7,8,9]], ... ]
    # for each of these factorizations, need to generate appropriate child
    # a proper child will be:
    # * SWAP proper qubits to get into the right position (canonical order)
    # * generate the proper Junction
    # * apply the transform
    # * reapply the proper Junction
    # * unSWAP the proper qubits to preserve ordering
    for factor in possible_qubits do
        # example factor = [[0, 1], [2,3,4]]
        original_qubits := [0..(Length(Flat(factor)) - 1)];
        original_qubits := Map(original_qubits, i -> l[i+1]);
        target_qubits := Flat(factor);
        reorderings := ReordIdx(target_qubits, original_qubits, n);
        # have swap matrices
        forjunction := qJunc(Flat(factor), n, 1);
        backjunction := qJunc(Flat(factor), n, -1);
        # have junctions
        # To prune arch, need to 1) eliminate all rows an columns of qubits not being used, i.e. in Flat(factor)
        # then need to rename the qubits to be 0,1,2,3,4, etc... canonical ordering with Flat(factor)
        newarch := PruneArch(arch, Flat(factor));
        for r in reorderings do
            child := (Reord(r, arch, 1) * forjunction * Tensor(S.recursive_def(newarch), I(2^(n-Length(l)))) * backjunction * Reord(r, arch, -1));
            if( VerifyPath(r, [0..n-1], arch) = true) then
                Add(children, [child]);
            fi;
        od;
    od;
    return children;
end;

##
#F ExpandTens( <l>, <n>, <S> )
##
## qEmbed terminate function. Generates a 2^n by 2^n matrix
## representing the application of Non-terminal S on the qubits in
## list l. We use canonical ordering
ExpandTens := function (l, n, S)
    local  size, swap1, swap2, trans;
    size := Length(l);
    # Generate swap matrix
    swap1 := PerfSwap([0..size-1], l, n);
    # Generate the reverse swap matrix
    swap2 := PerfSwap(Reversed([0..size-1]), Reversed(l), n);
    trans := Tensor(S(size), I(2^(n-size)));
    return swap1 * trans * swap2;
end;

##
#F qEmbed( <l>, <n>, <arch>, <Obj> ) Object
##
#F Embed the Obj Non-Terminal into the system of n qubits with given architecture arch
#F applied to the qubits in l
#F Represents a (2^n x 2^n)-matrix
Class(qEmbed, TaggedNonTerminal, rec(
  abbrevs   := [ (l, n, arch, nt) -> Checked(IsPosInt(n) , [l, n, arch, nt])],
  dims      := self >> let(size := 2^self.params[2], [size, size]),
  terminate := self >> (ExpandTens(self.params[1], self.params[2], self.params[4])),
  isReal    := self >> false,
  rChildren := self >> self.params,
  from_rChildren := (self, rch) >> self.__bases__[1](rch[1], rch[2], rch[3], rch[4]),
  recursive_def := (self, arch) >> self.__bases__[1](self.params[1], arch, self.params[2], arch, self.params[3]),
  SmallRandom := () -> Random([2..5]),
  LargeRandom := () -> Random([6..15]),
  normalizedArithCost := self >> Error("ArithCost not implemented"),
  TType := T_Complex(64)
));

##
#F PermIdx( <l>, <n> )
##
#F return an ordering of qubits indexed 0 through n-1
#F where the top |l| indices match l
PermIdx := function (l, n)
    local idcs, idx, e, tmp, diff, perms;
    idcs := [0..n-1];
    diff := ListDifference(idcs, l);
    perms := Arrangements(diff, Length(diff));
    idcs := Concatenation(l, perms[1]);
    return idcs;
end;

##
#F IsPerm( <l> )
##
#F verifies if the given ordering is a non-trivial permutation
IsPerm := function (l)
    local idcs;
    idcs := [0..(Length(l)-1)];
    if(l = idcs) then
        return 0;
    fi;
    return 1;
end;

##
#F qJunc Breakdown Rules
##
NewRulesFor(qJunc, rec(

    # Junc_Base rule
    # reduces a qJunc nonterminal to a Junc SPL object
    Junc_Base := rec (
        forTransposition := false,
        minSize          := 2,
        applicable       := (self, nt) >> (IsPerm(nt.params[1]) = 1),
        apply            := (nt, c, cnt) -> Junc( PermIdx(nt.params[1], nt.params[2]) , nt.params[3]),
    ),

    # Junc_ID rule
    # reduces a trivial qJunc nonterminal to an Identity SPL object
    Junc_Id := rec (
        forTransposition := false,
        minSize          := 2,
        applicable       := (self, nt) >> (IsPerm(nt.params[1]) = 0),
        apply            := (nt, c, cnt) -> I(2^(nt.params[2])),
    )

));

##
#F qEmbed Breakdown Rules
##
NewRulesFor(qEmbed, rec(

    # Embed_TryAll rule
    # Try every grouping possible placement on the given qubit architecture layout
    Embed_TryAll := rec (
        forTransposition := false,
        minSize          := 1,
        applicable       := (self, nt) >> (nt.params[3] <> [] and nt.params[1] <> [] and nt.params[2] >= 1),
        children         := nt -> List( GenChild(nt.params[1], nt.params[2], nt.params[3], nt.params[4]) ),
        apply            := (nt, c, cnt) -> c[1],
    )

));


# Copyright (c) 2018-2021, Carnegie Mellon University
# See LICENSE for details

Class(RulesRC, RuleSet);

RCExpandData := function(datavar)
   local rdatavar, r, i;
   Constraint(IsBound(datavar.value));
   rdatavar := Dat1d(TDouble, datavar.t.size*2);
   r := x->When(IsValue(x), ReComplex(Complex(x.v)), re(x));
   i := x->When(IsValue(x), ImComplex(Complex(x.v)), im(x));
   rdatavar.value := V(ConcatList(datavar.value.v, x->[r(x), i(x)]));
   return rdatavar;
end;

RewriteRules(RulesRC, rec(
 RC_Diag := Rule([RC, @(1,Diag)], e -> RCDiag(RCData(@(1).val.element))),

 RC_Compose := Rule([RC, @(1, Compose)], e -> Compose(List(@(1).val.children(), RC))),
 RC_SUM := Rule([RC, @(1, SUM)], e -> SUM(List(@(1).val.children(), RC))),
 RC_SUMAcc := Rule([RC, @(1, SUMAcc)], e -> SUMAcc(List(@(1).val.children(), RC))),

 RC_Container := Rule([RC, @(1, [BB,Buf,Inplace,Grp,NoPull,NoPullLeft,NoPullRight, NoDiagPullin, NoDiagPullinLeft, NoDiagPullinRight ])], e -> ObjId(@(1).val)(RC(@(1).val.child(1)))),

 RC_RStep := Rule([RC, @(1, RecursStep)], e -> RecursStep(2*@(1).val.yofs, 2*@(1).val.xofs,
                                                      RC(@(1).val.child(1)))),

 RC_Data := Rule([RC, @(1, Data)], e -> Data(@(1).val.var, @(1).val.value,
                                        RC(@(1).val.child(1))).attrs(@(1).val)),

 RC_ISum := Rule([RC, @(1, ISum)], e -> ISum(@(1).val.var, @(1).val.domain, RC(@(1).val.child(1)))),

 RC_ICompose := Rule([RC, @(1, ICompose)], e -> ICompose(@(1).val.var, @(1).val.domain, RC(@(1).val.child(1)))),

 RC_Gath := Rule([RC, @(1, Gath)], e -> Gath(fTensor(@(1).val.func, fId(2)))),
 RC_Scat := Rule([RC, @(1, [Scat, ScatAcc])], e -> ObjId(@(1).val)(fTensor(@(1).val.func, fId(2)))),
 RC_Prm := Rule([RC, @(1, Prm)], e -> Prm(fTensor(@(1).val.func, fId(2)))),

 RC_RowColVec := Rule([RC, @(1, [RowVec, ColVec], e->not IsSymbolic(e.element.domain()))],
     e -> RC(@(1).val.toDiagBlk())),

# RC_ScatGath := Rule([RC, @(1, ScatGath)], e -> ScatGath(fTensor(@(1).val.sfunc, fId(2)), fTensor(@(1).val.gfunc, fId(2)))),

 RC_O := Rule([RC, @(1, O)], e -> O(2*@(1).val.params[1], 2*@(1).val.params[2])),

 # yes, this does happen
 RC_RCDiag := Rule([RC, @(1, RCDiag)], e -> let(
     func := @(1).val.element,
     D := Dat1d(func.range(), func.domain()),
     j := Ind(func.domain()/2),
     re := nth(D, 2*j),
     im := nth(D, 2*j+1),
     Data(D, func,  # use Data, to preserve fPrecompute that might be present in <func>
          IterDirectSum(j, RC( Blk([[re, -im], [im, re]]) )).sums()))),

 # NB: add a rule for barring real diagonals with replication:
 #    RCData(FData(..real..) o f) -> FData o (f x proj(2))
 RCData_fCompose_FData := Rule([RCData, [fCompose, @(1,FData), @(2)]],
     e -> fCompose(FData(RCExpandData(@(1).val.var)), fTensor(@(2).val, fId(2)))),

 RCData_FData := Rule([RCData, @(1, FData, x -> IsBound(x.var.value) or x.var.t.t=TReal or ObjId(x.var.t.t)=T_Real)],
     e -> let(t := @(1).val.var.t.t,
	 Cond(t = TReal or ObjId(t) = T_Real,
	     diagTensor(FData(@(1).val.var), fConst(t, 2, t.one())),
	     FData(RCExpandData(@(1).val.var))))),

 # NOTE: works for real constants only
 RCData_fConst := Rule([RCData, [@(1,fConst), 1, @(2)]],
     e -> FList(TReal, [ReComplex(Complex(@(2).val)), ImComplex(Complex(@(2).val))])),

 RCData_fPrecompute := Rule([RCData, [fPrecompute, @(1)]], e -> fPrecompute(RCData(@(1).val))),

# YSV: Feb07, lets see what happens without this rule!
# #  RCData_fCompose := Rule([RCData, @(1, fCompose)],
# #      e -> let(ch := @(1).val.children(),
# #        fCompose(RCData(ch[1]), fTensor(fCompose(Drop(ch, 1)), fId(2))))),

 RCData_diagDirsum := Rule([RCData, @(1,diagDirsum)],
      e -> ApplyFunc(diagDirsum, List(@(1).val.children(), RCData))),

# RCData_fCompose_FDataOfs := Rule([RCData, [FDataOfs, @(1), @(2), @(3)]],
#     e -> FDataOfs(RCExpandData(@(1).val), 2 * @(2).val, 2 * @(3).val)),

 RC_Blk := Rule([RC, @(1, Blk)], e -> Blk(RealMatComplexMat(@(1).val.element))),
 RC_Blk1 := Rule([RC, @(1, Blk1)], e -> Blk(RealMatComplexMat([[@(1).val.element]]))),

 RC_Scale := Rule([RC, @(1, Scale)], e ->
     RC(Diag(fConst(Rows(@(1).val), @(1).val.scalar))) * RC(@(1).val.child(1))),

 RC_I := Rule([RC, @(1, I)], e -> I(2*Cols(@1.val))),

 RC_OLMultiplication := Rule([RC, @(1, OLMultiplication)],
     e -> let( p := @(1).val.rChildren(), RCOLMultiplication(p[1], p[2]))),
 RC_OLConjMultiplication := Rule([RC, @(1, OLConjMultiplication)],
     e -> let( p := @(1).val.rChildren(), RCOLConjMultiplication(p[1], p[2]))),

));


#############################################################################
##
#W  tree.gi                 automgrp package                   Yevgen Muntyan
#W                                                             Dmytro Savchuk
##
#Y  Copyright (C) 2003 - 2018 Yevgen Muntyan, Dmytro Savchuk
##

#############################################################################
##
#M  TopDegreeOfTree (<obj>)
##
InstallMethod(TopDegreeOfTree, "for [IsActingOnTree]", [IsActingOnTree],
function(obj)
  local si;
  si := SphericalIndex(obj);
  if not IsEmpty(si.start) then
    return si.start[1];
  else
    return si.period[1];
  fi;
end);

#############################################################################
##
#M  DegreeOfLevel (<obj>)
##
InstallMethod(DegreeOfLevel, "for [IsActingOnTree, IsPosInt]",
              [IsActingOnTree, IsPosInt],
function(obj, k)
  return AG_DegreeOfLevelInSphericalIndex(SphericalIndex(obj), k);
end);

#############################################################################
##
#M  IsActingOnRegularTree(<obj>)
##
InstallMethod(IsActingOnRegularTree, "for [IsActingOnTree]",
              [IsActingOnTree],
function(obj)
  local si;
  si := SphericalIndex(obj);
  return IsEmpty(si.start) and Length(si.period) = 1;
end);

#############################################################################
##
#M  DegreeOfTree(<obj>)
##
InstallMethod(DegreeOfTree, "for [IsActingOnTree]",
              [IsActingOnTree],
function(obj)
  if not IsActingOnRegularTree(obj) then Error("The object ",obj," is not acting on a regular tree"); fi;
  return SphericalIndex(obj).period[1];
end);

#############################################################################
##
#M  IsActingOnBinaryTree(<obj>)
##
InstallMethod(IsActingOnBinaryTree, "for [IsActingOnTree]",
              [IsActingOnTree],
function(obj)
  return IsActingOnRegularTree(obj) and DegreeOfTree(obj) = 2;
end);

#############################################################################
##
#M  FixesLevel (<obj>, <k>)
##
##  The most stupid method - just for case.
##
InstallMethod(FixesLevel, "for [IsActingOnTree, IsPosInt]",
              [IsActingOnTree, IsPosInt],
function(obj, k)
  local lev, v;

  if HasIsSphericallyTransitive(obj) then
    if IsSphericallyTransitive(obj) then
      return false;
    fi;
  fi;

  lev := Tuples([1..DegreeOfTree(obj)], k);
  for v in lev do
    if not FixesVertex(obj, v) then
      return false;
    else
      Info(InfoAutomGrp, 3, "IsSphericallyTransitive(obj): false");
      Info(InfoAutomGrp, 3, "  obj fixes vertex", v);
      Info(InfoAutomGrp, 3, "  obj = ", obj);
      SetIsSphericallyTransitive(obj, false);
    fi;
  od;

  return true;
end);

#E


#
# francy: Interactive Discrete Mathematics in GAP
#

#############################################################################
##
#M  Chart( <chart type> ) .
##
InstallMethod(Chart,
  "a chart type, chart defaults",
  true,
  [IsChartType,
   IsChartDefaults],
  0,
function(chartType, options)
  return MergeObjects(Objectify(ChartObjectType, rec(
    id   := GenerateID(),
    data := rec(),
    axis := DefaultAxis(chartType),
    type := chartType!.value,
  )), options);
end);

InstallOtherMethod(Chart,
  "a Chart type",
  true,
  [IsChartType],
  0,
function(chartType)
  return Chart(chartType, ChartDefaults);
end);

#############################################################################
##
#M  DefaultAxis( <chart type> ) .
##
InstallMethod(DefaultAxis,
  "a chart type",
  true,
  [IsChartType],
  0,
function(chartType)
  local axis;
  axis := rec();
  # default is linear
  axis.x := XAxis(AxisScaleType.LINEAR, "", []);
  axis.y := YAxis(AxisScaleType.LINEAR, "", []);
  if chartType!.value = ChartType.BAR!.value then
    axis.x := XAxis(AxisScaleType.BAND, "", []);
  fi;
  return axis;
end);

#############################################################################
##
#M  Add( <chart>, <francy object> ) . . . . . add objects to canvas
##
InstallOtherMethod(Add,
  "a Chart, a dataset",
  true,
  [IsChart,
   IsDataset],
  0,
function(chart, object)
  chart!.data!.(object!.title) := object!.data;
  return chart;
end);

InstallOtherMethod(Add,
  "a Chart, a list of francy objects",
  true,
  [IsChart,
   IsList],
  0,
function(chart, objects)
  local object;
  for object in objects do
    Add(chart, object);
  od;
  return chart;
end);

#############################################################################
##
#M  Remove( <chart>, <francy object> ) . . . . . remove object from canvas
##
InstallOtherMethod(Remove,
  "a chart, a dataset",
  true,
  [IsChart,
   IsDataset],
  0,
function(chart, object)
  Unbind(chart!.data!.(object!.title));
  return chart;
end);

InstallOtherMethod(Remove,
  "a Chart, a list of francy objects",
  true,
  [IsChart,
   IsList],
  0,
function(chart, objects)
  local object;
  for object in objects do
    Remove(chart, object);
  od;
  return chart;
end);

#############################################################################
##
#M  Dataset( <title>, <list of data> ) . . . . . create a dataset
##
InstallMethod(Dataset,
  "a title, a list of data",
  true,
  [IsString,
   IsList],
  0,
function(title, list)
  return Objectify(DatasetObjectType, rec(
    title := title,
    data  := list
  ));
end);

#############################################################################
##
#M  XAxis( <axis scale type>, <title>, <domain range> )
##
InstallMethod(XAxis,
  "the axis scale type, a title, a list of data",
  true,
  [IsAxisScaleType,
   IsString,
   IsList],
  0,
function(axisScale, title, list)
  return Objectify(XAxisObjectType, rec(
    scale  := axisScale!.value,
    title  := title,
    domain := list
  ));
end);

InstallOtherMethod(XAxis,
  "the axis scale type, a title",
  true,
  [IsAxisScaleType,
   IsString],
  0,
function(axisScale, title)
  return XAxis(axisScale, title, []);
end);

#############################################################################
##
#M  YAxis( <axis scale type>, <title>, <domain range> )
##
InstallMethod(YAxis,
  "the axis scale type, a title, a list of data",
  true,
  [IsAxisScaleType,
   IsString,
   IsList],
  0,
function(axisScale, title, list)
  return Objectify(YAxisObjectType, rec(
    scale  := axisScale!.value,
    title  := title,
    domain := list
  ));
end);

InstallOtherMethod(YAxis,
  "the axis scale type, a title",
  true,
  [IsAxisScaleType,
   IsString],
  0,
function(axisScale, title)
  return YAxis(axisScale, title, []);
end);