reduce-historical/r38/packages/assist/perms.red

module perms;

% returns product of two permutations

symbolic procedure pe_mult(p1, p2);
  begin scalar prod;
  integer count;
  prod := mkve(upbve(p1));
  for count := 1:upbve(p1) do
    putve(prod, count, venth(p2, venth(p1, count)));
  return prod;
  end;

% returns inverse of permutation
symbolic procedure pe_inv(pe);
  begin
  scalar inv;
  integer count;
  inv := mkve(upbve(pe));
  for count := 1:upbve(pe) do
    putve(inv, venth(pe, count), count);
  return inv;
  end;

% returns image of elt by permutation pe
symbolic smacro procedure pe_apply(pe, elt);
  venth(pe, elt);


%%% Stabilizer chain routines

%% Access macros

symbolic smacro procedure sc_orbits(sc, k);
  venth(venth(cdr sc, k), 1);

symbolic smacro procedure sc_transversal(sc,k);
  venth(venth(cdr sc, k), 2);

symbolic smacro procedure sc_generators(sc,k);
  venth(venth(cdr sc, k), 3);

symbolic smacro procedure sc_inv_generators(sc,k);
  venth(venth(cdr sc, k),4);

symbolic smacro procedure sc_stabdesc(sc, k);
  venth(cdr sc, k);

symbolic smacro procedure sd_orbrep(sd, elt);
  venth(venth(sd,1),elt);

symbolic smacro procedure sd_orbreps(sd);
  venth(sd,5);

%% Building routines

symbolic procedure copy_vect(v1, v2);
  begin
  integer count, top;
  top := upbv v2;
  for count := 0 : top do
    putv(v1, count, getv(v2, count));
  end;

symbolic procedure sd_addgen(sd, pe, inv);
  begin scalar
    t1, t2, orbits, orbreps, transversal, generators, inv_generators,
    new_elems, next_elem;
       integer
    count, img;

%% initialize local variables
  orbits := venth(sd, 1);
  transversal := venth(sd, 2);

%% add generator and inverse
  generators := vectappend1(venth(sd,3), pe);
  inv_generators := vectappend1(venth(sd,4), inv);

%% Join elements from the orbits.
  for count := 1 : upbve(orbits) do
    <<
    t1 := venth(orbits, count);
    while (t1 neq venth(orbits, t1)) do t1 := venth(orbits, t1);
    t2 := venth(orbits, pe_apply(pe, count));
    while (t2 neq venth(orbits, t2)) do t2 := venth(orbits, t2);
    if (t1 < t2) then
      putve(orbits, t2, t1)
    else
      putve(orbits, t1, t2)
    >>;
  for count := 1 : upbve(orbits) do
    <<
    putve(orbits, count, venth(orbits, venth(orbits, count)));
    if venth(orbits, count) = count then
      orbreps := count . orbreps
    >>;

%% extend transversal
  % add images of elements of basic orbit by pe to new_elems
  for count := 1 : upbve(transversal) do
    <<
    if venth(transversal, count) then
      <<
      img := pe_apply(pe, count);
      if null(venth(transversal, img)) then
        <<
        putve(transversal, img, inv);
        new_elems := img . new_elems
        >>
      >>
    >>;
  % add all possible images of each new_elems to the transversal
  while new_elems do
    <<
    next_elem := car new_elems;
    new_elems := cdr new_elems;
    for count := 1 : upbve(generators) do
      <<
      img := pe_apply(venth(generators, count), next_elem);
      if null(venth(transversal, img)) then
        <<
        putve(transversal, img, venth(inv_generators, count));
        new_elems := img . new_elems;
        >>
      >>
    >>;

%% update sd
  putve(sd, 1, orbits);
  putve(sd, 2, transversal);
  putve(sd, 3, generators);
  putve(sd, 4, inv_generators);
  putve(sd, 5, orbreps);
  return sd;
  end;

symbolic procedure sd_create(n, beta);
  begin
  scalar sd, orbits, transversal;
  integer count;
  sd := mkve(5);
  orbits := mkve(n);
for count := 1:n do
    putve(orbits, count, count);
  transversal := mkve(n);
  putve(transversal, beta, 0);

  putve(sd, 1, orbits);
  putve(sd, 2, transversal);
  putve(sd, 3, mkve(0));
  putve(sd, 4, mkve(0));
  putve(sd, 5, for count := 1:n collect count);
  return sd
  end;

