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

module dummycnt;

fluid '(g_dvnames g_dvbase g_sc_ve g_init_stree g_skip_to_level
        !*distribute);

%%%%%%%%%%%%%%%%%%%%%%% MISCELANEOUS ROUTINES %%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure ad_splitname(u);
  if idp u then
    begin scalar uu, nn;
    uu := reverse(explode u);
    while uu and (charnump!: car uu) do
      <<
      nn := car uu . nn;
      uu := cdr uu;
      >>;
    if uu then uu := intern(compress(reverse(uu)));
    if nn then nn := compress(nn);
    return (uu.nn);
    end;

symbolic procedure anticom_assoc(u,v);
  begin  scalar next_cell;
  if null v then
    return nil
  else if u = caar v then
    return (1 . car v)
  else
    <<
    next_cell := anticom_assoc(u, cdr v);
    if null next_cell then return nil;
    if oddp(length(cdar v)) then
      rplaca(next_cell, - car next_cell);
    return next_cell;
    >>;
  end;

%%%%%%%%%%%%%%%%%%%%%%% ORDERING FUNCTIONS %%%%%%%%%%%%%%%%%%%%
symbolic procedure ad_signsort(l, fn);
 begin scalar  tosort, sorted, insertl, dig;
        integer  thesign;
  tosort := copy l;
  thesign := 1;
  sorted := nil;
  while tosort do
    if null sorted then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else if car tosort = car sorted then
      <<
      thesign := 0;
      sorted := tosort := nil;
      >>
    else if apply(fn, {car sorted, car tosort}) then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else
      <<
      thesign := - thesign;
      insertl := sorted;
      dig := t;
      while dig do
        if null cdr insertl then
          dig := nil
        else if cadr insertl = car tosort then
          <<
          insertl := {nil};
          dig := nil;
          thesign := 0;
          sorted := tosort := nil;
          >>
        else if not apply(fn, {cadr insertl, car tosort}) then
          <<
          insertl := cdr insertl;
          thesign := - thesign;
          >>
        else
          dig := nil;
      if tosort then
        <<
        rplacd(insertl, (car tosort) . cdr insertl);
        tosort := cdr tosort;
        >>;
      >>;
 return (thesign . reverse sorted);
 end;

symbolic procedure cdr_sort(lst, fn);
  begin scalar  tosort, sorted, insertl;
  tosort := lst;
  while tosort do
    <<
    if (null sorted) or apply(fn, {cdar sorted, cdar tosort}) then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else
      <<
      insertl := sorted;
      while (cdr insertl) and
                    not(apply(fn, {cdadr insertl, cdar tosort})) do
        insertl := cdr insertl;
      rplacd(insertl, (car tosort) . cdr insertl);
      tosort := cdr tosort
      >>
    >>;
  return reverse sorted;
  end;

symbolic procedure cdr_signsort(l, fn);
  begin scalar  tosort, sorted, insertl, dig;
        integer thesign;
  tosort := copy l;
  thesign := 1;
  sorted := nil;
  while tosort do
    if null sorted then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else if cdar tosort = cdar sorted then
      <<
      thesign := 0;
      sorted := tosort := nil;
      >>
    else if apply(fn, {cdar sorted, cdar tosort}) then
      <<
      sorted := car tosort . sorted;
      tosort := cdr tosort;
      >>
    else
      <<
      thesign := - thesign;
      insertl := sorted;
      dig := t;
      while dig do
        if null cdr insertl then
          dig := nil
        else if cdadr insertl = cdar tosort then
          <<
          dig := nil;
          thesign := 0;
          sorted := tosort := nil;
          >>
        else if not apply(fn, {cdadr insertl, cdar tosort}) then
          <<
          insertl := cdr insertl;
          thesign := - thesign;
          >>
        else
          dig := nil;
      if tosort then
        <<
        rplacd(insertl, (car tosort) . cdr insertl);
        tosort := cdr tosort
        >>;
      >>;
  return (thesign . reverse sorted);
  end;

symbolic procedure num_signsort(l);
  ad_signsort(l, function(lambda(x,y); x <= y));

symbolic procedure cons_ordp(u,v, fn);
  if null u then t
  else if null v then nil
  else if pairp u then
    if pairp v then
      if car u = car v then
        cons_ordp(cdr u, cdr v, fn)
      else
        cons_ordp(car u, car v, fn)
    else
      nil
  else if pairp v then t
  else apply2(fn,u,v);

symbolic procedure atom_compare(u,v);
  if numberp u then numberp v and not(u < v)
  else if idp v then orderp(u,v)
  else numberp v;

symbolic procedure idcons_ordp(u,v);
  cons_ordp(u, v, function atom_compare);

symbolic procedure skp_ordp(u,v);
  cons_ordp(car u, car v, function atom_compare);

symbolic procedure numlist_ordp(u,v);
  cons_ordp(u,v,function(lambda(x,y); x <= y));

symbolic procedure ad_numsort(l);
  sort(l,function(lambda(x,y); x <= y));

%%%%%%%%%%%%%%%%%%%%%%% ACCESS ROUTINES %%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure sc_kern(ind);
  caddr venth(g_sc_ve, ind);

symbolic procedure sc_rep(ind);
  cadr venth(g_sc_ve, ind);

symbolic procedure sc_desc(ind);
  car venth(g_sc_ve, ind);

symbolic procedure dummyp(var);
  begin scalar varsplit;
       integer count, res;
  if not idp var then return nil;
  count := 1;
  while count <= upbve(g_dvnames) do
    <<
   if var = venth(g_dvnames, count) then
    <<
      res := count;
      count := upbve(g_dvnames) + 1
      >>
    else
      count := count + 1;
    >>;
  if res eq 0 then
    <<
    varsplit := ad_splitname(var);
    if (car varsplit eq g_dvbase) then
      return cdr varsplit
    >>
  else return res;
  end;

symbolic procedure dv_ind2var(ind);
  if ind <= upbve(g_dvnames) then
    venth(g_dvnames, ind)
  else
    mkid(g_dvbase, ind);

