library stabcalc;

"This program is designed to calculate stabilizers for iteration 
 of p-group generation in cases where the automorphism group of the 
 starting group is insoluble. The input file for this program is 
 created using the p-group generation algorithm implementation
 within the p-Quotient Program (PQP). The program is handed a matrix 
 group representing the action of the general linear group or the 
 appropriate subgroup thereof on a finite p-group. The action of
 the automorphisms extended to a characteristic subgroup of the 
 p-multiplicator of the group is also represented as a subgroup 
 of the appropriate general linear group. The generators of the 
 stabilizers of each orbit representative are determined as words 
 in the original generators of the automorphism group. This is done 
 by building up images under the action of random words in the defining 
 generators,  where the individual letters in a word are selected on a 
 random basis. When the stabilizer has been determined within the 
 automorphism group, a composition series with cyclic factors is 
 calculated if it is soluble. Appropriate information is written out 
 to create a file for input to PQP" 

"compute the image of the matrix under the action of the automorphism"

procedure matimage (f, p, nsteps, nmrgens, m, rvec; ivec);

ivec = seq (0) of f;

for i = 1 to nsteps do
    entry = (i - 1) * nmrgens;
    for j = 1 to nmrgens do
        add = 0;
        for k = 1 to nmrgens do
            matent = (j - 1) * nmrgens + k;
            add = add +  m[matent] * rvec[entry + k];
        end;
        ivec[entry + j] = add;
    end;
end;
 
for row = 1 to nsteps do

    zero = true;
    col = row - 1;
    
    while  (zero) do 
       col = col + 1;
       for i = row to nsteps do
           entry = (i - 1) * nmrgens + col;
           if  (ivec[entry] ne 0) then 
              zero = false;
              break;
           end;
       end;
    end;             

    if  (i gt row) then 
       for j = col to nmrgens do
           prev = (row - 1) * nmrgens + j;
           entry = (i - 1) * nmrgens + j;
           temp = ivec[entry];
           ivec[entry] = ivec[prev];
           ivec[prev] = temp;
       end;
    end;

    hold =  (row - 1) * nmrgens;
       
    x = ivec[hold + col]^-1;

    for j = col to nmrgens do 
        entry = hold + j;
        ivec[entry] = ivec[entry] * x;
    end;

    for i = 1 to nsteps do 
        if  (i eq row) then loop; end;
        entry = (i - 1) * nmrgens + col;
        y = p - ivec[entry];
        for j = col to nmrgens do 
            entry = (i - 1) * nmrgens + j;
            ivec[entry] = ivec[entry] + ivec[hold + j] * y;
        end;
    end;
end;

end;


procedure labmat (f, p, l, len, holdid, nmrids, nsteps, nmrgens; reps);

idpos = seq (0);
update = seq (0);
reps = seq (0) of f;

for idnmr = 1 to nmrids do
    totlen = p^len[idnmr];
    if  (l le totlen) then break; end;
    l = l - totlen;
end;

if nmrgens ge 10 then mult = 100; else mult = 10; end;
fac = mult^(nsteps - 1);
hold = holdid[idnmr];
for j = 1 to nsteps do
    idpos[j] = hold / fac;
    hold = hold - (hold / fac) * fac;
    fac = fac / mult;
end;

matlen = nmrgens * nsteps;
for i = 1 to matlen do
    reps[i] = 0 of f;
end;

for i = 1 to nsteps do
    x = (i - 1) * nmrgens + idpos[i];
    reps[x] = 1 of f;
end;

nmrent = 0;
idpos[nsteps + 1] = 0;
for i = 1 to nsteps do
    hold = i + 1;
    for j = idpos[i] + 1 to nmrgens do
        if (j ne idpos[hold]) then
           nmrent = nmrent + 1;
           update[nmrent] = i * 100 + j;
        else
          hold = hold + 1;
        end;
    end;
end;

l = l - 1;
fac = totlen / p;
for k = 1 to nmrent do
    entry = l / fac;
    l = l - (l / fac) * fac;
    fac = fac / p;
    if  (entry ne 0) then
       u = update[nmrent + 1 - k];
       rownmr = u / 100;
       colnmr = u - (u / 100) * 100;
       x = (rownmr - 1) * nmrgens + colnmr;
       for e = 1 to entry do
          reps[x] = reps[x] + (1 of f);
       end;
    end;
end;

end;

procedure shift (g, temp, noofgens, hold; hold);

ltemp = noofgens;
lhold = length (hold);
if hold[1] eq id then lhold = 0; end;
for i = lhold + 1 to lhold + ltemp do hold[i] = id of g; end;
for i = 1 to lhold do
hold[ltemp + lhold - i + 1] = hold[lhold - i + 1];
end;
for i = 1 to ltemp do
hold[i] = temp[i];
end;
end; "procedure shift"



"given a soluble group G, this procedure calculates a composition series 
 for the group together with a system of generators of the series which 
 ascend the series in cyclic steps. The system of generators is obtained 
 starting at the top and working down the series"