symbolic procedure sc_create(n);
  begin
  scalar base;
  integer count;
  for count := n step -1 until 1 do
    base := count . base;
  return ((list2vect!*(base,'symbolic)) . mkve(n));
  end;

symbolic procedure sd_recomp_transversal(sd, beta);
  begin
  scalar
    new_trans,
    new_elems, next_elem,
    generators, inv_generators,
    img;
  integer count;

  new_trans := mkve(upbve(venth(sd,1)));
  new_elems := beta . nil;
  putve(new_trans, beta, 0);
  generators := venth(sd,3);
  inv_generators := venth(sd,4);

  while new_elems do
    <<
    next_elem := car new_elems;
    new_elems := cdr new_elems;
    for count := 1 : upbve(generators) do
      <<
      img := pe_apply(venth(generators, count), next_elem);
      if null(venth(new_trans, img)) then
        <<
        putve(new_trans, img, venth(inv_generators, count));
        new_elems := img . new_elems;
        >>
      >>
    >>;
  putve(sd, 2, new_trans);
  return sd;
  end;

symbolic procedure sc_swapbase(sc, k);
  begin scalar
    sd,                    % stab desc being constructed
    pe, inv_pe,
    nu_1, nu_2,
    sd_reps_orb1,          % O_k \cap orbit reps of sd \ beta_k
    b_orb2;                % O_k+1

  integer
    b_1, b_2,              % reps of basic orbits of G_k and G_k+1
    img,
    sigma, swap,
    count,
    ngens,
    elt;

%% take care of nil stabilizer descriptions

 % if k'th sd is null, then the base may be changed with no other modif
  if null sc_stabdesc(sc,k) then
    <<
    swap := venth(car sc, k);
    putve(car sc, k , venth(car sc, k+1));
    putve(car sc, k+1, swap);
    return sc
    >>;

 % if k+1'th sd is null, then one must create a trivial
 % stabilizer desc
  if null sc_stabdesc(sc,k+1) then
    putve(cdr sc, k+1, sd_create(upbve(car sc), venth(car sc, k+1)));

%% initialize sd to copy of stabdesc(k+2), changing the basic rep

  if (k+2 > upbve(car sc)) or null sc_stabdesc(sc, k+2) then
    sd := sd_create(upbve(car sc), venth(car sc, k))
  else
    <<
    sd := mkve(5);
    putve(sd, 1, fullcopy(sc_orbits(sc, k+2)));
    % make copy of generators, but not total copy
    ngens := upbve(sc_generators(sc, k+2));
    putve(sd, 3, mkve(ngens));
    putve(sd, 4, mkve(ngens));
    for count := 1 : ngens do
      <<
      putve(venth(sd, 3), count, venth(sc_generators(sc, k+2), count));
      putve(venth(sd,4), count, venth(sc_inv_generators(sc,k+2),count))
      >>;
    putve(sd, 5, venth(venth(cdr sc, k+2),5));
    sd_recomp_transversal(sd, venth(car sc, k));
    >>;

%% initialize sd_reps_orb1 and b_orb2
  for count := 1:upbve(car sc) do
    <<
    if venth(sc_transversal(sc, k+1), count) then
      b_orb2 := count . b_orb2;
    if venth(sc_transversal(sc, k), count) then
      sd_reps_orb1 := count . sd_reps_orb1
    >>;

  sd_reps_orb1 :=
    intersection(sd_reps_orb1, venth(sd, 5));

  b_1 := venth(car sc, k);
  b_2 := venth(car sc, k+1);

  sd_reps_orb1 := delete(venth(car sc, k), sd_reps_orb1);
%% join orbits of sd by joining elts of sd_reps_orb1
  while sd_reps_orb1 do
    <<
    elt := car sd_reps_orb1;
    sd_reps_orb1 := cdr sd_reps_orb1;
    nu_1 := nu_2 := nil;
    img := elt;
    while (img neq b_1) do
      <<
      nu_1 :=
        if nu_1 then
          pe_mult(nu_1, venth(sc_transversal(sc,k),img))
        else
          venth(sc_transversal(sc,k),img);
      img := pe_apply(nu_1, elt);
      >>;
    sigma := pe_apply(nu_1, b_2);
    if member(sigma, b_orb2) then
      <<
      img := sigma;
      while (img neq b_2) do
        <<
        nu_2 :=
          if nu_2 then
            pe_mult(nu_1, venth(sc_transversal(sc,k+1),img))
          else
            venth(sc_transversal(sc,k+1),img);
        img := pe_apply(nu_2, sigma);
        >>;
      if nu_2 then
        pe := pe_mult(nu_1, nu_2)
      else
        pe := nu_1;
      inv_pe := pe_inv(pe);
      sd_addgen(sd, pe, inv_pe);
      %% update sd_reps_orb1
      %% nu_1 taken as temp storage
      nu_1 := nil;
      for each img in sd_reps_orb1 do
        if sd_orbrep(sd, img)= img then
          nu_1 := img . nu_1;
      sd_reps_orb1 := nu_1;
      >>
    >>;
%% update base specifications
  swap := venth(car sc, k);
  putve(car sc, k, venth(car sc, k+1));
  putve(car sc, k+1, swap);
%% sd is new description of stabilizer at level k+1 of sc
  putve(cdr sc, k+1, sd);
%% update transversal for sd(k), as base element has changed
  sd_recomp_transversal(sc_stabdesc(sc, k), venth(car sc, k));
  return sc;
  end;

symbolic procedure sc_setbase(sc, base_vect);
  begin integer count, k;
  for count := 1:upbve(base_vect) do
    <<
    if venth(base_vect, count) neq venth(car sc, count) then
      for k := index_elt(venth(base_vect, count), car sc)-1
               step -1 until count do sc_swapbase(sc, k)
    >>;
  end;

endmodule;

end;