%%%%%%%%%%%%%%%%%%%%%% SYMMETRY CELLS %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure sc_repkern(s_cell, n);
  if car s_cell eq '!* then               % nil symmetric cell
    begin scalar  kern, rest, next_rest;
          integer head, rep;
    rest := cdr s_cell;
    rep := 0;
    while rest do
      <<
      head := car rest;
      kern := {head} . kern;
      rest := cdr rest;
      next_rest := nil;
      rep := rep*2 + 1;
      for each elt in rest do
        <<
        if elt eq head then
          rep := rep * 2 + 1
        else
          <<
          rep := rep * 2;
          next_rest := elt . next_rest
          >>
        >>;
      rest := reverse next_rest;
      >>;
    return {rep, pa_list2vect(reverse kern, n)};
    end
  else
    begin scalar  count, replist, rep, kern;
          integer last_count;
    s_cell := cdr s_cell; % s_cell supposed sorted
    for each elt in s_cell do
      if (count := assoc(elt, replist)) then
        rplacd (count, cdr count + 1)
      else
        replist := (elt . 1) . replist;
    replist := sort(replist, function(lambda(x,y); cdr x <= cdr y));
    last_count := 0;
    for each elt in replist do
      if (cdr elt neq last_count) then
        <<
        rep := (cdr elt . 1) . rep;
        kern := {car elt} . kern;
        last_count := cdr elt;
        >>
      else
        <<
        rplacd(car rep, cdar rep + 1);
        rplaca(kern, car elt . car kern)
        >>;
    return {rep , pa_list2vect(kern, n)};
    end;