procedure compseries (g; compgen);

  k = g;

  compgen = seq (identity) of g;
  temp = seq (identity) of g;
  
  noofgens = 0;

  while order (k) ne 1 do
  
     d = derived group (k);
     sqprime = forder (k / d);
     done = false;
     totord = order (k / d);

     "set up the generators of K in a sequence"
 
     genset = generators (k);
     gen = setseq (genset);
     l = length (gen);
       
     m = d;
     nprime = length (sqprime) / 2;

     for i = 1 to nprime  do

        offset = (i - 1) * 2;
        p = sqprime[offset + 1];
        n = sqprime[offset + 2];

        step = p^n;
        done = false;
        reqord = order (m) * step;
        remain = totord / step;

        for j = 1 to l do
           found = false;     
           for q = 0 to n do
              expn = p^q;
              if gen[j]^(remain * expn) in m then found = true; break; end;
           end;
           if not found then loop; end; 
           for r = 0 to q - 1 do
              expn = p^ (q - 1 - r);
              noofgens = noofgens + 1;
              temp[noofgens] = gen[j]^(remain * expn);
              m = <m, temp[noofgens]>;
              if order (m) eq reqord then done = true; end;
           end;
           if  (done) then break; end;
        end;

     end;
     shift (g, temp, noofgens, compgen; compgen);
     noofgens = 0;
  
     k = d;

  end;
end; "compgen"


"verify the cyclic factor group structure of the composition series 
 given in COMPGEN setting error equal to true if any failure"

procedure verify (g, compgen; error);

error = false;

subgp = <compgen[1]> of g;

for i = 2 to length (compgen) do
orig = subgp;
subgp = <subgp, compgen[i]> of g;
facgp = subgp / orig;
if not prime (order (facgp)) then error = true; return; end;
end;

end; "verify"

"now process each orbit rep in turn to obtain its stabilizer"

autg = <identity> of glnp;

for i = 1 to t do autg = <autg, gen[i]>; end;
ordautg = order (autg);

autqg = <identity> of glqp;
for i = 1 to t do autqg = <autqg, genq[i]>; end;

rvec = seq (0) of f;
ivec = rvec;
ord = seq (0);
qgen = seq (seq (0 of f));
for i = 1 to t do qgen[i] = eltseq (genq[i]); end;

h = cyclic (t);
nmrorbits = length (r);

for n = 1 to nmrorbits do

    reqord = ordautg / orblen[n];
    labmat (f, p, r[n], len, holdid, nmrids, nsteps, nmrgens; rvec);
    stab = seq (identity) of glnp;
    done = false;
    stabgp = <identity> of glnp;
    nmrstabs = 0;
    for i = 1 to t do

        if  (genq[i] ne id of autqg ) then
           matimage (f, p, nsteps, nmrgens, qgen[i], rvec; ivec);
        end;

        if  (genq[i] eq id of autqg or ivec eq rvec) then
           stabgen = gen[i]^-1;
           if not (stabgen in stabgp) then                      
              nmrstabs = nmrstabs + 1;
              stab[nmrstabs] = stabgen;
              stabgp = <stabgp, stabgen>;
           end;
           if  (order (stabgp) eq reqord) then
              done = true;
              break;
           end;
        end;
        ord[i] = order (genq[i]);
    end;

    pathlen = 1;
    rangen = seq (0);
    l = 0;
    prevl = 0;
    lastpos = 0;
    lastg = 0;
    nlastg = 0;
    sol = 0;
    orbelts = seq (rvec);
    found = false;
    
    while  (not done) do
       
       while  (not found) do

          x = ranelt (h);
          q = eltseq (x);
          j = q[1];
          if  (j eq lastg) then
             if  (nlastg ne ord[j] - 1) then
                found = true;
                nlastg = nlastg + 1;
             end;
          else
             lastg = j;
             nlastg = 1;
             found = true;
          end;

       end;
      
       found = false;       
       l = l + 1;
       rangen[l] = j;
       matimage (f, p, nsteps, nmrgens, qgen[j], rvec; ivec);

       pos = 0;
       for k = 1 to pathlen do              
          if  (ivec eq orbelts[k]) then
             pos = k;
             break;
          end;
       end;

       if  (pos ne 0) then 
          stabgen = identity of glnp;
          for k = 1 to lastpos do 
              stabgen = stabgen * gen[rangen[k]]^-1;
          end;
          for k = prevl + 1 to l do
              stabgen = stabgen * gen[rangen[k]]^-1;
          end;
          for k = 1 to pos - 1 do
              stabgen = stabgen * gen[rangen[pos - k]];
          end;
          if not (stabgen in stabgp) then
             nmrstabs = nmrstabs + 1;
             stab[nmrstabs] = stabgen;
             stabgp = <stabgp, stab[nmrstabs]>;
             if order (stabgp) eq reqord then done = true; end;
          end;
          lastpos = pos - 1;
          prevl = l;
       end;
       pathlen = pathlen + 1;
       orbelts[pathlen] = ivec;
       rvec = ivec;

    end;   

 "if stabilizer is soluble then calculate composition series"
 
 if soluble (stabgp) then
   sol = -1;
   compseries (stabgp; stab);
   
   "verify accuracy of composition series calculation"
   verify (stabgp, stab; error);
   if error then 
      print '*** error in composition series calculation for orbit rep', 
             n, '***';
      errors = append (errors, stabgp);
   end;
 end;

 nsj = length (stab);
 print sol;
 print nsj;
 for i = 1 to nsj do print stab[i]; end;
 
end; "for n"

finish;