%%%%%%%%%%%%%%%%%%%%% PARTITIONS COMP %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure pa_list2vect(pa, n);
  begin scalar  ve, reps;
        integer abs;
  ve := mkve(n);
  for each cell in pa do
    <<
    reps := eval('min . cell) . reps;
    for each elt in cell do putve(ve, elt, car reps);
    >>;
  for count := 1:n do
    <<
    if null venth(ve, count) then
      <<
      if abs = 0 then
        <<
        abs := count;
        reps := abs . reps
        >>;
      putve(ve, count, abs)
      >>
    >>;
  return ((reverse reps) . ve);
  end;

symbolic procedure pa_part2list(p);
  begin scalar  ve;
        integer len, rep;
  len := upbve(cdr p);
  ve := mkve(len);
  for count := len step -1 until 1 do
    <<
    rep := venth(cdr p, count);
    putve(ve, rep, count . venth(ve, rep));
    >>;
  return for each count in car p join copy
    venth(ve,count);
  end;

symbolic procedure pa_vect2list(pa);
  begin scalar  ve;
        integer count, rep;
  ve := mkve(upbve(cdr pa));
  for count := 1 : upbve(cdr pa) do
    <<
    rep := venth(cdr pa, count);
    putve(ve, rep, count . venth(ve,rep));
    >>;
  return for each rep in (car pa) collect ordn(venth(ve, rep));
  end;

symbolic procedure pa_coinc_split(p1, p2);
  begin
     scalar  ve1, ve2, cursplit, split_alist, split_info, coinc, split;
     integer count, plength;
  plength := upbve(cdr p1);
  ve1 := mkve(plength);
  ve2 := mkve(plength);
  split := mkve(plength);
  count := 0;
  for each rep in car p1 do
    <<
    count := count + 1;
    putve(ve1, rep, count)
    >>;
  count := 0;
  for each rep in car p2 do
    <<
    count := count + 1;
    putve(ve2, rep, count)
    >>;
  for count := 1 : plength do
    <<
    cursplit := (venth(ve1, venth(cdr p1, count)) .
                 venth(ve2, venth(cdr p2, count)));
    if (split_info := assoc(cursplit, split_alist)) then
      <<
      rplacd(cdr split_info, cddr split_info + 1);
      putve(split, count, cadr split_info)
      >>
    else
      <<
      split_info := cursplit . (count . 1);
      split_alist := split_info . split_alist;
      putve(split, count, count)
      >>
    >>;
  split_alist :=
     sort(split_alist,
          function(lambda x,y;
            if caar x < caar y then t
            else if caar y < caar x then nil
            else cdar x leq cdar y));
  split := (for each cell in split_alist collect cadr cell) . split;
  coinc := for each cell in split_alist collect
    (car cell) . (cddr cell);
  return coinc . split;
  end;

%%%%%%%%%%%%%%%%%%%%% SYMMETRY TREES %%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure st_flatten(stree);
  if numberp(cadr stree) then
    cdr stree
  else
    for each elt in cdr stree join copy st_flatten(elt);

symbolic procedure st_extract_symcells(stree, maxind);
  begin scalar  ve, symcells;
        integer count;
  if null stree then return (nil . mkve(0));
  symcells := st_extract_symcells1(st_consolidate(stree),nil,1);
  stree := car symcells;
  if not listp stree then % stree is a single symcell
    stree := {'!* , stree};
  symcells := cadr symcells;
  ve := mkve(length(symcells));
  count := upbve(ve);
  while symcells do
    <<
    putve(ve, count, car symcells . sc_repkern(car symcells, maxind));
    symcells := cdr symcells;
    count := count - 1
    >>;
  return(st_consolidate(stree) . ve);
  end;

symbolic procedure st_extract_symcells1(stree, symcells, count);
  begin scalar  res, new_stree;
  if not listp cadr stree then % stree is a symcell
    return { count , stree . symcells, count + 1}
  else
    <<
    new_stree := car stree .
      for each inner_stree in cdr stree collect
        <<
        res := st_extract_symcells1(inner_stree, symcells, count);
        symcells := cadr res;
        count := caddr res;
        if numberp car res then
          {'!*, car res}
        else
          car res
        >>;
    return ({ new_stree, symcells, count })
    >>;
  end;

symbolic procedure st_signchange(ve1, ve2);
  car st_signchange1(g_init_stree, vect2list ve1) *
  car st_signchange1(g_init_stree, vect2list ve2);

symbolic procedure st_signchange1(stree, eltlist);
  begin scalar  levlist, elt_levlist, subsign;
        integer the_sign;
  the_sign := 1;
  levlist := for each child in cdr stree collect
    if numberp child then
      child
    else
      <<
      subsign := st_signchange1(child, eltlist);
      the_sign := the_sign * car subsign;
      cdr subsign
      >>;
  if not cdr levlist then return (the_sign . car levlist);
  elt_levlist := eltlist;
  if member(car eltlist, levlist) then
    elt_levlist := 0 . elt_levlist
  else while not member(cadr elt_levlist, levlist) do
    elt_levlist := cdr elt_levlist;
%% cdr elt_levlist starts with the elements of levlist
%% Compute the sign change
  if car stree eq '!- and not permp(levlist, cdr elt_levlist) then
      the_sign := - the_sign;
%% remove from elt_levlist (and thus from eltlist)
%% the elements of levlist except the last (which will be the
%% ref).
  rplacd(elt_levlist, pnth(cdr elt_levlist, length(levlist)));
  return (the_sign . cadr elt_levlist);
  end;

symbolic procedure st_sorttree(stree, ve, fn);
  cdr st_sorttree1(stree, ve, fn);

symbolic procedure st_sorttree1(stree, ve, fn);
  begin scalar  schild, vallist, sorted, thesign, tosort;
  thesign := 1;
  if numberp cadr stree then
    <<
    if car stree eq '!* then
      <<
      vallist := for each elt in cdr stree collect venth(ve,elt);
      return (vallist . (1 . stree))
      >>;
    tosort := for each elt in cdr stree collect
      elt . venth(ve,elt);
    >>
  else
    <<
    if (car stree) eq '!* then
      <<
      for each child in cdr stree do
        if thesign neq 0 then
          <<
          schild := st_sorttree1(child, ve, fn);
          thesign := thesign * cadr schild;
          vallist := (car schild) . vallist;
          sorted := (cddr schild) . sorted;
          >>;
      if thesign = 0 then
        return (nil . 0 . nil)
      else
        <<
        sorted := reverse sorted;
        vallist := reverse vallist;
        return (vallist . (thesign . ('!* . sorted)));
        >>
      >>;
    for each child in cdr stree do
      if thesign neq 0 then
        <<
        schild := st_sorttree1(child, ve, fn);
        thesign := thesign * cadr schild;
        tosort := ((cddr schild) . (car schild)) . tosort;
        >>;
    >>;
  if thesign = 0 then return (nil . (0 . nil));
  if car stree = '!+ then
    tosort := cdr_sort(tosort, fn)
  else
    <<
    tosort := cdr_signsort(tosort, fn);
    if car tosort = 0 then
      return (nil . (0 . nil))
    else
      thesign := thesign * car tosort;
    tosort := cdr tosort;
    >>;
  % fill up return structures
  while tosort do
    <<
    sorted := (caar tosort) . sorted;
    vallist := (cdar tosort) . vallist;
    tosort := cdr tosort;
    >>;
  sorted := (car stree) . reverse sorted;
  vallist := reverse(vallist);
  return (vallist . (thesign . sorted));
  end;

symbolic procedure st_ad_numsorttree(stree);
  begin scalar sorted;
  sorted := st_ad_numsorttree1(stree);
  return car sorted . cadr sorted;
  end;

symbolic procedure st_ad_numsorttree1(stree);
  begin scalar  subtree, contents, tosort;
        integer thesign;
  if numberp stree then return {1, stree, stree};
  thesign := 1;
  if car stree eq '!* then
    <<
    stree := '!* . for each elt in cdr stree collect
      <<
      subtree := st_ad_numsorttree1(elt);
      thesign := thesign * car subtree;
      contents := cddr subtree . contents;
      cadr subtree
      >>;
    contents := ad_numsort(for each elt in contents join elt);
    return thesign . (stree . contents);
    >>;
  tosort := for each elt in cdr stree collect
    <<
    subtree := st_ad_numsorttree1(elt);
    thesign := thesign * car subtree;
    cdr subtree
    >>;
  if car stree eq '!+ then
    <<
    tosort := cdr_sort(tosort, function numlist_ordp);
    tosort := for each elt in tosort collect
      <<
      contents := (cdr elt) . contents;
      car elt
      >>;
    contents := ad_numsort(for each elt in reverse contents join elt);
    return (thesign . (('!+ . tosort) . contents));
    >>;
  if car stree eq '!- then
    <<
    tosort := cdr_signsort(tosort, function numlist_ordp);
    thesign := car tosort;
    tosort := for each elt in cdr tosort collect
      <<
      contents := (cdr elt) . contents;
      car elt
      >>;
    contents := ad_numsort(for each elt in reverse contents join elt);
    return (thesign . (('!- . tosort) . contents));
    >>;
  end;

symbolic procedure st_consolidate(stree);
  begin scalar join_cells, children, tmp;
   if null stree then return nil;
   if numberp cadr stree then return stree;
   join_cells := t;
   for each child in reverse(cdr stree) do
     <<
     tmp := st_consolidate(child);
     if tmp then
      <<
      if cddr tmp then
        join_cells := nil
      else
        tmp := {'!*, cadr tmp};
      children := tmp . children;
      >>;
    >>;
  if children then
    <<
    if null cdr children then
      return car children;
    if join_cells then
      children := for each elt in children collect cadr elt;
    return (car stree) . children
    >>
  else
    return nil;
  end;

%%%%%%%%%%%%%%%%%%%%%% SKELETONS %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure dv_cambhead(camb);
  begin
  if listp camb then
    <<
    if member(car camb, {'expt, 'minus}) then
      return dv_cambhead(cadr camb);
    if listp camb then return car camb;
    >>;
  end;

symbolic procedure dv_skelhead(skelpair);
  dv_cambhead car(skelpair);

symbolic procedure dv_skelsplit(camb);
  begin scalar  skel, stree, subskels;
        integer count, ind, maxind, thesign;
  thesign := 1;
  if not listp camb then
    if (ind := dummyp(camb)) then
      return {1, ind, ('!~dv . {'!*, ind})}
    else
      return {1, 0, (camb . nil)};
  stree := get(car camb, 'symtree);
  if not stree then
    <<
    stree := for count := 1 : length(cdr camb) collect count;
    if flagp(car  camb, 'symmetric) then
      stree := '!+ . stree
    else if flagp(car camb, 'antisymmetric) then
      stree := '!- . stree
    else
      stree := '!* . stree
    >>;
  subskels := mkve(length(cdr camb));
  count := 0;
  for each arg in cdr camb do
    <<
    count := count + 1;
    if listp arg then
      putve(subskels, count, (arg . nil))
    else if (ind := dummyp(arg)) then
      <<
      maxind := max(maxind, ind);
      putve(subskels, count, ('!~dv . {'!*, ind}))
      >>
    else
      putve(subskels, count, (arg . nil));
    >>;
  stree := st_sorttree(stree, subskels, function skp_ordp);
  if stree and (car stree = 0) then return nil;
  thesign := car stree;
  skel := dv_skelsplit1(cdr stree, subskels);
  stree := st_consolidate(cdr skel);
  skel := (car camb) . car skel;
  return {thesign, maxind, skel . stree};
  end;

symbolic procedure dv_skelsplit1(stree, skelve);
  begin scalar
            cell_stree, child_list, cur_cell, dv_stree, part, skel, ve;
        integer count, len;
  if numberp cadr stree then
    <<
    ve := skelve;
    child_list := cdr stree;
    skel := for each elt in cdr stree collect car venth(ve,elt);
    >>
  else
    <<
    len := length(cdr stree);
    ve := mkve(len);
    count := len;
    for each child in reverse(cdr stree) do
      <<
      putve(ve, count, dv_skelsplit1(child, skelve));
      skel := car(venth(ve,count)) . skel;
      child_list := count . child_list;
      count := count - 1;
      >>;
    skel := for each elt in skel join copy elt;
    >>;
  %% if root of stree is * node, then
  %% no partition of children is necessary
  if car stree eq '!* then
    <<
    for each elt in reverse(child_list) do
      if cdr venth(ve, elt) then
        dv_stree := cdr venth(ve, elt) . dv_stree;
    if length(dv_stree) = 1 then
      dv_stree := car dv_stree
    else if dv_stree then
      dv_stree := '!* . dv_stree;
    return (skel . dv_stree);
    >>;
  %% regroup children with equal skeletons
  for each elt in child_list do
    if null cur_cell then % new skeleton
      cur_cell := car venth(ve, elt) . {cdr venth(ve, elt)}
    else if (car venth(ve, elt)) = (car cur_cell) then
      rplacd(cur_cell, (cdr venth(ve,elt)) . cdr cur_cell)
    else
      <<
      part := cur_cell . part;
      cur_cell := car venth(ve, elt) . {cdr venth(ve, elt)};
      >>;
  part := cur_cell . part;
  %% prepend contribution of each cell to dv_stree
  %% note that cells of part are in reverse order,
  %% as are elements of each cell
  for each cell in part do
    if cdr cell then
      <<
      cell_stree := car stree . reverse(cdr cell);
      dv_stree := cell_stree . dv_stree
      >>;
  %% now set type of dv_stree, if it has more than one element
  if length(dv_stree) neq 1 then
    dv_stree := '!* . dv_stree
  else
    dv_stree := car dv_stree;
  return skel . dv_stree;
  end;


symbolic procedure nodum_varp u;
% u is a list or an atom (index) or !~dv or !~dva
% returns true if it is neither a list nor a dummy var 
% nor !~dv or !~dva.
 if listp u then t 
   else 
 if flagp(u,'dummy) or car ad_splitname u = g_dvbase
                    or u member {'!~dv,'!~dva} 
         then nil
  else t;


symbolic procedure list_is_all_free u;
% u is a list of indices 
% returns nil if there is at least one dummy index
% or if one of them is !~dv or !~dva.
 if null u then t
  else 
 if nodum_varp car u then list_is_all_free cdr u
   else nil;


symbolic procedure dv_skelprod(sklist, maxind);
% This is the corrected function for commuting 
% operators which do not depend on dummy variables.
  begin scalar
               skform, stree, symcells, skel, apair, anticom_alist,
               com_alist, noncom_alist, acom_odd, acom_even, idvect,
               varskel;
        integer the_sign, count;
  %% sort skeletons according to lexicograpical order of dv_skelhead,
  %% placing commuting factors before anticommuting factors
  the_sign := 1;
  for each skelpair in sklist do
    <<
    skel := car skelpair;
    varskel:=if listp skel then 
                if car skel neq 'expt then cdr skel;
% else 
%                     if car skel neq 'expt then cdr skel;
    if flagp(dv_skelhead skelpair , 'anticom) then
      <<
      if (apair := anticom_assoc(skel, anticom_alist)) then
        <<
        if member(cdr skelpair, cddr apair) then
          the_sign := 0
        else
          the_sign := the_sign * car apair;
        rplacd(cdr apair, (cdr skelpair) . (cddr apair))
        >>
      else
        anticom_alist := (skel . {cdr skelpair}) . anticom_alist;
      >>
    else if flagp(dv_skelhead skelpair, 'noncom) then
      noncom_alist := (skel . {cdr skelpair}) . noncom_alist
   % we do not need the "else if" for commuting operators
   %   if no dummy variable is involved:
 %   else  if null list_is_all_free varskel or atom skel then   
 %               if(apair := assoc(skel, com_alist)) then
    else  if ( (null list_is_all_free varskel or atom skel) and    
               (apair := assoc(skel, com_alist)) ) then
    rplacd (apair, (cdr skelpair) . (cdr apair))
     %           else nil
    else
      com_alist := (skel . {cdr skelpair}) . com_alist;
    >>;
  if the_sign = 0 then return nil;
  %% restore order of factors for each anticom cell
  anticom_alist := for each elt in anticom_alist collect
    (car elt) . reverse(cdr elt);
  %% sort com_alist
  com_alist := sort(com_alist,
                    function(lambda(x,y); idcons_ordp(car x, car y)));
  %% sort anticom_alist, taking care of sign changes
  %% isolate even prod of anticoms from odd prod of anticoms
  for each elt in anticom_alist do
    if evenp(length(cdr elt)) then
      acom_even := elt . acom_even
    else
      acom_odd := elt . acom_odd;
  acom_even := sort(acom_even,
                    function(lambda(x,y); idcons_ordp(car x, car y)));
  anticom_alist := ad_signsort(acom_odd,
                     function(lambda(x,y); idcons_ordp(car x, car y)));
  the_sign := the_sign * car anticom_alist;
  anticom_alist :=
    merge_list1(acom_even, cdr anticom_alist, function idcons_ordp);
  skform := append(com_alist, anticom_alist);
  skform := append(skform, reverse noncom_alist);
  if maxind = 0 then
    <<
    if the_sign = -1 then skform := ((-1) . {nil}) . skform;
    return skform . nil;
    >>;
  %% build complete symtree,
  %% omiting skels which do not depend on dummy variables
  for each elt in reverse noncom_alist do
    stree := cadr elt . stree;
  for each elt in reverse anticom_alist do
    if length(cdr elt) > 1 then
      stree := ('!- . cdr elt) . stree
    else if (cdr elt) then
      stree := cadr elt . stree;
  for each elt in reverse com_alist do
    if length(cdr elt) > 1 then
      stree := ('!+ . cdr elt) . stree
    else if (cdr elt) then
      stree := cadr elt . stree;
  if length(stree) > 1 then
    stree := '!* . stree
  else
    stree := car stree;
  stree := st_consolidate(stree);
  idvect := mkve(maxind);
  for count := 1 : maxind do putve(idvect, count, count);
  stree := st_sorttree(stree, idvect, function numlist_ordp);
  %% the sign change for sorting the symmetry tree does not influence
  %% the sign of the expression.  Indeed, the symtree used to fill up
  %% the blanks in the expression is the symtree stored with the
  %% skeleton, which is not sorted.  Note however that if the sign here
  %% is 0, then the expression is null.
  %  the_sign := the_sign * car stree;
  if car stree = 0 then return nil;
  if the_sign = -1 then
    skform := ((-1) . {nil}) . skform;
  symcells := st_extract_symcells(cdr stree, maxind);
  return skform . symcells;
  end;


symbolic procedure dv_skel2factor1(skel_kern, dvars);
  begin scalar dvar,scr;
    if null skel_kern then return nil;
   return 
    if listp skel_kern then
     <<scr:=dv_skel2factor1(car skel_kern, dvars);
          scr:=scr . dv_skel2factor1(cdr skel_kern, dvars)
     >>
  else
    if skel_kern eq '!~dv then
      <<
      dvar := car dvars;
      if cdr dvars then
        <<
        rplaca(dvars, cadr dvars);
        rplacd(dvars, cddr dvars);
        >>;
      dvar
      >>
    else
      skel_kern;
  end;

%%%%%%%%%%%%%%% PARTITION SYMMETRY TREES %%%%%%%%%%%%%%%%%%

symbolic procedure pst_termnodep(pst);
  null cdr venth(cdr pst, 1);

symbolic procedure pst_mkpst(stree);
  pst_equitable(nil . pst_mkpst1(stree));

symbolic procedure st_multtermnodep(stree);
  begin
  scalar res, subtrees;
  if car stree neq '!* then return nil;
  subtrees := cdr stree;
  res := t;
  while subtrees do
    <<
    if numberp cadar subtrees then
      subtrees := cdr subtrees
    else
      <<
      subtrees := nil;
      res := nil;
      >>
    >>;
  return res;
  end;

symbolic procedure pst_mkpst1(stree);
  begin
  scalar
    subtrees, s_cells, ve, pst, cell;
  integer
    count, lastcount;
  if null stree then return nil;
  ve := mkve(length(cdr stree));
  subtrees := cdr stree;
  count := 1;
  if numberp(car subtrees) then       % terminal node with single cell
    while subtrees do
      <<
      putve(ve, count, ({car subtrees} . nil));
      count := count + 1;
      subtrees := cdr subtrees;
      >>
  % check if valid as pst terminal node with several cells
  else if st_multtermnodep(stree) then
    <<
    ve := mkve(for each cell in subtrees sum (length(cdr cell)));
    lastcount := 0;
    for each s_cell in subtrees do
      <<
      cell := cdr s_cell;
      if car s_cell eq '!* then
        for count := 1 : length(cell) do
          pst := {count + lastcount} . pst
      else
        pst := (
          for count := 1 : length(cell) collect (count + lastcount)
          ) . pst;
      count := lastcount + 1;
      lastcount := lastcount + length(cell);
      for each elt in cell do
        <<
        putve(ve,count, {{elt}});
        count := count + 1;
        >>;
      >>;
    return (reverse pst . ve);
    >>
  else
    while subtrees do
      <<
      pst := pst_mkpst1(car subtrees);
      s_cells := nil;
      for count2 := 1 : upbve(cdr pst) do
        s_cells := append(car venth(cdr pst, count2), s_cells);
      putve(ve, count, (s_cells . pst));
      count := count + 1;
      subtrees := cdr subtrees;
      >>;
  if ((car stree) eq '!*) then % discrete partition
    pst := ((for count := 1 : upbve(ve) collect {count}) . ve)
  else % single cell partition
    pst := ({(for count := 1 : upbve(ve) join {count})} . ve);
  return pst;
  end;

symbolic procedure pst_subpst(pst, ind);
  venth(cdr pst, ind);

symbolic procedure pst_reduce(pst);
  begin
  scalar
       isolated, f_cell, rpst, tmp, npart, nsubs;
  integer
       ind, count;
  if null pst then return (nil . nil);
  if null cdr pst then return pst;
  f_cell := caar pst;
  while length(f_cell) eq 1 do
    <<
    ind := car f_cell;                   % index of pst_subpst
    if pst_termnodep(pst) then
      <<
      isolated := append(isolated, {caar venth(cdr pst, ind)});
      %% remove first cell from pst, and set f_cell
      if cdar pst then % pst is not fully reduced
        <<
        %% remove first cell
        rplaca(pst, cdar pst);
        %% update pst representation
        npart := for each cell in car pst collect
          for each elt in cell collect
            if (elt > ind) then elt - 1 else elt;
        nsubs := mkve(upbve(cdr pst)-1);
        for count := 1 : upbve(nsubs) do
          if count geq ind then
            putve(nsubs, count, venth(cdr pst, count+1))
          else
            putve(nsubs, count, venth(cdr pst, count));
        rplaca(pst, npart);
        rplacd(pst, nsubs);
        f_cell := caar pst;
        >>
      else % pst fully reduced
        f_cell := pst := nil;
      >>
    else
      <<
      rpst := pst_reduce(cdr pst_subpst(pst,ind));
      if car rpst then
      %% new isolates
        <<
        %% add new isolates to isolated
        isolated := append(isolated, car rpst);
        if cdr rpst then
        %% first subtree in pst was not discrete, update subtree spec
          <<
          tmp := pst_subpst(pst,ind);
          rplaca(tmp, setdiff(car tmp, car rpst));
          rplacd(tmp, cdr rpst);
          f_cell := nil;
          >>
        else  % first subtree in pst was discrete, so remove it
          <<
          if cdar pst then % pst not fully reduced
            <<
            rplaca(pst, cdar pst);
            npart := for each cell in car pst collect
              for each elt in cell collect
                if (elt > ind) then elt - 1 else elt;
            nsubs := mkve(upbve(cdr pst)-1);
            for count := 1 : upbve(nsubs) do
              if count geq ind then
                putve(nsubs, count, venth(cdr pst, count+1))
              else
                putve(nsubs, count, venth(cdr pst, count));
            rplaca(pst, npart);
            rplacd(pst, nsubs);
            f_cell := caar pst;
            >>
          else
            f_cell := pst := nil;
          >>;
        >>
      else
      %% car rpst is nil, so no more isolated d-elts
        <<
        f_cell := nil;
        >>;
      >>
    >>;
  return (isolated . pst);
  end;

symbolic procedure pst_isolable(rpst);
  begin
  scalar
    ve, f_cell;
  %% verify if fully reduced.
  if null cdr rpst then return nil;
  %% f_cell is list of elts in first cell in rpst.
  %% ve is vector of descriptions of elts in f_cell
  f_cell := caadr rpst;
  ve := cddr rpst;
  %% if the elts in f_cell are d-elts, then return the list of d-elts
  if null cdr venth(ve, car f_cell) then
    return for each ind in f_cell collect caar venth(ve, ind);
  return for each ind in f_cell join copy
    pst_isolable(nil . cdr venth(ve, ind));
  end;

symbolic procedure pst_isolate(s_cell, rpst);
  begin
  scalar
    redisol;
  redisol := pst_reduce(pst_isolate1(s_cell, cdr rpst));
  rplaca(redisol, append(car rpst, car redisol));
  return redisol;
  end;

symbolic procedure pst_isolate1(s_cell, pst);
  begin
  scalar
    fcell, tmp, spst;
  integer
    ind;
  %% fcell is the list of elts in the first cell of rpst
  %% ve is the vector of descriptions of elts in fcell
  fcell := caar pst;
  %% find out which elt of fcell needs to be set aside, if any
  tmp := fcell;
  while (ind = 0) do
    <<
    if null tmp then ind := -1;
    ind := car tmp;
    tmp := cdr tmp;
    if not member(s_cell, car (spst := pst_subpst(pst, ind))) then
      ind := 0
    >>;
  %% if no elt should be set aside, then s_cell is not isolable
  if (ind = -1) then return nil;
  %% effectively isolate, splitting first cell if necessary
  if (length(fcell) > 1) then
    <<
    tmp := delete(ind, fcell) . cdar pst;
    tmp := {ind} . tmp;
    rplaca(pst, tmp)
    >>;
  %% if the set aside elt is not a mere dummy variable, then isolate
  %% s_cell in the partition it represents.
  if not pst_termnodep(pst) then
    <<
    spst := car spst . pst_isolate1(s_cell, cdr spst);
    putve(cdr pst, ind, spst)
    >>;
  return pst;
  end;

symbolic procedure pst_equitable(rpst);
  begin
  scalar
    nrpst, reduced, isol;
  if null cdr rpst then return rpst;
  isol := car rpst;
  nrpst := pst_reduce(cdr rpst);
  rplaca(nrpst, append(isol, car nrpst));
  repeat
    <<
    isol := car nrpst;
    nrpst := isol . pst_equitable1(isol, cdr nrpst);
    reduced := pst_reduce(cdr nrpst);
    if car reduced then
      nrpst := (append(isol, car reduced) . cdr reduced);
    reduced := car reduced
    >>
  until not reduced;
  return nrpst;
  end;

symbolic procedure pst_equitable1(isolated, pst);
  begin
  scalar
    isol, ve, alpha, beta, p1, equit, cell, psi;
  integer
    len, k, n_delems;
  if null pst then return nil;
  %% make partition to equitate, merging isolated and car pst
  isol := isolated;
  len := length(isolated);
  ve := mkve(upbve(cdr pst) + len);
  for count := 1 : upbve(cdr pst) do
    putve(ve, count, car venth(cdr pst, count));
  alpha := car pst;
  for count := upbve(cdr pst) + 1 : upbve(ve) do
    <<
    putve(ve, count, {car isol});
    isol := cdr isol;
    alpha := {count} . alpha;
    >>;
  p1 := fullcopy alpha;
  len := length(p1);
  n_delems := upbve(ve);
  while (alpha and len  < n_delems) do
    <<
    beta := car alpha;
    alpha := cdr alpha;
    equit := nil;
    len := 0;
    while(p1) do
      <<
      cell := car p1;
      p1 := cdr p1;
      psi := if cdr cell then
                       pst_partition(cell, beta, ve) else {cell};
      k := length(psi);
      equit := append(equit, psi);
      len := len + k;
      if k geq 2 then alpha := append(cdr psi, alpha);
      >>;
    p1 := equit;
    >>;
  equit := pnth(p1,length(isolated)+1);
  %%% make every child of pst equitable w.r.t. isolated
  if not pst_termnodep(pst) then
    for count := 1 : upbve(cdr pst) do
      <<
      p1 := venth(cdr pst, count);
      putve(cdr pst, count,
            (car p1 . pst_equitable1(isolated, cdr p1)));
      >>;
  return (equit . cdr pst);
  end;

symbolic procedure pst_d1(d1,d2, ve);
  for each e1 in venth(ve,d1) collect ordn
    for each e2 in venth(ve, d2) collect ordn
      car pa_coinc_split(sc_kern(e1), sc_kern(e2));

symbolic procedure pst_d(d1, d2, ve);
  if listp d1 then
    if listp d2 then
      ordn for each e1 in d1 collect
        ordn for each e2 in d2 collect pst_d(e1, e2, ve)
    else
      ordn for each e1 in d1 collect pst_d(e1, d2, ve)
  else
    if listp d2 then
      ordn for each e2 in d2 collect pst_d(d1, e2, ve)
    else
      pst_d1(d1, d2, ve);

symbolic procedure pst_partition(s1, s2, ve);
  begin
  scalar
    elt_d, elt_apair, pst_alist;
  for each elt in s1 do
    <<
    elt_d := pst_d(elt, s2, ve);
    if (elt_apair := assoc(elt_d, pst_alist)) then
      rplacd(elt_apair, elt . cdr elt_apair)
    else
      pst_alist := (elt_d . {elt}) . pst_alist;
    >>;
  % sort regrouped elts according to distance to s2
  pst_alist := sort(pst_alist,
      function( lambda(x,y); numlist_ordp(car x, car y)));
  return for each elt in pst_alist collect reverse(cdr elt);
  end;

%%%%%%%%%%%%%%%%%%%%%%%% BACKTRACKING %%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure dv_next_choice(sc, partial_perm, rpst, comp_info);
  begin scalar
    next_perm, extensions, nrpst, new_aut;
  integer
    npoints, len, next_img ;
  npoints := upbve(car sc);
  g_skip_to_level := len := upbve(partial_perm) + 1;
  sc_setbase(sc, partial_perm);
  extensions := pst_isolable(rpst);
  repeat
    <<
    extensions := idsort( intersection
        (extensions, candidate_extensions(sc, partial_perm)));
    if extensions then
      <<
      next_img := car extensions;
      extensions := cdr extensions;
      nrpst := pst_equitable(pst_isolate(next_img, fullcopy(rpst)));
      next_perm := list2vect!*(car nrpst,'symbolic);
      comp_info := dv_compare(next_perm, comp_info, len, npoints);
      if (car comp_info = 0) then
       if (upbve(next_perm) = npoints) then
       <<
       new_aut := pe_mult(pe_inv(venth(cadr comp_info, 1)), next_perm);
          process_new_automorphism(sc, new_aut);
          >>
        else
          comp_info := dv_next_choice(sc, next_perm, nrpst, comp_info)
      else if (car comp_info = 1) then
        if (upbve(next_perm) < npoints) then
          comp_info := dv_next_choice(sc, next_perm, nrpst, comp_info)
        else
          rplaca(comp_info, 0);
      rplacd(cdr comp_info, cdr cddr comp_info);
      >>
    >>
  until (null extensions) or (len > g_skip_to_level);
  return comp_info;
  end;

symbolic procedure can_rep_cell(comp_info, level);
  venth(venth(cadr comp_info, 2), level);

symbolic procedure last_part_kern(comp_info);
  car cddr comp_info;

symbolic procedure dv_compare(next_perm, comp_info, len, npoints);
  begin
  scalar
    part_kern, part_rep, can_rep, curlev, res;
  if car comp_info = 1 then
    return
     dv_fill_comp_info(next_perm, comp_info, len, npoints, nil, nil);
  if len = 1 then
    <<
    part_kern := sc_kern(venth(next_perm, 1));
    part_rep := {sc_rep(venth(next_perm,1))};
    >>
  else
    <<
    part_kern := last_part_kern(comp_info);
    part_kern := pa_coinc_split(part_kern,
                                sc_kern(venth(next_perm, len)));
    part_rep := (sc_rep(venth(next_perm, len)) . car part_kern);
    part_kern := cdr part_kern;
    >>;
  can_rep := can_rep_cell(comp_info, len);
  curlev := len;
  res := 0;
  repeat
    <<
    if equal(can_rep, part_rep) then
      <<
      res := 0;
      if (curlev < upbve(next_perm)) then
        <<
        curlev := curlev + 1;
        part_kern := pa_coinc_split(part_kern,
                                   sc_kern(venth(next_perm, curlev)));
        part_rep := (sc_rep(venth(next_perm,curlev)) . car part_kern);
        part_kern := cdr part_kern;
        can_rep := can_rep_cell(comp_info, curlev);
        >>
      >>
    else if numlist_ordp(can_rep, part_rep) then
      <<
      res := 1;
      rplaca(comp_info, 1);

      comp_info := dv_fill_comp_info(next_perm, comp_info,
                              curlev, npoints, part_rep, part_kern);
      >>
    else
      <<
      res := 2;
      % grow partial permutation kernel stack
      rplacd(cdr comp_info, nil . (cddr comp_info));
      rplaca(comp_info, 2);
      >>
    >>
  until (res neq 0) or (curlev = upbve(next_perm));
  if res = 0 then
    <<
    % update partial permutation stack
    rplacd(cdr comp_info, part_kern . cddr comp_info);
    if (curlev = npoints) and
                 dv_new_aut_hook(next_perm, comp_info) then
      <<
      g_skip_to_level := 0;
      rplaca(comp_info, 2);
      >>;
    >>;
  return comp_info;
  end;


symbolic procedure dv_fill_comp_info(pe, comp_info, len, npoints,
                                     part_rep, part_kern);
  begin scalar
    part_rep;
  integer level;
  if len = 1 then
    <<
    part_kern := sc_kern(venth(pe, 1));
    part_rep := {sc_rep(venth(pe,1))};
    >>
  else if null part_kern then
    <<
    part_kern := last_part_kern(comp_info);
    part_kern := pa_coinc_split(part_kern, sc_kern(venth(pe, len)));
    part_rep := (sc_rep(venth(pe, len)) . car part_kern);
    part_kern := cdr part_kern;
    >>;
  putve(venth(cadr comp_info, 2), len, part_rep);
  level := len + 1;
  while(level <= upbve(pe)) do
    <<
    part_kern := pa_coinc_split(part_kern, sc_kern(venth(pe, level)));
    part_rep := (sc_rep(venth(pe, level)) . car part_kern);
    part_kern := cdr part_kern;
    putve(venth(cadr comp_info, 2), level, part_rep);
    level := level + 1
    >>;
  rplacd(cdr comp_info, part_kern . (cddr comp_info));
  if level = npoints+1 then
    if null venth(cadr comp_info, 1) and
                             dv_null_first_kern(part_kern) then
      <<
      g_skip_to_level := 0;
      rplaca(comp_info, 2);
      >>
    else
      <<
      putve(cadr comp_info, 1, fullcopy(pe));
      putve(cadr comp_info, 3, part_kern);
      >>;
  return comp_info;
  end;

symbolic procedure dv_null_first_kern(kern);
  begin
  scalar
    l_kern, cell, nullexp, acell;
  integer
    count, count2;
  nullexp := nil;
  l_kern := pa_vect2list kern;
  for each cell in l_kern do
    if cdr cell and not nullexp then
      <<
      count := 0;
      for count2 := 1 : upbve(g_sc_ve) do
        if (car (acell := car venth(g_sc_ve, count2)) eq '!-) and
          member (car cell, acell) then count := count + 1;
      if oddp count then
        nullexp := t;
      >>;
  return nullexp;
  end;

symbolic procedure dv_new_aut_hook(pe, comp_info);
  begin
  scalar tmp1, tmp2, ve;
  integer count, thesign;
  thesign := st_signchange(venth(cadr comp_info,1), pe);
  tmp1 := pa_part2list(venth(cadr comp_info, 3));
  tmp2 := pa_part2list(caddr comp_info);
  ve := mkve(length(tmp1));
  count := 1;
  while tmp1 do
    <<
    putve(ve, car tmp1, car tmp2);
    tmp1 := cdr tmp1;
    tmp2 := cdr tmp2;
    count := count + 1;
    >>;
  for count := 1 : upbve(g_sc_ve) do
    <<
    tmp1 := car venth(g_sc_ve, count);
    if car tmp1 eq '!- then
      <<
      tmp1 := cdr tmp1;
      tmp2 := for each elt in tmp1 collect venth(ve,elt);
      % tmp2 is the image of tmp1. Since all cells in g_sc_ve are
      % ordered in increased numerical order
      thesign := thesign * car num_signsort(tmp2);
      >>
    >>;
  if thesign = -1 then
    return t;
  return nil;
  end;

%%%%%%%%%%%%%%%%%%%%%%%%%% TOP LEVEL %%%%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure dv_canon_monomial(sf);
  begin
  scalar
    tmp, sklist, camb, skel, skprod, aut_sc, can_kern,
    new_dvnames, pst, comp_info, factlst, res, fact,
    sorted_factlst;
  integer
    count, expnt, thesign, maxind;
  %% get skeleton pairs for each one of the factors
  thesign := 1;
  while not domainp sf do
    <<
    tmp := lpow(sf); sf := lc(sf);
    %% suppose exponents are integers
    expnt := cdr tmp; camb := car tmp;
    if expnt neq 1 and flagp(dv_cambhead(camb),'anticom) then
      <<
      skel := nil;
      sf := nil;
      >>
    else
      skel := dv_skelsplit(camb);
    if null skel then
      sf := nil
    else
      <<
      if car skel < 0 then
        <<
        skel := cdr skel;
        if oddp(expnt) then thesign := - thesign
        else rplacd(cdr skel, subst('!-, '!+, cdr skel));
        >>
      else
        skel := cdr skel;
      if (car skel > maxind) then maxind := car skel;
      skel := cadr skel;
      if expnt neq 1 then
        rplaca(skel, {'expt, car skel, expnt});
      sklist := skel . sklist;
      >>;
    >>;
  if null sf then return nil;
  sklist := reverse((sf . nil) . sklist);
  %% regroup factors with identical skeletons
  skprod := dv_skelprod(sklist, maxind);
  if null skprod then return nil;
  sklist := car skprod;
  if maxind > 0 then
    <<
    g_sc_ve := cddr skprod;
    g_init_stree := cadr skprod;
    aut_sc := sc_create(upbve(g_sc_ve));
    comp_info := mkve(3);
    putve(comp_info, 2, mkve(upbve(g_sc_ve)));
    comp_info := {1, comp_info, nil};
    pst := pst_mkpst(g_init_stree);
    tmp := list2vect!*(car pst,'symbolic);
    g_skip_to_level := 1;
    if car pst then
      comp_info := dv_compare(tmp, comp_info, 1, upbve(g_sc_ve));
    if cdr pst then
      comp_info := dv_next_choice(aut_sc, tmp, pst, comp_info);
    if g_skip_to_level = 0 then return nil;
    can_kern := pa_part2list(venth(cadr comp_info, 3));
    count := 0;
    new_dvnames := nil;
    for each elt in can_kern do
      <<
      count := count + 1;
      if elt neq count then
        new_dvnames := (elt . count) . new_dvnames;
      >>;
    >>;
  for each cell in sklist do
    <<
    factlst := nil;
    skel := car cell;
    if cadr cell then
     <<
     for each stree in cdr cell do
       <<
       fact := dv_skel2factor( (skel . stree), new_dvnames);
       if car fact = -1 then
         thesign := - thesign;
       factlst := (cdr fact) . factlst;
       >>;
     factlst := reverse factlst;
     if flagp(dv_cambhead skel, 'anticom) then
       <<
       sorted_factlst := ad_signsort(factlst, 'idcons_ordp);
       thesign := thesign * car sorted_factlst;
       sorted_factlst := cdr sorted_factlst;
       >>
     else
       sorted_factlst :=  sort(factlst, 'idcons_ordp);
     res := append(res, sorted_factlst);
     >>
   else
     res := append(res, {skel});
    >>;
  %% transform res, list of factors, into standard form
  if thesign = -1 then
    skprod := {'minus, 'times . res}
  else if thesign = 1 then
    skprod := 'times . res
  else
    skprod := 0;
  return !*a2f skprod;
  end;

symbolic procedure dv_skel2factor(skelpair, newnames);
  begin
  scalar stree, dvars;
  if null cdr skelpair then return car skelpair;
  stree := sublis(newnames, cdr skelpair);
  stree := st_ad_numsorttree(stree);
  dvars :=
   for each elt in st_flatten(cdr stree) collect dv_ind2var elt;
  return (car stree . dv_skel2factor1(car skelpair, dvars));
  end;

%%%%%%%%%%%%%%%%%%%%%%% USER INTERFACE %%%%%%%%%%%%%%%%%%%%%%%%%

symbolic procedure canonical sq;
  begin
  scalar
    sf, denom, res, !*distribute;
  res := nil;
  sq := simp!* car sq;
  denom := denr sq;
  on distribute;
  sf := distri_pol numr sq;
  %% process each monomial in sf
  while not domainp(sf) do
    <<
    res := addf(res, dv_canon_monomial(lt sf .+ nil));
    sf := red sf;
    >>;
  res := addf(res,sf);
  %% simplify the whole thing, and return
  return simp!*( {'!*sq, res ./ denom, nil} )
  end;

put ('canonical, 'simpfn, 'canonical);

flag('(symtree),'opfn);

symbolic procedure symtree (name, s);
  <<
  put (name, 'symtree, alg_to_symb s);
  >>;

symbolic procedure remsym u;
% ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES.
 for each j in u do
   if flagp(j,'symmetric) then remflag(list j,'symmetric)
     else
   if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric)
     else remprop(j,'symtree); 

symbolic procedure dummy_names u;
 <<if g_dvbase then msgpri("The created dummy base",g_dvbase,
                           "must be cleared",nil,t);
    g_dvnames := list2vect!*(u,'symbolic);
   flag(u, 'dummy);
  t>>;

rlistat '(dummy_names);

 symbolic procedure show_dummy_names;
  if g_dvnames then symb_to_alg vect2list g_dvnames
     else symb_to_alg list('list); 

symbolic procedure dummy_base u;
 if g_dvnames then 
     msgpri("Named variables",symb_to_alg vect2list g_dvnames,
                            "must be eliminated",nil,t)
   else g_dvbase := u;

symbolic procedure clear_dummy_base;
<< g_dvbase := nil;t>>;

symbolic procedure clear_dummy_names;
<< g_dvnames := nil;t>>;

flag ('(show_dummy_names clear_dummy_names dummy_base 
                                   clear_dummy_base), 'opfn);

deflist(
  '((clear_dummy_base endstat) (clear_dummy_names endstat)),'stat);

symbolic procedure anticom u;
 << for each x in u do  
  <<flag(list x, 'anticom); flag(list x, 'noncom)>>;	
  t>>;

symbolic procedure remanticom u;
% ALLOWS TO ELIMINATE THE DECLARED anticom flag.
% Operators becomes COMMUTATIVE operators.
 <<
 for each x in u do 
      <<remflag(x,'noncom); remflag(x,'anticom)>>;
    t>>;

deflist('((anticom rlis) (remanticom rlis)),'stat);

endmodule;

end;