reduce-historical/r38/packages/hephys/cvitmap.red

module cvitmap;

  exports calc_spur$
  imports simp!*,reval,calc_map_tar ,calc_den_tar,spaces$

% SIMP!* AND REVAL REDUCE SYSTEM GENERAL FUNCTIONS FOR
% EVALUATING ALGEBRAIC EXPRESSIONS.

%*********************************************************************
%                                                                    *
%                        FOR CVITANOVIC GAMMA MATRICES               *
%                                CALCULATIONS                        *
%                                                                    *
%                                                                    *
%                       18.03.88  10.06.90  15.06.90 31.08.90        *
%                       01.09.90  11.09.90  14.09.90                 *
%********************************************************************$
 lisp$
 % 07.06.90 all MAP was replaced by MAP_ 
 % 07.06.90 all DEN was replaced by DEN_ 
 % 07.06.90 all PROP was replaced by PROP_ 
 % SOME FUNCTIONS WAS MOVED TO SMACRO SECTION  08.06.90 10.06.90

%**********************************************************************
%                                                                     *
%                      _DATA_STRUCTURE                                *
%                                                                     *
%    WORLD::=(EDGELIST,VARIANTS,WORLD1)                               *
%    WORLD1::=(MAP_2,COEFF,DEN_OM)                                    *
%    MAP_2::=(MAP_S,VARIANTS,PLAN)                                    *
%    MAP_S::=(EDGEPAIR . GSTRAND)                                     *
%    MAP_1::=(EDGEPAIR . MAP_)                                        *
%    EDGEPAIR::=(OLDEDGELIST . NEWEDGELIST)                           *
%    COEFF::=LIST OF WORLDS (UNORDERED)                               *
%    ATLAS::=(MAP_,COEFF,DEN_OM)                                      *
%    MAP_::=LIST OF VERTICES (UNORDERED)                              *
%    VERTEX::=LIST OF EDGES (CYCLIC ORDER)                            *
%    VERTEX::=(NAME,PROP_ERTY,TYPE)                                   *
%    NAME::=ATOM                                                      *
%    PROP_ERTY::= (FIRSTPARENT . SECONDPARENT)                        *
%    TYPE::=T OR NIL                                                  *
%                                                                     *
%*********************************************************************$

%========================== PREDICATES =============================$


symbolic procedure is_indexp x$  % 01.09.90 RT
    (lambda z$
       z and cdr z)   
     assoc(s_edge_name x,dindices!*)$
     
symbolic procedure mk_edge_name (name1,name2)$
% GENERATE NEW EDGE NAME $
<< n_edge := n_edge +1$
%INTERN COMPRESS APPEND(MK_NAME1 NAME1,
        compress append(mk_name1 name1,
                        append ( mk_name1 n_edge ,
                                 mk_name1 name2)) >> $

symbolic procedure new_edge (fedge,sedge)$
% GENERATE NEW EDGE $
begin
 scalar s$
 s:=
 mk_edge ( mk_edge_name ( s_edge_name fedge,
                          s_edge_name sedge),
            mk_edge_prop_ ( s_edge_name fedge,
                            s_edge_name sedge),
            mk_edge_type ( nil,
                           nil))$
 %          MK_EDGE_TYPE ( S_EDGE_TYPE FEDGE,
 %                         S_EDGE_TYPE SEDGE))$
 new_edge_list := s . new_edge_list $
 return s
 end$

symbolic procedure delete_vertex (vertex,map_)$
%DELETS VERTEX FROM MAP_$
if p_empty_map_ map_ then mk_empty_map_ ()
else
  if p_eq_vertex (vertex,s_vertex_first map_)
    then s_map__rest map_
  else
    add_vertex (s_vertex_first map_,
                 delete_vertex (vertex,s_map__rest map_))$

%====================== PREDICATES (CONTINUE) =====================$

symbolic procedure p_eq_vertex (vertex1,vertex2)$
% VERTICES ARE EQ IF THEY HAVE EQUAL NUMBER OF EDGES
% IN THE SAME ORDER WITH EQUAL _NAMES $
if p_empty_vertex vertex1 then p_empty_vertex vertex2
else
 if p_empty_vertex vertex2 then nil
 else
   if equal_edges (first_edge vertex1,
                    first_edge vertex2)
      then p_eq_vertex (s_vertex_rest vertex1,
                          s_vertex_rest vertex2)
   else nil$

%::::::::::::::::::::::: SOME ROUTINES :::::::::::::::::::::::::::::$

symbolic procedure mk_old_edge x$
 begin
  scalar s$
  s:=assoc(x,old_edge_list )$
  if s then return s$
  s:=mk_edge ( x,
                if not gamma5p x
                   then  mk_edge_prop_ (1,1)           %10.06.90 RT 
                else     mk_edge_prop_ (ndim!*,ndim!*),
                mk_edge_type (t,t))$
 old_edge_list :=cons(s,old_edge_list )$
 return s
 end$

symbolic procedure change_name (name,edge)$
% CHANGES EDGE'S NAME $
mk_edge (name,
          s_edge_prop_ edge,
          s_edge_type edge )$

%======================= PREDICATES (CONTINUE) ================== $

symbolic procedure is_tadpole vertex$    %11.09.90 RT
% RETURNS T IF THERE IS ONLY ONE EXTERNAL LEG
    is_tadpolen(vertex) < 2$

symbolic procedure is_tadpolen vertex$    %11.09.90 RT
% RETURNS NUMBER OF EXTERNAL LEGS
  vertex_length diff_legs(vertex,mk_empty_vertex())$

symbolic procedure diff_legs(vertex,vertex1)$  %11.09.90 RT
% RETURNS LIST OF EXTERNAL LEGS
  if p_empty_vertex vertex then vertex1 
  else  if p_member_edge(first_edge vertex,
                          s_vertex_rest vertex)
                      or
           p_member_edge(first_edge vertex,
                           vertex1)
           then diff_legs(s_vertex_rest vertex,vertex1)
         else  diff_legs(s_vertex_rest vertex,
                   add_edge(first_edge vertex,vertex1))$
    
  
symbolic procedure is_buble (vertex1,vertex2)$
% RETURNS NIL IF VERTEX1 AND VERTEX2 DOES NOT FORMED A BUBLE,
% OR N . MAP_ ,WHERE N IS A NUMBER OF EXTERNAL LINES ( 0 OR 2 ),
% MAP_ IS A MAP_ CONTAINING THIS BUBLE $
%NOT(IS_TADPOLE VERTEX1) AND NOT(IS_TADPOLE VERTEX2) AND  %14.09.90 RT
(lambda z$ if z >= 2 then nil
           else (2*z) . mk_vertex2_map_ (vertex1,vertex2))
vertex_length ( diff_vertex (vertex1,vertex2))$

%^^^^^^^^^^^^^^^^^^^^^^^ MAIN PROGRAM ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^$

symbolic procedure transform_map_ map_$
% GENERATE SIMPLE MAP_ (ONLY PRIMITIVE VERTICES) FROM INITIAL ONE$
begin
 scalar n_edge$
 n_edge := 0$
 new_edge_list :=nil$
 old_edge_list :=nil$
return
mk_simple_map_
(for each vertex in map_ collect
   prepare_map_ vertex)$
end$


%,,,,,,,,,,,,,,,,,,,,,RODIONOV & TARANOV INTERFACE ,,,,,,,,,,,,,,,$

global '(bubltr freemap_)$

symbolic procedure to_taranov map_$
% MAP_ IS INITIAL MAP_,
% RETURNS (FULL LIST OF EDGES (INITIAL AND GENERATED) .
%         (MAP_ OF PRIMITIVE VERTICES )  .
%         (LIST OF ALL POSSIBLE ENUMERATION OF MAP_'S EDGES) $
begin
  scalar new_edge_list ,old_edge_list ,full_edge_list ,
         new_map_ ,free_map_ ,marks ,variants ,alst ,bubles$
  new_map_ :=transform_map_ map_$
  free_map_ :=find_bubltr new_map_ $
  bubles:=car free_map_ $
  bubltr:=bubles $
  free_map_ := cdr free_map_ $
  freemap_:=free_map_ $
  full_edge_list := for each edge in old_edge_list collect
                          s_edge_name edge $
  alst:=nconc(for each x in full_edge_list collect (x . 1) ,
              list('!_0 . 0) ) $                   %ADD EMPTY EDGE $
  marks:=set_mark (new_edge_list ,
                   nil,
                   buble_proves bubles,
                   new_map_ ,
                   add_tadpoles (bubles,alst))$
 variants:=edge_bind (marks,alst)$
  full_edge_list :=nconc (for each edge in new_edge_list collect
                              s_edge_name edge,
                          full_edge_list )$
return full_edge_list .
       new_map_ .
       variants
end$


 % TEST TEST TEST  TEST TEST TEST TEST TEST TEST TEST $
 % TO_TARANOV '((A B C C B A)) $


%END$    %cvit2.red
%********************************************************************
%                     NOW WE MARKED THE MAP_                        *
%*******************************************************************$

                  % 09.03.88  $
lisp$

global '(ndim!* )$

%ERROERRORERRORERRORERROR ERROR ROUTINES ERRORERRORERRORERRORERROR $

global '(!*cviterror)$

flag('(cviterror),'switch)$

!*cviterror:=t$           % IF T THEN ERROR MESSAGES WILL BE PRINTED$

% The FEXPR for set_error has been re-written by JPff
%%%  symbolic fexpr procedure set_error u$
%%%  if !*cviterror then set_error0 (u,alst)
%%%  else
%%%     error(55,"ERROR IN MAP_ CREATING ROUTINES")  $
symbolic macro procedure set_error u$
   list('set_error_real,mkquote cadr u,cons('list,cddr u))$

symbolic procedure set_error_real (u,v)$
<<
   if !*cviterror then <<
     prin2 "Function: "$
     prin2 car u$
     prin2 " Arguments: "$
     if v then for each x in v do <<
        prin2 x$ prin2 " IS " $
        prin2 x$
        terpri()  >>;
    >>;
    error(55,"Error in MAP_ creating routines")
>>$
   
%ERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERE$

symbolic procedure mark_edges (newedges,oldedges,map_)$
  mk_proves (map_,oldedges) .
  set_mark (newedges,nil,nil,map_,
             for each x in oldedges collect (s_edge_name x .
                                             car s_edge_prop_ x ) ) $

symbolic procedure mk_proves (map_,oldedges)$
if p_empty_map_ map_ then nil
else
  if defined_vertex (s_vertex_first map_,oldedges) then
      s_vertex_first map_ .
      mk_proves (s_map__rest map_,oldedges)
  else
      mk_proves (s_map__rest map_,oldedges)$

symbolic procedure defined_vertex (vertex,oldedges)$
if p_empty_vertex vertex then t
else
 memq_edgelist (first_edge vertex,oldedges)
                and
 defined_vertex (s_vertex_rest vertex,oldedges)$

symbolic procedure set_mark (edges,notdef,toprove,map_,blst)$
% EDGES - LIST OF NEW EDGES CREATED WHILE MAKING A MAP_,
% NOTDEF - LIST OF EDGES WHICH CANNOT BE FULLY IDEN_TIFY,
% TOPROVE - LIST OF VERTICES FOR CHECKING TRIANGLE RULE,
% MAP_ - MAP_ CREATED EARLIER,
% BLST - ALIST OF BINDED EDGES$
if null edges then
    if notdef or toprove then          % 15.06.90 RT
		 set_error_real('set_mark,
				list(edges,notdef,toprove,map_,blst))
    else nil
else
  (lambda z$
      if z then                  %THE EDGE IS FULLY DEFINED$
         set_prove (append(notdef,            %RESTOR LIST OF EDGES$
                            cdr edges),
                     car edges,
                     append(new_prove (car edges,    %ADD CHECKS$
                                        map_),
                            toprove),
                     map_,
                     (s_edge_name car edges . 0) .
                     blst)
     else
         set_mark (cdr edges,                   %TRY NEXT$
                    car edges . notdef,         % ADD NOT DEF. LIST$
                    toprove,
                    map_,
                    blst))
    ( assoc(caadar edges,blst)          %CHECK IF BOTH PARENT IS $
             and                        %ALREADY DEFINED         $
      assoc(cdadar edges,blst) ) $

symbolic procedure new_prove (edge,map_)$
% RETURNS NEW VERTEX FOR TRIANGLE RULE CHECKING LIST$
if null map_ then nil
else
  (lambda z$  if z then list z
              else new_prove (edge,cdr map_))
   new_provev (edge,car map_) $

 symbolic procedure new_provev (edge,vertex)$
 % CAN THIS VERTEX BE UTILIZED FOR CHECKING ? $
 if not member(edge,vertex) then nil
 else
  if (assoc(caadr edge,vertex)
           and
      assoc(cdadr edge,vertex))
    then nil
  else vertex $

symbolic procedure is_son (edge,vertex)$
 assoc(car s_edge_prop_ edge,vertex)$

symbolic procedure not_parents (edge,proves)$
if null proves then nil
else
  if is_son (edge,car proves)
     then cdr proves
  else car proves . not_parents (edge,cdr proves)$

symbolic procedure set_prove (edges,edge,toprove,map_,blst)$
% RETURNS A PAIR (EDGE . (LIST FOF VERICES FOR TRIANGLE RULE TEST))$
(lambda z$
   (edge . not_parents (edge,car z)) .
    set_mark (edges,nil,cdr z,map_,blst))
  find_proved (toprove,nil,nil,blst)$

symbolic procedure find_proved (toprove,proved,unproved,blst)$
% RETURNS A PAIR ((LIST OF ALREADY DEFINED VERTICES) .
%                 (LIST OF NOT YET DEFINED EDGES) ) $
if null toprove then proved . unproved
else
  if is_proved (car toprove,blst) then
                   find_proved (cdr toprove,
                                 car toprove . proved,
                                  unproved,
                                  blst)
  else             find_proved (cdr toprove,
                                 proved,
                                 car toprove . unproved,
                                 blst) $

symbolic procedure is_proved (vertex,blst)$
 if null vertex then t
 else if assoc(caar vertex,blst) then is_proved (cdr vertex,blst)
      else nil $

%@@@@@@@@@@@@@@@@@@@@@@@ NOW GENERATES ALL POSSIBLE NUMBERS @@@@@@@@$

symbolic procedure mk_binding (provedge,blst)$
 can_be_proved (car provedge,blst)
             and
 edge_bind (cdr provedge,blst)$

symbolic procedure edge_bind (edgelist,blst)$
if null edgelist then list blst
else
 begin
   scalar defedge,prop_,p,emin,emax,s,proves,i$
% DEFEDGE - EDGE WITH DEFINED RANG,
% PROP_ - ITS PROP_ERTY: (NUM1 . NUM2),
% P - ITS NAME,
% EMIN AND EMAX - RANGE OF P,
% S - TO STORE RESULTS,
% PROVES - CHECKS OF TRIANGLE LAW$
  defedge:=car edgelist$
  proves:=cdr defedge$
  defedge:=car defedge$
  edgelist:=cdr edgelist$
  p:=s_edge_name defedge$
  prop_:=s_edge_prop_ defedge$
  emin:=assoc(car prop_,blst)$
  emax:=assoc(cdr prop_,blst)$
 if null emin or null emax
   then set_error_real ('edge_bind,list(prop_,blst))$
 prop_:=(cdr emin) . (cdr emax)$
  emin:=abs((car prop_)-(cdr prop_))$
  emax:=(car prop_)+(cdr prop_)$
 if numberp ndim!* then              %NUMERICAL DIMENSIONAL$
    << emax:=min(emax,ndim!*)$
       if emin > ndim!* then return nil >> $
 i:=emin$
loop:
       if i > emax then return s$
       if can_be_proved (proves,(p . i) . blst)
         then s:=append(edge_bind (edgelist,
                                    (p . i) . blst),
                        s) $
       i:=i+2$
 go loop
end$

symbolic procedure can_be_proved (proves,blst)$
if null proves then t
else if can_be_p (car proves,blst) then
        can_be_proved (cdr proves,blst)
     else nil$

symbolic procedure can_be_p (vertex,blst)$
%CHECKS TRIANGLE RULE$
begin
  scalar i,j,k$
  i:=assoc(car car   vertex,blst)$
  j:=assoc(car cadr  vertex,blst)$
  k:=assoc(car caddr vertex,blst)$
  if null i or null j or null k then set_error_real('can_be_proved,
						     list(vertex,%%edge,
						     blst))$
  i:=cdr i$
  j:=cdr j$
  k:=cdr k$
  if numberp ndim!* and (i+j+k) > (2*ndim!*) then
    return nil $                           %SINCE S+T+U<NDIM!* $
 % ======== NOW CHECK TRIANGLE RULE ======= $
  return
        if not evenp(i+j+k) or
           k < abs(i-j)     or
           k > (i+j)
         then nil
        else t
end$

%END$  %cvit4.red
%OOOOOOOOOOOOOOOOOOOOOOOOO ROUTINES TO SELECT BUBLES OOOOOOOOOOOOOOOO$

lisp$                                   %24.05.88$

symbolic procedure find_bubles atlas$
 find_bubles1 (atlas,old_edge_list )$

symbolic procedure find_bubles_coeff (atlaslist,edgelist,bubles)$
%F NULL BUBLES THEN NIL . ATLASLIST
%LSE
 find_bubles1_coeff (atlaslist,nil,edgelist,bubles)$

symbolic procedure find_bubles1_coeff (atlaslist,passed,edgelist,
                                                          bubles)$
if null atlaslist then bubles . passed
else
 (lambda z$             %Z - PAIR = (BUBLES . REDUCED MAP_)
    find_bubles1_coeff (cdr atlaslist,
                          cdr z . passed,
                          edgelist,
                          if null car z then bubles else
                          car z . bubles) )
  find_bubles1 (car atlaslist,edgelist) $

symbolic procedure mk_atlaslist (map_,coeff,den_om)$
 list mk_atlas (map_,coeff,den_om)$

symbolic procedure find_bubles1 (atlas,edgelist)$
  select_bubles (nil,
                 s_atlas_map_ atlas,
                 nil,
                 s_atlas_coeff atlas,
                 s_atlas_den_om atlas,
                 edgelist)$

symbolic procedure select_bubles(bubles,map_,passed,coeff,den_om,al)$
% RETURNS (LIST OF BUBLES ) . ATLAS,
% WHERE BUBLES ARE TWO OR ONE VERTICES MAP_S $
if p_empty_map_  map_ then
             (lambda x$
                     car x .
                           mk_atlas (passed,cdr x,den_om))
              find_bubles_coeff (coeff,
                                 union_edges (map__edges passed,
                                              al),
                                 bubles)
else
 if (map__length map_ + map__length passed) < 3 then
         select_bubles (bubles,
                        mk_empty_map_ (),
                        append_map_s(map_,
                                     passed),
                        coeff,
                        den_om,
                        al)
 else
  (lambda z$                          % Z IS NIL OR A PAIR
                                      % N . MAP_ ,WHERE
                                      % N - NUMBER OF FREE EDGES$
     if z then                                      %A BUBLE IS FIND$
      (lambda d$
       (lambda bool$              %BOOL=T IFF ALL EDGES CAN BE DEFINED$
      if car z = 0 then                             %NO EXTERNAL LINES$
       if bool then
        select_bubles ( z . bubles,
                         mk_empty_map_ (),
                         cdr z,
                         mk_atlaslist ( conc_map_s (passed,
                                                    delete_vertex (
                                                      s_vertex_second
                                                                cdr z,
                                                      s_map__rest
                                                                map_)),
                                         coeff,
                                         den_om),
                         nil,
                         al)
       else
        select_bubles ( z . bubles,               %ADD BUBLE$
                         delete_vertex (s_vertex_second cdr z,
                                         s_map__rest map_),
                         passed,
                         try_sub_atlas (mk_atlas (cdr z,
                                                  nil,
                                                  nil),
                                        coeff),
                         den_om,
                         al)
      else
       if not p_old_vertex d then
        if bool then
        select_bubles (z . bubles,
                        mk_empty_map_ (),
                        cdr z,
                        mk_atlaslist (conc_map_s (passed,
                                                  buble_vertex (
                                                    cdr z,
                                                    delete_vertex (
                                                     s_vertex_second
                                                        cdr z,
                                                     s_map__rest
                                                        map_ ),
                                                     al)),
                                       coeff,
                                       den_om),
                         list d,
                         al)
        else
        select_bubles ( z . bubles,               %ADD NEW BUBLE$
                        buble_vertex (cdr z,      %RENAME EDGES $
                             conc_map_s (passed,
                             delete_vertex (s_vertex_second cdr z,
                                            s_map__rest map_)),
                                        al),
                         mk_empty_map_ (),
                         try_sub_atlas (mk_atlas (cdr z,nil,list d),
                                        coeff),
                         den_om,
                         al)
       else
        if bool then
        select_bubles (z . bubles,
                        mk_empty_map_ (),
                        ren_vertmap_ (d,cdr z),
                        mk_atlaslist (
                          conc_map_s (
                            passed,
                            add_vertex (add_edge (!_0edge ,d),
                                        delete_vertex (
                                            s_vertex_second cdr z,
                                            s_map__rest map_ ))),
                          coeff,
                          den_om),
                        list ren_vertices (d,d),
                        al)
        else
        select_bubles (z . bubles,
                        add_vertex (add_edge (!_0edge ,d),
				    delete_vertex(s_vertex_second cdr z,
						  s_map__rest map_)
                                    ),
                        passed,
                        try_sub_atlas (mk_atlas (ren_vertmap_
                                                    (d,cdr z),
                                                 nil,
                                                 list
                                                 ren_vertices (d,d)
                                                 ),
                                        coeff),
                        den_om,
                        al )
                                     )
   %      ALL_DEFINED (CDR Z,AL))
          t                           )
        delta_edges cdr z
     else
        select_bubles (bubles,
                       s_map__rest map_,
                       add_vertex (s_vertex_first map_,passed),
                       coeff,
                       den_om,
                       al )
                                )
   find_buble (s_vertex_first map_,
               s_map__rest map_ ) $

symbolic procedure p_old_vertex vertex$
% RETURNS T IFF ALL EDGES OF VERTEX ARE OLD OR VERTEX IS EMPTY ONE$
if p_empty_vertex vertex then t
else p_old_edge first_edge vertex
             and
     p_old_vertex s_vertex_rest vertex$

symbolic procedure renames_edges (vertex,al)$
rename_edges_par (first_edge vertex,
                    second_edge vertex,
                    al)$

symbolic procedure rename_edges_par (vertex1,vertex2,al)$
% Here VERTEX1 and VERTEX2 are edges!
if   defined_edge (vertex1,al)
     and not p_old_edge(vertex2)  then        % 14.09.90 RT
       replace_edge (vertex2,vertex1,new_edge_list )
else
  if defined_edge (vertex2,al) 
     and not p_old_edge(vertex1)  then        % 14.09.90 RT
       replace_edge (vertex1,vertex2,new_edge_list )
  else
    if  p_old_edge (vertex1)
        and not p_old_edge(vertex2)  then        % 14.09.90 RT
         replace_edge (vertex2,vertex1,new_edge_list )
    else
      if p_old_edge (vertex2) 
         and not p_old_edge(vertex1)  then        % 14.09.90 RT
          replace_edge (vertex1,vertex2,new_edge_list )
      else rename_edges (vertex1,vertex2)$

symbolic procedure buble_vertex (map_2,map_,al)$
if p_empty_map_ map_2 then mk_empty_map_ ()
else
  << renames_edges (delta_edges map_2,al)$
     map_ >> $

symbolic procedure delta_edges map_2$
% MAP_2 - MAP_ OF TWO VERTICES $
mk_edge2_vertex (
                   first_edge
                               diff_vertex (s_vertex_first map_2,
                                            s_vertex_second map_2),
                   first_edge
                               diff_vertex (s_vertex_second map_2,
                                            s_vertex_first map_2 )
                  )$

symbolic procedure delta_names map_2$
% MAP_2 - MAP_ OF TWO VERTICES $
(lambda z$
     s_edge_name first_edge car z .
     s_edge_name first_edge cdr z  )
 (diff_vertex (s_vertex_first map_2,
               s_vertex_second map_2) .
  diff_vertex (s_vertex_second map_2,
               s_vertex_first map_2) ) $

symbolic procedure old_rename_edges (names,map_)$
if p_empty_map_ map_ then mk_empty_map_ ()
else add_vertex (ren_edge (names,s_vertex_first map_),
                 old_rename_edges (names,
                                s_map__rest map_) ) $

symbolic procedure ren_vertmap_ (vertex1,map_)$
% VERTEX1 MUST BE TWO EDGE VERTEX,
% EDGES OF VERTEX2 TO BE RENAME$
if vertex_length vertex1 neq 2 then set_error_real ('ren_vertmap_  ,
                                                     list(vertex1,map_))
else old_rename_edges (s_edge_name first_edge vertex1 .
                       s_edge_name second_edge vertex1,
                       map_)$

symbolic procedure ren_vertices (vertex1,vertex2)$
% VERTEX1 MUST BE TWO EDGE VERTEX,
% EDGES OF VERTEX2 TO BE RENAME$
if vertex_length vertex1 neq 2
  then set_error_real ('ren_vertices,list(vertex1,vertex2))
else ren_edge (s_edge_name first_edge vertex1 .
               s_edge_name second_edge vertex1,
               vertex2)$

symbolic procedure ren_edge (names,vertex)$
% NAMES IS NAME1 . NAME2,
% CHANGE NAME1 TO NAME2$
if null assoc(car names,vertex) then vertex  %NO SUCH EDGES IN VERTEX$
else ren_edge1 (names,vertex)$

symbolic procedure ren_edge1 (names,vertex)$
if p_empty_vertex vertex then mk_empty_vertex ()
else if car names =s_edge_name first_edge vertex then
        add_edge ( change_name (cdr names,first_edge vertex),
                   ren_edge1 (names ,s_vertex_rest vertex))
     else
        add_edge ( first_edge vertex,
                   ren_edge1 (names,s_vertex_rest vertex))$

symbolic procedure find_buble (vertex,map_)$
if p_empty_map_ map_ then mk_empty_map_ ()
else
  is_buble (vertex,s_vertex_first map_)
  or
  find_buble (vertex,s_map__rest map_) $

symbolic procedure diff_vertex (vertex1,vertex2)$
if p_empty_vertex vertex1 then mk_empty_vertex ()
else
  if p_member_edge (first_edge vertex1,vertex2)
                    and
      not equal_edges (first_edge vertex1,!_0edge )
     then diff_vertex (s_vertex_rest vertex1,vertex2)
  else
    add_edge (first_edge vertex1,
              diff_vertex (s_vertex_rest vertex1,vertex2)) $

%SSSSSSSSSSSSSSSSSSSSSSSSSS NOW MAKES PROVES FROM BUBLE PPPPPPPPPPPPPP$

global '(!_0edge )$

!_0edge :=mk_edge ('!_0 ,
                   mk_edge_prop_ (0,0),
                   mk_edge_type (t,t)) $

symbolic procedure buble_proves bubles$
if null bubles then nil
else
  if caar bubles = 0                           %NO EXTERNAL LINES $
    then buble_proves cdr bubles
  else if caar bubles = 2 then
       mk_edge3_vertex (
                          first_edge diff_vertex (
                                      s_vertex_first cdar bubles,
                                      s_vertex_second cdar bubles),
                          first_edge diff_vertex (
                                      s_vertex_second cdar bubles,
                                      s_vertex_first cdar bubles),
                          !_0edge ) .
                                      buble_proves cdr bubles
        else
         if caar bubles = 3 then
               car cdar bubles .
                                 buble_proves cdr bubles
         else buble_proves cdr bubles $


symbolic procedure try_sub_atlas (atlas,atlaslist)$
if null atlaslist then list atlas
else
  if sub_map__p (s_atlas_map_ atlas,
                 s_atlas_den_om car atlaslist)
   then try_sub_atlas (mk_sub_atlas (atlas,car atlaslist),
%  THEN TRY_SUB_ATLAS (MK_SUB_ATLAS (CAR ATLASLIST,
%                                        ATLAS        ),
                         cdr atlaslist)
  else  car atlaslist .
        try_sub_atlas (atlas,cdr atlaslist)$

symbolic procedure sub_map__p (map_1,den_)$
%MAP_1 AND DEN_  HAVE COMMON VERTEX (DEN_ - DEN_OMINATOR)$
if p_empty_map_ map_1 then nil
else  sub_vertex_map_ (s_vertex_first map_1,den_)
                    or
      sub_map__p (s_map__rest map_1,den_)$

symbolic procedure sub_vertex_map_ (vertex,den_)$
if null den_ then nil
else p_common_den_ (vertex,car den_)
                  or
     sub_vertex_map_ (vertex,cdr den_)$

symbolic procedure  p_common_den_ (vertex,vertexd)$
(lambda n$
    if n = 3 then                                %TRIANGLE
             p_eq_vertex (vertex,vertexd)

    else
      if n = 2 then                              %KRONEKER
             p_member_edge (first_edge vertexd,vertex)
      else nil )
  vertex_length vertexd $

symbolic procedure mk_sub_atlas (atlas1,atlas2)$
 mk_atlas (s_atlas_map_ atlas1,
           atlas2 . s_atlas_coeff atlas1,
           s_atlas_den_om atlas1)$

symbolic procedure all_defined (map_,al)$
 all_defined_map_ (map_,
                   defined_append(map__edges map_,al))$

symbolic procedure all_defined_map_ (map_,al)$
 al1_defined_map_ (map_,mk_empty_map_ (),al)$

symbolic procedure al1_defined_map_ (map_,passed,al)$
% T IF ALL EDGES IN MAP_ CAN BE DEFINED $
if p_empty_map_ map_ then
 if p_empty_map_ passed then t
 else nil
else
 if all_defined_vertex (s_vertex_first map_,al) then
     al1_defined_map_ (conc_map_s(passed,s_map__rest map_),
                       mk_empty_map_ (),
                       append(vertex_edges s_vertex_first map_ ,al))
 else
     al1_defined_map_ (s_map__rest map_,
                       add_vertex (s_vertex_first map_,passed),
                       al)$

symbolic procedure all_defined_vertex (vertex,al)$
 al1_defined_vertex (vertex,mk_empty_vertex (),
                            mk_empty_vertex (),al)$

symbolic procedure al1_defined_vertex (vertex,passed,defined,al)$
% T IF ALL EDGES IN VERTEX CAN BE DEFINED $
if p_empty_vertex vertex then
 if p_empty_vertex passed then t
 else re_parents (passed,defined)
else
  if defined_edge (first_edge vertex,al)
                    then
     al1_defined_vertex (conc_vertex(passed,s_vertex_rest vertex),
                         mk_empty_vertex (),
                         add_edge (first_edge vertex,defined),
                         first_edge vertex . al)
  else
     al1_defined_vertex (s_vertex_rest vertex,
                         add_vertex (first_edge vertex,passed),
                         defined,
                         al)$

symbolic procedure re_parents (passed,defined)$
%TRY TO MAKE NEW PARENTS
if vertex_length passed = 1 and vertex_length defined = 2
  then make_new_parents (first_edge passed,defined)
else nil$

symbolic procedure make_new_parents (edge,vertex)$
%VERTEX CONSISTS OF TWO EDGES
 add_parents0 (edge,
               s_edge_name first_edge vertex .
               s_edge_name second_edge vertex ,
               t)$


%^.^.^.^.^.^.^.^.^.^.^.^.^.^.^..^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^
%          13.05.88


symbolic procedure p_def_edge edge$
 s_edge_type edge$
%P_OLD_EDGE EDGE$

symbolic procedure defined_edge (edge,al)$
  p_old_edge edge
      or
 defined_all_edge (all_edge (s_edge_name edge,new_edge_list ),
                   nil,
                   al) $

symbolic procedure all_edge (edgename,edgelist)$
if null edgelist then nil
else
  if edgename eq s_edge_name car edgelist then
                 car edgelist . all_edge (edgename,cdr edgelist)
  else all_edge (edgename,cdr edgelist)$

symbolic procedure def_edge (edge,al)$
(lambda z$
          assoc(car z,al) and assoc(cdr z,al))
 s_edge_prop_ edge$

symbolic procedure defined_all_edge (edgelist,passed,al)$
if null edgelist then nil
else
  if def_edge (car edgelist,al) then
    if p_def_edge car edgelist then t  %REPLACE WAS ALREADY DONE
    else  rep_edge_prop_ (nconc(passed,edgelist),
                          s_edge_prop_ car edgelist . list t)
  else defined_all_edge (cdr edgelist,
                         car edgelist . passed,
                         al)$

symbolic procedure rep_edge_prop_ (edgelist,prop_)$
if null edgelist then t
else << rplacd(car edgelist,prop_)$           %CHANGE EDGE PARENTS
        rep_edge_prop_ (cdr edgelist,prop_) >> $



%END$  %cvit6.red
%<><><><><><><><><><><> ROUTINES FOR SELECTING TRIANGLES <><><><><><>$
                            %24.05.88$

global '(!*cvitbtr !*cviterror)$

flag('(cvitbtr),'switch)$

!*cvitbtr:=t$           %IF T THEN BUBLES AND TRIANGLES  WILL BE
                        %     FACTORIZED

!*cviterror:=t$         %IF T THEN ERROR MESSAGES WILL BE PRINTED

symbolic procedure find_triangles atlas$
 find_triangles1 (atlas,old_edge_list)$

symbolic procedure find_triangles1 (atlas,al)$
 select_triangles (nil,
                   s_atlas_map_ atlas,
                   nil,
                   s_atlas_coeff atlas,
                   s_atlas_den_om atlas,
                   al)$

symbolic procedure find_triangl_coeff (atlaslist,edgelist,triangles)$
 find_triangle_coeff (atlaslist,nil,edgelist,triangles)$

symbolic procedure find_triangle_coeff(atlaslist,passed,edgelist,
                                         triangles)$
if null atlaslist then triangles . passed
else
 (lambda z$                 % Z - PAIR= (TRIANGLES . REDUCED MAP_)
     find_triangle_coeff (cdr atlaslist,
                          cdr z . passed,
                          edgelist,
                          if null car z then triangles
                          else car z . triangles))
  find_triangles1 (car atlaslist,edgelist)$

symbolic procedure select_triangles (triangles,map_,passed,
                                      coeff,den_om,al)$
%RETURNS A PAIR OF THE FORM ( (LIST OF TRIANGLES) . (ATL.WITHOUT TR.))$
if p_empty_map_ map_ then                       %No triangles found.
      (lambda x$
              car x .
              mk_atlas (passed,cdr x,den_om))
      find_triangl_coeff (coeff,
                          union_edges (map__edges passed,al),
                          triangles)
else
 if (map__length map_ + map__length passed) < 4 then
    select_triangles (triangles,
                      mk_empty_map_ (),
                      append_map_s (map_,passed),
                      coeff,
                      den_om,
                      al)
 else
 (lambda z$
    if z then                                    %TRIANGLE IS FOUND$
     (lambda trn$                                %TRN - NEW VERTEX $
     %IF ALL_DEFINED (CDDR Z,AL) THEN
      if t then
         select_triangles (
             z . triangles,
             mk_empty_map_ (),
             add_vertex (trn,cddr z),
             mk_atlaslist (
                  conc_map_s (
                      mk_vertex1_map_  trn,
                      conc_map_s (passed,delete_map_s (cddr z,map_))
                             ),
                  coeff,
%                 TRN . DEN_OM    ),
                  den_om    ),
%            NIL,
             list trn,
             al             )
       else
       select_triangles ( z . triangles,       %ADD NEW TRIANGLE $
 %     SELECT_TRIANGLES ( CDDR Z . TRIANGLES,  %ADD NEW TRIANGLE$
                           conc_map_s (mk_vertex1_map_
                                       trn,     %ADD NEW VERTEX$
                                       conc_map_s (passed,
						   delete_map_s(cddr z,
								map_)
                                                  )
                                      ),
                          mk_empty_map_ (),
                          try_sub_atlas (
                              mk_atlas (add_vertex (trn,cddr z),
                                        nil,
                                        list trn),
                              coeff       ),
                          den_om,
                          al
                         )
                   )
      sk_vertextr z
    else
       select_triangles (triangles,
                         s_map__rest map_,
                         add_vertex (s_vertex_first map_,passed),
                         coeff,
                         den_om,
                         al
                         ) )
reduce_triangle
 find_triangle (s_vertex_first map_,
                s_map__rest map_) $

symbolic procedure vertex_neighbour (vertex,map_)$
%RETURNS A MAP_ OF VERTEX NEIGHBOURS $
if p_empty_vertex vertex
           or
   p_empty_map_ map_ then mk_empty_map_ ()
else
  (lambda z$             %Z - NIL OR A PAIR (EDGE . ADJACENT EDGE )$
     if z then
        add_vertex (cdr z,
                     vertex_neighbour (delete_edge (car z,vertex),
                                       delete_vertex (cdr z,map_)))
     else
        vertex_neighbour (vertex,s_map__rest map_))
   is_neighbour (vertex,
                  s_vertex_first map_)$

symbolic procedure delete_map_s (map_1,map_2)$
if p_empty_map_ map_1 then map_2
else delete_map_s (s_map__rest map_1,
                   delete_vertex (s_vertex_first map_1,map_2) ) $

symbolic procedure delete_edge (edge,vertex)$
%DELETES EDGE FROM VERTEX $
if p_empty_vertex vertex then mk_empty_vertex ()
else
  if equal_edges (edge,first_edge vertex)
   then s_vertex_rest vertex
  else
    add_edge (first_edge vertex,
               delete_edge (edge,
                            s_vertex_rest vertex ) ) $

symbolic procedure is_neighbourp (vertex1,vertex2)$
% ARE VERTEX1 AND VERTEX2 NEIGHBOURS ?
if p_empty_vertex vertex1 then nil         % NIL IF NOT NEIGHBOURS$
else
     p_member_edge (first_edge vertex1,vertex2)
                    or
     is_neighbourp (s_vertex_rest vertex1,vertex2)$

symbolic procedure is_neighbour (vertex1,vertex2)$
% ARE VERTEX1 AND VERTEX2 NEIGHBOURS ?
% IF THEY ARE THEN RETURN A PAIR: (ADJ.EDGE . VERTEX2)$
if p_empty_vertex vertex1 then nil         % NIL IF NOT NEIGHBOURS$
else
  (lambda z$
     if z then                   %FIRTS VERTEX IS ADJACENT TO VERTEX2$
          first_edge vertex1 . vertex2
     else is_neighbour (s_vertex_rest vertex1,
                         vertex2 ) )
   p_member_edge (first_edge vertex1,
                    vertex2)$

symbolic procedure find_triangle (vertex,map_)$
%FINDS TRIANGLE WICH INCLUDES THE VERTEX.
%RETURNS MAP_ OF THREE VERTICES (TRIANGLE) OR NIL $
(lambda z$               %Z - MAP_ OF VERTICES WICH ARE NEIGHBOURS
                         %  OF VERTEX OR (IF NO NEIGHBOURS) EMPTY MAP_$
   if map__length z neq 2 then nil
   else add_vertex (vertex,z) )
 is_closed vertex_neighbour (vertex,map_)$

symbolic procedure is_closed map_$
if p_empty_map_ map_   or
   p_empty_map_ s_map__rest map_ then mk_empty_map_ ()
else
    two_neighbour (s_vertex_first map_,
                    s_map__rest map_)
             or
    is_closed s_map__rest map_$

symbolic procedure two_neighbour (vertex,map_)$
% HAS VERTEX A NEIGHBOUR IN THE MAP_ ? $
if p_empty_map_ map_ then nil
else
 if is_neighbourp (vertex,s_vertex_first map_)
    then mk_vertex2_map_ (vertex,s_vertex_first map_)
 else two_neighbour (vertex,s_map__rest map_)$

symbolic procedure mk_vertextr map_$
%MAKES VERTEX FROM TRIANGLE MAP_$
if map__length map_ neq 3 then set_error_real ('mk_vertextr ,list(map_))
else
    mk_vertextr3 (map_,3)$

symbolic procedure add_edge1(edge,vertex)$ % 14.09.90 RT
 if null edge then vertex
 else add_edge(edge,vertex)$

symbolic procedure mk_vertextr3 (map_,n)$
if n <= 0 then mk_empty_map_ ()
else
  add_edge1 (take_edge (s_vertex_first map_,
                         s_map__rest map_),
             mk_vertextr3 (cycl_map_ map_,n-1)) $

symbolic procedure take_edge (vertex,map_)$
if p_empty_vertex vertex then nil    %14.09.90 RT
% SET_ERROR ('TAKE_EDGE ,VERTEX,MAP_)    % 14.09.90  RT
else
%  IF P_EMPTY_VERTEX S_VERTEX_REST VERTEX THEN FIRST_EDGE VERTEX
%  ELSE                                     % 14.09.90 RT
    if contain_edge (first_edge vertex,map_)
                 and
       not equal_edges (first_edge vertex,!_0edge )
     then take_edge (s_vertex_rest vertex,map_)
    else first_edge vertex$

symbolic procedure contain_edge (edge,map_)$
% IS THERE A VERTEX IN THE MAP_ CONTAINING THE EDGE? $
if p_empty_map_ map_ then nil
else
    p_member_edge (edge,s_vertex_first map_)
                    or
    contain_edge (edge,s_map__rest map_) $

% ,,,,,,,,,,,,,,,,,,,,,,,,,,,,SORTING AFTER FACTORIZATION ,,,,,,,,,,,$
%      19.05.88 $

symbolic procedure find_bubltr atlas$
if null !*cvitbtr then atlas else
begin
 scalar s$
 s:=errorset(list('find_bubltr0 ,mkquote atlas),
             !*cviterror,
             !*backtrace)$
 return
     if atom s then atlas
     else car s
 end$

symbolic procedure find_bubltr0 atlas$
%(LAMBDA Z$
%    IF CAR Z THEN  SORT_ATLAS CDR Z  %FACTORIZATION HAPPENED
%    ELSE CDR Z)
 sort_atlas cdr
  find_bubltr1 (atlas,old_edge_list )$

% ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,$

symbolic procedure find_bubltr1 (atlas,al)$
%FINDS BOTH BUBLES AND TRIANGLES IN ATLAS$
begin
 scalar s,c,bubles$
 s:=find_bubles1 (atlas,al)$
 c:=car s$
 atlas:=cdr s$
 bubles:=append(c,bubles)$
loop:
 s:=find_triangles1 (atlas,al)$
 c:=car s$
 atlas:=cdr s$
 bubles:=append(c,bubles)$
 if null c then return bubles . atlas$
 s:=find_bubles1 (atlas,al)$
 c:=car s$
 atlas:=cdr s$
 bubles:=append(c,bubles)$
 if null c then return bubles . atlas$
 go loop
end$

symbolic procedure reduce_triangle triangle$
% RETURN (N . VERTEX . TRIANGLE) OR NIL,
% N - NUMBER OF EXTERNAL EDGES$
if null triangle then nil
else
  begin
    scalar extedges,vertex,n$
    %EXTEDGES - LIST OF EXTERNAL EDGES,
    % N - NUMBER OF EXTERNAL EDGES,
    %VERTEX - NEW VERTEX,MADE FROM TRIANGLE$
      vertex:=mk_vertextr triangle$
      extedges:=ext_edges vertex$
      n:=length extedges$
  return
         if n = 1 then nil            % 14.09.90    RT
         else                         % 14.09.90    RT
             n . vertex . triangle
end$

symbolic procedure sk_vertextr z$
% Z IS (N . VERTEX . TRIANGLE) $
if car z = 1 then mk_empty_vertex ()
else
 if car z = 3 then cadr z
 else set_error_real ('sk_vertextr,list z) $

symbolic procedure ext_edges vertex$
%SELECT EXTERNAL EDGES IN VERTEX $
if p_empty_vertex vertex then nil
else
  if p_member_edge (first_edge vertex,s_vertex_rest vertex)
                         or
     equal_edges (first_edge vertex,!_0edge )
   then ext_edges delete_edge (first_edge vertex,
                                 s_vertex_rest vertex)
  else first_edge vertex .
                           ext_edges s_vertex_rest vertex $

symbolic procedure ext_edges_map_ map_$
%SELECT EXTERNAL EDGES OF MAP_$
if p_empty_map_ map_ then nil
else
  ext_map__ver (ext_edges s_vertex_first map_,
                 ext_edges_map_ s_map__rest map_)$

symbolic procedure ext_map__ver (vlist,mlist)$
if null vlist then mlist
else
  if memq(car vlist,mlist) then
       ext_map__ver (cdr vlist,
                      delete(car vlist,mlist))
  else ext_map__ver (cdr vlist,car vlist . mlist)$

symbolic procedure add_tadpoles (bubles,alst)$
if null bubles then alst
else
  if caar bubles = 1 then
       add_tadpoles (cdr bubles,
                      cons(cons(car mk_vertextr cadr car bubles,
                                0),
                           alst))
   else add_tadpoles (cdr bubles,alst)$


%END$  %cvit8.red
%::::::::::::::::::::::: ATLAS SORTING ROUTINES ********************** $
% 13.06.88$

lisp$

global '(!*cvitrace)$

!*cvitrace:=nil$  %IF T THEN TRACE BACTRAKING WHILE ATLAS SORTING$

 flag('(cvitrace),'switch)$

symbolic procedure sort_atlas atlas$
%TOP LEVEL PROCEDURE
if null atlas then atlas
else
 (lambda z$
   if z then z        %ATLAS FULLY SORTED
   else set_error_real ('sort_atlas ,list atlas))
  sort_atlas1 atlas $

symbolic procedure sort_atlas1 atlas$
(lambda z$
   if z then z          %ATLAS FULLY SORTED
   else
     if !*cviterror then print_atlas_sort (atlas,nil)
     else nil )
 atlas_sort (atlas,old_edge_list )$

symbolic procedure print_atlas_sort (atlas,edgelist)$
<< print "Atlas not sorted "$
   print_atlas atlas$
   if edgelist then
      << print "Defined edges: "$
         for each edge in edgelist do print edge >> $
   nil >> $

symbolic procedure atlas_sort (atlas,edgelist)$
begin
  scalar z,newedges$
 newedges:=store_edges new_edge_list$
 z:=
 errorset(list('atlas_sort1 ,mkquote atlas,mkquote edgelist),
          !*cvitrace,
          !*backtrace)$
 return
 if atom z then        %ATLAS NOT SORTED
 << restor_edges (newedges,new_edge_list)$  %RESTORE EDGES PARENTS
    if !*cvitrace then print_atlas_sort (atlas,edgelist)
    else nil >>
 else car z
end$

symbolic procedure store_edges edgelist$
for each edge in edgelist collect
      (car edge . cdr edge)$

symbolic procedure restor_edges (edgelist,newedgelist)$
if null edgelist then
 if newedgelist
   then set_error_real ('restor_edges ,list(edgelist,newedgelist))
 else nil
else
 if null newedgelist then
           set_error_real ('restor_edges ,list(edgelist,newedgelist))
 else
  if s_edge_name car edgelist = s_edge_name car newedgelist then
      << rplacd(car newedgelist,cdar edgelist)$
         car newedgelist . restor_edges (cdr edgelist,
                                          cdr newedgelist) >>
  else
    set_error_real ('restor_edges ,list(edgelist,newedgelist))$

symbolic procedure defined_atlas (atlas,edgelist)$
(lambda edges$
    defined_edges (edges,
%                   DEFINED_APPEND(EDGES,EDGELIST)))
                    edgelist))
 atlas_edges atlas$

symbolic procedure defined_append (edges,edgelist)$
 if null edges then edgelist
 else if defined_edge (car edges,edgelist) then
          car edges . defined_append (cdr edges,edgelist)
      else defined_append (cdr edges,edgelist) $

symbolic procedure defined_edges (edges,edgelist)$
if null edges then t
else
  if defined_edge (car edges,edgelist)
              then
     defined_edges (cdr edges,car edges . edgelist)
  else definedl_edges (cdr edges,list car edges,edgelist)$

symbolic procedure definedl_edges (edges,passed,edgelist)$
if null edges then null passed
else
 if defined_edge (car edges,edgelist) then
    defined_edges (nconc(passed,cdr edges),car edges . edgelist)
 else definedl_edges (cdr edges,car edges . passed,edgelist)$

symbolic procedure atlas_sort1 (atlas,edgelist)$
if all_defined (s_atlas_map_ atlas,edgelist) then
     mk_atlas (s_atlas_map_ atlas,
                coeff_sortl( s_atlas_coeff atlas,
                              nil,
                              nconc( map__edges s_atlas_map_ atlas,
                                     edgelist)),
                s_atlas_den_om atlas)
else coeff_sort (coeff_ordn (s_atlas_coeff atlas,edgelist),
%LSE COEFF_SORT (S_ATLAS_COEFF ATLAS,
                  mk_atlaslist (s_atlas_map_ atlas,
                                 nil,
                                 s_atlas_den_om atlas),
                  edgelist)$

symbolic procedure coeff_sortl (atlaslist,passed,edgelist)$
 coeff_sortl1 (coeff_ordn (atlaslist,edgelist),passed,edgelist)$

symbolic procedure coeff_sort (atlaslist,passed,edgelist)$
if atlaslist then
  (lambda z$                   %Z - NIL OR SORDET ATLAS
      if z then                %FIRST ATLAS ALREADY DEFINED
         mk_atlas (s_atlas_map_ z,
                    coeff_sortl (append(s_atlas_coeff z,
                                        append(cdr atlaslist,passed)),
                                  nil,
                                  nconc(map__edges s_atlas_map_ z,
                                        edgelist)),
                    s_atlas_den_om z)
      else
          coeff_sort (cdr atlaslist,
                       car atlaslist . passed,
                       edgelist))
  atlas_sort (car atlaslist,edgelist)
else coeff_sort_f (passed,nil,edgelist)$

symbolic procedure coeff_sort_f (passed,farewell,edgelist)$
if null passed then
  if null farewell then nil
  else error(51,nil)
else
 if s_atlas_coeff car passed then          %NOT EMPTY COEFF
   coeff_sort (append(
                   s_atlas_coeff car passed,
                   mk_atlas (s_atlas_map_ car passed,
                              nil,
                              s_atlas_den_om car passed) .
                     append(cdr passed,farewell)),
                nil,
                edgelist)
 else coeff_sort_f (cdr passed,
                      car passed . farewell,
                      edgelist) $

%.......... 31.05.88 ::::::::::: $

symbolic procedure coeff_ordn (atlaslist,edgelist)$
for each satlas in
 coeff_ordn1 (mk_spec_atlaslist (atlaslist,edgelist),nil)
collect cdr satlas$

symbolic procedure mk_spec_atlaslist (atlaslist,edgelist)$
 for each atlas in atlaslist collect mk_spec_atlas (atlas,edgelist)$

symbolic procedure mk_spec_atlas (atlas,edgelist)$
%RETURN PAIR (PAIR1 . ATLAS)
%WHERE PAIR1 IS A PAIR - EDGES . PARENTS
%WHERE EDGES - ALL EDGES OF ATLAS
%WHERE PARENTS-THOSE PARENTS OF EDGES WICH NOT CONTAITED IN EDGELIST
(lambda edges$
(edges . diff_edges (edges_parents edges,edgelist)) . atlas)
 atlas_edges atlas$

symbolic procedure edges_parents edgelist$
if null edgelist then nil
else
  (lambda z$
     append(z ,edges_parents cdr edgelist))
   edge_new_parents car edgelist$

symbolic procedure edge_new_parents edge$
% SELECT EDGE PARENTS FROM NEW_EDGE_LIST$
if p_old_edge edge then nil else
(lambda names$
  edge_new_parent list(car names,cdr names))
 s_edge_prop_ edge$

symbolic procedure edge_new_parent namelist$
if null namelist then nil
else
 (lambda z$
    if z then z . edge_new_parent cdr namelist
    else edge_new_parent cdr namelist)
  assoc(car namelist,new_edge_list) $

symbolic procedure diff_edges (edgelist1,edgelist2)$
if null edgelist1 then nil
else
 if p_member_edge (car edgelist1,edgelist2) then
    diff_edges (cdr edgelist1,edgelist2)
 else  car edgelist1 .
       diff_edges (cdr edgelist1,edgelist2)$

symbolic procedure coeff_ordn1 (satlaslist,passed)$
if null satlaslist then passed
else
%IF NULL CAAR SATLASLIST THEN     %ATLAS HAS NO UNDEFINED
%      COEFF_ORDN1 (CDR SATLASLIST,CAR SATLASLIST . PASSED)
%ELSE
 (lambda z$                    % Z - NIL OR SATLASLIST
   if z then                   % SUBATLAS FINED AND ADDED$
        coeff_ordn1 (z,passed)
   else coeff_ordn1 (cdr satlaslist,car satlaslist . passed) )
  p_subsatlaslist (car satlaslist,cdr satlaslist,nil)$

symbolic procedure p_subsatlaslist (satlas,satlaslist,passed)$
if null satlaslist then nil
else
 if or_subsatlas(satlas,car satlaslist) then
            embed_satlases (satlas,car satlaslist) .
            nconc(passed,cdr satlaslist)
 else p_subsatlaslist (satlas,
                       cdr satlaslist,
                       car satlaslist . passed)$

symbolic procedure or_subsatlas (satlas1,satlas2)$
  p_subsatlas (satlas1,satlas2)
             or
  p_subsatlas (satlas2,satlas1) $

symbolic procedure p_subsatlas (satlas1,satlas2)$
 p_subedgelist (caar satlas1,caar satlas2)
               or
 p_inbothlists (cdar satlas1,caar satlas2) $

symbolic procedure p_inbothlists (edgelist1,edgelist2)$
if null edgelist1 then nil
else p_member_edge (car edgelist1,edgelist2)
                 or
     p_inbothlists (cdr edgelist1,edgelist2)$

symbolic procedure p_subedgelist (edgelist1,edgelist2)$
 if null edgelist1 then t
 else
   p_member_edge (car edgelist1,edgelist2)
              and
   p_subedgelist (cdr edgelist1,edgelist2)$

symbolic procedure embed_satlases (satlas1,satlas2)$
 if p_subsatlas (satlas1,satlas2) then embed_satlas (satlas1,satlas2)
 else
 if p_subsatlas (satlas2,satlas1) then embed_satlas (satlas2,satlas1)
 else set_error_real ('embed_satlases,list(satlas1,satlas2)) $

symbolic procedure embed_satlas (satlas1,satlas2)$
 car satlas2 . embed_atlas (cdr satlas1,cdr satlas2)$

symbolic procedure embed_atlas (atlas1,atlas2)$
%EMBED ATLAS1 INTO ATLAS2
 mk_atlas (s_atlas_map_ atlas2,
            atlas1 . s_atlas_coeff atlas2,
            s_atlas_den_om atlas2)$

symbolic procedure coeff_sortl1 (atlaslist,passed,edgelist)$
if null atlaslist then
 if null passed then nil
 else list coeff_sort_f (passed,nil,edgelist)
else
(lambda z$
 if z then      %ATLAS SORTED
      z . coeff_sortl1 (cdr atlaslist,passed,edgelist)
 else coeff_sortl1 (cdr atlaslist,car atlaslist . passed,edgelist))
 atlas_sort (car atlaslist,edgelist)$

% ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,$


%END$  %cvit82.red
%:*:*:*:*:*:*:*:*:*:*:*:* FACTORIZATION OF MAP_S :*:*:*:*:*:*:*:*:*:$
% 19.05.88 $
lisp$

symbolic procedure renamel_edges edges$
if not equal_edges (car edges,cadr edges) then
  rename_edges (car edges ,cadr edges)$

symbolic procedure map__vertex_first map_$
  mk_vertex1_map_
                  s_vertex_first map_$

symbolic procedure  both_empty_map_s (map_1,map_2)$
 p_empty_map_ map_1
      and
 p_empty_map_ map_2 $

symbolic procedure has_parents edge$
 (lambda z$
           car z neq '!? and
           cdr z neq '!?    )
  s_edge_prop_ edge $

symbolic procedure less_edge (edge1,edge2,edgelist)$
% EDGE1 < EDGE2 IFF EDGE1 WAS CREATED EARLIER$
 less_edge_name (s_edge_name edge1,
                 s_edge_name edge2,
                 edgelist)$

symbolic procedure less_edge_name (name1,name2,edgelist)$
if null edgelist then set_error_real ('less_edge_name , 
                                      list(name1,name2,edgelist))
else
  if name1 eq s_edge_name car edgelist then nil
  else
    if name2 eq s_edge_name car edgelist then t
    else less_edge_name (name1,name2,cdr edgelist)$

symbolic procedure rename_edges (edge1,edge2)$
if p_old_edge edge1 then
 %IF P_OLD_EDGE EDGE2 THEN OLD_EDGE_LIST
  if p_old_edge edge2 then replace_old_edge (edge1,edge2)
  else replace_edge (edge2,edge1,new_edge_list )
else
  if p_old_edge edge2 then replace_edge (edge1,edge2,
                                         new_edge_list )
  else
    if has_parents edge1 then
      if has_parents edge2 then replace_new_edge (edge1,edge2)
      else replace_edge (edge2,edge1,new_edge_list )
    else
      if has_parents edge2 then
           replace_edge (edge1,edge2,new_edge_list )
      else replace_new_edge (edge1,edge2)$

symbolic procedure replace_new_edge (edge1,edge2)$
 replace_o_edge (edge1,edge2,new_edge_list )$

symbolic procedure replace_old_edge (edge1,edge2)$
% 31.08.90 RT
if is_indexp edge1 then
 if is_indexp edge2 then
     replace_o_edge (edge1,edge2,old_edge_list )
 else  replace_edge (edge1,edge2,old_edge_list)
else
  if is_indexp edge2 then
       replace_edge (edge2,edge1,old_edge_list)
  else
      replace_o_edge (edge1,edge2,old_edge_list )$

symbolic procedure replace_o_edge (edge1,edge2,edgelist)$
if less_edge (edge1,edge2,edgelist) then
              replace_edge (edge2,edge1,edgelist)
else          replace_edge (edge1,edge2,edgelist)$

symbolic procedure copy_edge edge$
 car edge . cadr edge . caddr edge . nil $


symbolic procedure replace_edge2 (oldedge,newedge)$
<< rplaca(oldedge,car newedge)$
   rplacd(oldedge,cdr newedge) >> $

symbolic procedure replace_edge (oldedge,newedge,edgelist)$
 replace1_edge (copy_edge oldedge,newedge,edgelist)$

symbolic procedure replace1_edge (oldedge,newedge,edgelist)$
if null edgelist then nil
else
  <<  if equal_edges (oldedge,car edgelist) then
                         replace_edge2 (car edgelist,newedge)$
      replace1_parents (oldedge,newedge,car edgelist)$
      replace1_edge (oldedge,newedge,cdr edgelist) >> $

symbolic procedure replace1_parents (oldedge,newedge,edge)$
 replace2_parents (s_edge_name oldedge,
                   s_edge_name newedge,
                   s_edge_prop_ edge)$

symbolic procedure replace2_parents (oldname,newname,edgeprop_)$
 << if oldname = car edgeprop_ then rplaca(edgeprop_,newname)$
    if oldname = cdr edgeprop_ then rplacd(edgeprop_,newname) >> $

symbolic procedure mk_simple_map_ inmap_$
  mk_simple_map_1 (inmap_,mk_empty_map_ (),nil,nil)$

symbolic procedure both_old edges$
 p_old_edge  car edges
        and
 p_old_edge cadr edges$

symbolic procedure both_vectors edges$   % 31.08.90 RT
 not is_indexp car edges
        and
 not is_indexp cadr edges$

symbolic procedure old_renamel_edv (vertex,edges)$
% RENAMES EDGES IN VERTEX$
 ren_edge (s_edge_name car edges .
           s_edge_name cadr edges,vertex)$

symbolic procedure mk1_simple_map_ map_d$
%MAP_D IS A PAIR (MAP_.DEN_OM)$
mk_simple_map_1 (car map_d,mk_empty_map_ (),list cdr map_d,nil)$

symbolic procedure mk_simple_map_1 (inmap_,outmap_,den_om,coeff)$
if p_empty_map_ inmap_ then <<
 %        FIND_BUBLTR
        outmap_ := mk_parents_map_ outmap_;
        mk_atlas  (outmap_ ,
                   if null coeff then nil 
		    else for each map_ in coeff
			     collect mk1_simple_map_ map_,
                   den_om) >>
else
(lambda edges$
 (lambda n$
  if p_vertex_prim s_vertex_first inmap_ then
   if n=2 then                 % VERTEX=(A,B)=DELTA(A,B)  $
    if both_old edges and both_vectors edges then   % 31.08.90
          mk_simple_map_1 (s_map__rest inmap_,
                           add_vertex (s_vertex_first inmap_,outmap_),
                           den_om,
                           coeff)
    else
     << renamel_edges edges$
        if both_empty_map_s (s_map__rest inmap_,outmap_) then
          mk_simple_map_1 (s_map__rest inmap_,
                           add_vertex (s_vertex_first inmap_,outmap_),
                           den_om,
                           coeff)
        else
           mk_simple_map_1 (s_map__rest inmap_,
                            outmap_,
                            den_om,
                            coeff )
     >>
   else
      mk_simple_map_1 ( s_map__rest inmap_,
                        add_vertex ( s_vertex_first inmap_,outmap_),
                        den_om,
                        coeff)
  else
   if n=2  then
    if both_old edges  and both_vectors edges then  %11.09.90 RT
        mk_simple_map_1 (add_vertex (mk_edges_vertex edges,
                                     s_map__rest inmap_),
                          outmap_,
                          den_om,
                          (mk_vertex1_map_ (
			   old_renamel_edv(s_vertex_first inmap_,edges))
			 . old_renamel_edv(mk_edges_vertex edges,edges))
			 . coeff  )
    else
     << renamel_edges edges$
        mk_simple_map_1 (s_map__rest inmap_,
                         outmap_,
                         den_om,
                         (map__vertex_first inmap_ . edges) . coeff)
      >>
   else
   if n=3  and
     ((map__length (inmap_) + map__length (outmap_)) > 2 )
    then
     (lambda v$
     mk_simple_map_1 (add_vertex (v,s_map__rest inmap_),
                      outmap_,
                      den_om,
                      (add_vertex (v,map__vertex_first inmap_) . v)
                        . coeff))
      mk_edges_vertex edges
   else
    if
      (lambda k$
           k > 4 and
           n < k )              %NOT ALL LINES EXTERNAL $
           vertex_length s_vertex_first inmap_
    then
    (lambda firz$
    mk_simple_map_1 (append_map_s (firz,s_map__rest inmap_),
                     outmap_,
                     den_om,
                     coeff) )
     (mk_firz_op s_vertex_first inmap_)        %26.04.88
  else if t then
    mk_simple_map_1 (s_map__rest inmap_,
                     add_vertex (s_vertex_first inmap_,outmap_),
                     den_om,
                     coeff)
    else
    mk_simple_map_1 (append_map_s (mk_simple_vertex
                                   s_vertex_first inmap_,
                                   s_map__rest inmap_),
                      outmap_,
                      den_om,
                      coeff)  )
  length edges)
(ext_edges s_vertex_first inmap_) $


% ?^?^?^?^?^?^?^?^?^?^?^?^? FIERZ OPTIMIZATION ?^?^?^?^?^?^?^?^?^?^?^?$
%       13.05.88$


global '(!*cvitop)$

flag('(cvitop),'switch)$

symbolic procedure mk_firz_op vertex$
if null !*cvitop then mk_firz vertex
else firz_op vertex$

symbolic procedure firz_op vertex$
mk_firz find_cycle (optimal_edge vertex,
                    vertex,
                    mk_empty_vertex ())$

symbolic procedure find_cycle (edge,vertex,passed)$
if equal_edges (edge,first_edge vertex) then
   append_vertex (vertex,reversip_vertex passed)
else find_cycle (edge,
                 s_vertex_rest vertex,
                 add_edge (first_edge vertex,passed))$

symbolic procedure optimal_edge vertex$
optimal1_edge
 internal_edges (vertex,mk_empty_vertex ())$

symbolic procedure internal_edges (vertex1,vertex2)$
if p_empty_vertex vertex1 then vertex2
else
  if p_member_edge (first_edge vertex1,s_vertex_rest vertex1)
            or
     p_member_edge (first_edge vertex1,vertex2)
   then internal_edges (s_vertex_rest vertex1,
                        add_edge (first_edge vertex1,vertex2))
  else  internal_edges (s_vertex_rest vertex1,vertex2)$

symbolic procedure optimal1_edge vertex$
% VERTEX CONTAINS ONLY PAIRED EDGES
(lambda (l,z)$
   opt_edge (z,
             edge_distance (z,vertex,l),
             s_vertex_rest vertex,
             add_edge (z,mk_empty_vertex ()),
             l))
(vertex_length vertex,
 first_edge vertex)$

symbolic procedure edge_distance (edge,vertex,l)$
% L - FULL VERTEX LENGTH
(lambda n$
     min(n,l - n - 2))
 edge_dist (edge,s_vertex_rest vertex)$

symbolic procedure edge_dist (edge,vertex)$
if equal_edges (edge,first_edge vertex) then 0
else add1 edge_dist (edge,s_vertex_rest vertex)$

symbolic procedure opt_edge (edge,distance,vertex,passed,n)$
% N - FULL VERTEX LENGTH
if distance = 0 or p_empty_vertex vertex then edge
else
(lambda firstedge$
   if p_member_edge (firstedge,passed) then
              opt_edge (edge,
                        distance,
                        s_vertex_rest vertex,
                        passed,
                        n)
   else
 (lambda dist$
    if dist < distance then
              opt_edge (firstedge,
                        dist,
                        s_vertex_rest vertex,
                        add_edge (firstedge,passed),
                        n)
     else     opt_edge (edge,
                        distance,
                        s_vertex_rest vertex,
                        add_edge (firstedge,passed),
                        n))
  edge_distance (firstedge,vertex,n))
first_edge vertex $



%<?><?><?><?><?><?><?> END OF OPTIMIZATION PART <?><?><?><?><?><?> $

symbolic procedure mk_firz vertex$
% VERTEX=(A1,...,AM,Z,B1,...,BN,Z,C1,...,CK)
% RETURNS UNION MAP_ WHERE
% MAP_ =MAP_1 & MAP_2  WHERE
% MAP_1=((B1,...,BN,X)(Y,C1,...,CK,A1,...,AM)),
% MAP_2=((Z,X,Z,Y)) $
   mk_firz1 (vertex,mk_empty_vertex ())$

symbolic procedure mk_firz1 (vertex1,vertex2)$
if p_empty_vertex vertex1 then reversip_vertex vertex2
else
  (lambda z$
      if z then                   %FIRST EDGE CONTAINS TWICE$
         mk_firz2 (first_edge vertex1,
                   car z,
                   append_vertex (cdr z,reversip_vertex vertex2))
      else
         mk_firz1 (s_vertex_rest vertex1,
                   add_edge (first_edge vertex1,vertex2) ) )
   mp_member_edge (first_edge vertex1,
                     s_vertex_rest vertex1)$

symbolic procedure mk_firz2 (edge,vertex1,vertex2)$
%RETURNS MAP_ =MAP_1 & MAP_2 ,
%VERTEX1=(B1,...,BN),
%VERTEX2=(C1,...,CK,A1,...,AM)  $
(lambda (nedge,nedg1)$
 append_map_s (
  mk_coeff2 (edge,nedge,nedg1),
  mk_vertex2_map_ (conc_vertex (vertex1,mk_edge1_vertex nedge),
                   add_edge (nedg1,vertex2))
               ))
(mk_nedge (),
 mk_nedge ()) $

symbolic procedure mk_coeff2 (edge,nedge,nedg1)$
 mk_vertex1_map_ mk_edge4_vertex (edge,nedge,edge,nedg1)$

symbolic procedure mk_nedge $
(lambda edge$
   new_edge (edge,edge))
 mk_edge ('!?,'!? . '!?,nil) $

symbolic procedure mp_member_edge (edge,vertex)$
% RETURNS NIL OR PAIR.
% IF VERTEX=(A1,...,AM,EDGE,...,B1,...,BN) THEN
% PAIR= (A1,...,AM) . (B1,...,BM) $
  mp_member1_edge (edge,vertex,mk_empty_vertex ())$

symbolic procedure mp_member1_edge (edge,vertex,tail)$
if p_empty_vertex vertex then nil
else
 if
  equal_edges (edge,first_edge vertex) then
           reversip_vertex tail .
           s_vertex_rest vertex
 else mp_member1_edge (edge,
                       s_vertex_rest vertex,
                       add_edge (first_edge vertex,tail) ) $


%END$  %cvit10.red
% ()()()()()()()()()()()()()() PRINTING ATLAS AND MAP_ ROUTINES ()()().
lisp$             %30.01.87$

fluid '(ntab!*)$

symbolic procedure print_atlas atlas$
begin
  scalar ntab!*$
  ntab!*:=0$
  prin2_atlas atlas$
end$

symbolic procedure prin2_atlas atlas$
if null atlas then nil
else
    << print_map_ s_atlas_map_ atlas$
       print_den_om s_atlas_den_om atlas$
       print_coeff s_atlas_coeff atlas
     >> $

symbolic procedure print_map_ map_$
 << pttab ntab!*$
    prin2 "Map_ is: ("$
    prin2_map_ map_$
    prin2 " )"$
    terpri()  >> $

symbolic procedure prin2_map_ map_$
if p_empty_map_ map_ then nil
else
    << print_vertex s_vertex_first map_$
       prin2_map_ s_map__rest map_ >> $

symbolic procedure print_vertex vertex$
 <<
    prin2 "( "$
    prin2_vertex vertex$
    prin2 ")"      >> $

symbolic procedure prin2_vertex vertex$
if p_empty_vertex vertex then nil
else
    << print_edge first_edge vertex$
       prin2_vertex s_vertex_rest vertex >> $

symbolic procedure print_edge edge$
 << prin2_edge edge$
    prin2 " "    >> $

symbolic procedure prin2_edge edge$
 prin2 s_edge_name edge $

symbolic procedure pttab n$
  << spaces n $   % TTAB N$         % 07.06.90
     prin2 n$
     prin2 ":" >> $

symbolic procedure print_coeff coeff$
 << ntab!*:=ntab!*+1$
    prin2_coeff coeff$
    ntab!*:=ntab!*-1    >> $

symbolic procedure prin2_coeff atlases$
if null atlases then nil
else << prin2_atlas car atlases$
        prin2_coeff cdr atlases >> $

symbolic procedure print_den_om den_list$
 << pttab ntab!*$
    prin2 "DEN_OM is: "$
    if null den_list then prin2 nil
    else prin2_map_ den_list $
    terpri() >> $

unfluid '(ntab!*)$

symbolic procedure print_old_edges ()$
   print_edge_list old_edge_list $

symbolic procedure print_new_edges ()$
   print_edge_list new_edge_list $

symbolic procedure print_edge_list edgelist$
if null edgelist then nil
else << print car edgelist$
        print_edge_list cdr edgelist >> $


%END$  %cvit12.red
%---------------------- MAKES PARENTS AFTER FIERZING ----------------$

          %24.05.88$
 lisp$


symbolic procedure mk_simpl_map_ map_$
  mk_simpl_map_1 (map_,mk_empty_map_ ())$

symbolic procedure mk_simpl_map_1 (inmap_,outmap_)$
if p_empty_map_ inmap_ then resto_map__order outmap_
else
  if p_vertex_prim s_vertex_first inmap_ then
      mk_simpl_map_1 ( s_map__rest inmap_,
		       add_vertex(mk_parents_prim s_vertex_first inmap_,
                                   outmap_))
  else
    mk_simpl_map_1 (append_map_s(mk_simple_vertex s_vertex_first inmap_,
                                  s_map__rest inmap_),
                    outmap_)$

symbolic procedure mk_simple_vertex vertex$
 % VERTEX => MAP_ $
begin
 scalar nedge,fedge,sedge$
 fedge:=first_edge vertex$
 sedge:=second_edge vertex$
 if not has_parents fedge or not has_parents sedge then
    return mk_simple_vertex cycl_vertex vertex$
 nedge:=new_edge (fedge,sedge)$
 vertex:=s_vertex_rest
         s_vertex_rest vertex$
 return
     mk_vertex2_map_ ( mk_edge3_vertex (nedge,fedge,sedge),
                       add_edge (nedge,vertex))
end$

symbolic procedure mk_parents_map_ map_$
%MAKES PARENTS FOR ALL EDGES IN MAP_.
%THIS CAN BE DONE BECAUSE NEW EDGES NEVER CREATE CYCLES$
 standard_map_
 mk_simpl_map_
 mk_parents1_map_ (map_,mk_empty_map_ (),mk_empty_map_ ())$

symbolic procedure standard_map_ map_$
if p_empty_map_ map_ then mk_empty_map_ ()
else
 if vertex_length s_vertex_first map_ > 2 then
    add_vertex (s_vertex_first map_,
                standard_map_ s_map__rest map_)
 else standard_map_ add_vertex (add_0_edge s_vertex_first map_,
                                s_map__rest map_)$

symbolic procedure add_0_edge vertex$
%ADDS SPECIAL VERTEX$
add_edge (!_0edge ,vertex)$

symbolic procedure mk_parents1_map_ (inmap_,outmap_,passed)$
if p_empty_map_ inmap_ then
 if p_empty_map_ passed then outmap_     %ALL EDGES HAVE PARENTS$
 else mk_parents1_map_ (passed,outmap_,mk_empty_map_ ())
else
 (lambda edges$
   if null edges then        %IN FIRST VERTEX ALL EDGES HAVE PARENTS$
      mk_parents1_map_ (s_map__rest inmap_,
                        add_vertex (s_vertex_first inmap_,outmap_),
                        passed)
   else
    if single_no_parents edges then   %ONLY ONE EDGE IN THE VERTEX$
                                        %HAS NO PARENTS$
       mk_parents1_map_ (s_map__rest inmap_,
			 append_map_s (mk_parents_vertex
					  s_vertex_first inmap_,
                                       outmap_),
                         passed)
    else
       mk_parents1_map_ (s_map__rest inmap_,
                         outmap_,
                         add_vertex (s_vertex_first inmap_,passed)))
  s_noparents s_vertex_first inmap_ $

symbolic procedure s_noparents vertex$
%SELECTS EDGES WITHOUT PARENTS IN VERTEX$
if p_empty_vertex vertex then nil
else
 if has_parents first_edge vertex then
         s_noparents s_vertex_rest vertex
 else
     first_edge vertex .
     s_noparents s_vertex_rest vertex$

symbolic procedure mk_parents_vertex vertex$
%MAKES PARENTS FOR THE SINGLE EDGE WITHOUT PARENTS IN VERTEX,
% (VERTEX HAS ONLY ONE EDGE WITHOUT PARENTS ^)       $
 mk_simpl_map_ mk_vertex1_map_ vertex$

symbolic procedure mk_parents_prim pvertex$
% CREATES PARENTS FOR THE ONLY EDGE WITHOUT PARENTS IN PRIMITIVE
% (THREE EDGES) VERTEX $
if vertex_length pvertex neq 3 then pvertex
else
  (lambda edges$
     if null edges then pvertex
     else
        << mk_edge_parents (pvertex,car edges)$
           pvertex >> )
   s_noparents pvertex$

symbolic procedure mk_edge_parents (vertex,edge)$
 mk_edge1_parents (delete_edge (edge,vertex),edge)$

symbolic procedure mk_edge1_parents (vertex2,edge)$
 add_parents (edge,
              mk_edge_prop_ (
                             s_edge_name first_edge vertex2,
                             s_edge_name second_edge vertex2))$

symbolic procedure add_parents (edge,names)$
  add_parents0(edge,names,nil)$

symbolic procedure add_parents0 (edge,names,bool)$
 addl_parents (new_edge_list,edge,names . list bool)$

symbolic procedure addl_parents (edgelist,edge,names)$
% NAMES IS A PAIR NAME1 . NAME2 $
if null edgelist then nil
else
(if equal_edges (car edgelist,edge) then
    rep_parents (car edgelist,names)
 else car edgelist) .
                      addl_parents (cdr edgelist,edge,names) $

symbolic procedure rep_parents (edge,names)$
 << rplacd(edge,names)$
    edge >> $

%END$  %cvit14.red
%EEEEEEEEEEEEEEEEEEEEEEEEE SELECT ALL EDGES %%%%%%%%%%%%%%%%%%%%%%%%% $

                       % 07.06.88$

lisp$

symbolic procedure atlas_edges atlas$
union_edges (
 union_edges (map__edges s_atlas_map_ atlas,
              den__edges s_atlas_den_om atlas),
 coeff_edges s_atlas_coeff atlas)$

symbolic procedure den__edges den_om$
 map__edges den_om$

symbolic procedure coeff_edges atlaslist$
 if null atlaslist then nil
 else union_edges (atlas_edges car atlaslist,
                   coeff_edges cdr atlaslist) $

symbolic procedure map__edges map_$
 if p_empty_map_ map_ then nil
 else union_edges (vertex_edges s_vertex_first map_,
                   map__edges s_map__rest map_)$

symbolic procedure union_edges (newlist,oldlist)$
if null newlist then oldlist
else union_edges (cdr newlist,
                  union_edge (car newlist,oldlist))$

symbolic procedure union_edge (edge,edgelist)$
 if memq_edgelist (edge,edgelist) then edgelist
 else edge . edgelist$

symbolic procedure memq_edgelist (edge,edgelist)$
 assoc(s_edge_name edge,
       edgelist)$

symbolic procedure exclude_edges (edgelist,exclude)$
% EXCLUDE IS A LIST OF EDGES TO BE EXCLUDED FROM EDGELIST$
 if null edgelist then nil
 else
   if memq_edgelist (car edgelist,exclude) then
           exclude_edges (cdr edgelist,exclude)
   else car edgelist .
           exclude_edges (cdr edgelist,exclude)  $


symbolic procedure constr_worlds (atlas,edgelist)$
(lambda edges$
   actual_edges_world (
      mk_world1 (actual_edges_map_ (edges,
                                    edgelist,
                                    s_atlas_map_ atlas),
                  constr_coeff (s_atlas_coeff atlas,
                                union_edges (edges,edgelist)),
                  s_atlas_den_om atlas
                  )
               ) )
union_edges(
  den__edges s_atlas_den_om atlas,
  map__edges s_atlas_map_ atlas)$

symbolic procedure constr_coeff (atlases,edgelist)$
 if null atlases then nil
 else
      constr_worlds (car atlases,edgelist) .
      constr_coeff (cdr atlases,edgelist)$

symbolic procedure actual_edges_map_ (edges,edgelist,map_)$
 actedge_map_ (edges,edgelist,list_of_parents(edges,edgelist),nil)
%ACTEDGE_MAP_ (EDGES,EDGELIST,NIL,NIL)
  . map_$

symbolic procedure list_of_parents (edges,edgelist)$
if null edges then nil
else append(list_of_parent (car edges,edgelist),
            list_of_parents (cdr edges,edgelist))$

symbolic procedure list_of_parent (edge,edgelist)$
if p_old_edge edge or memq_edgelist (edge,edgelist) then nil
               %IF EDGE IS DEF. THEN NO NEED IN ITS PARENTS
else
begin$
 scalar pr1,pr2,p,s$
 p:=s_edge_prop_ edge$
 pr1:=assoc(car p,edgelist)$
 if pr1 then s:=pr1 . s$
 pr2:=assoc(cdr p,edgelist)$
 if pr2 then s:=pr2 . s$
%IF NULL PR1 OR NULL PR2 THEN
% SET_ERROR (LIST_OF_PARENTS ,EDGE,EDGELIST)$
 return  s
end$

symbolic procedure actedge_map_ (edges,edgelist,old,new)$
if null edges then old . new
else
  if memq_edgelist (car edges,edgelist) then
       actedge_map_ (cdr edges,edgelist,car edges . old,new)
  else actedge_map_ (cdr edges,edgelist,old,car edges . new) $

symbolic procedure actual_edges_world world1$
 mk_world (actual_world (s_actual_world1 world1,
                         s_actual_coeff s_coeff_world1 world1),
            world1)$

symbolic procedure mk_world1 (edges!-map_,coeff,den_om)$
 mk_atlas (map_2_from_map_1 edges!-map_,coeff,den_om)$

symbolic procedure map_2_from_map_1 map_1$
 list(map_1_to_strand1 map_1,
      list nil,
      mark_edges (cdar map_1,
                % UNION_EDGES(OLD_EDGE_LIST,CAAR MAP_1),
                  caar map_1,
                  cdr map_1))$

symbolic procedure map_1_to_strand1 map_1$
car map_1 .
pre!-calc!-map_ (cdr map_1,
                 names_edgepair map__edges cdr map_1)$

symbolic procedure names_edgepair edgepair$
%NCONC(FOR EACH EDGE IN CAR EDGEPAIR COLLECT S_EDGE_NAME EDGE,
%      FOR EACH EDGE IN CDR EDGEPAIR COLLECT S_EDGE_NAME EDGE)$
       for each edge in edgepair collect s_edge_name edge $

symbolic procedure s_actual_world1 world1$
%RETURNS PAIR: OLDEDGES . NEWEDGES $
caar s_atlas_map_ world1$

symbolic procedure actual_world (map_edges,coeffedges)$
%MAP_EDGES IS A PAIR OLD . NEW,
%COEFFEDGES IS LIST OF ACTUAL EDGES OF COEEF.$
 union_edges (car map_edges,
              exclude_edges (coeffedges,cdr map_edges)) $

symbolic procedure s_actual_coeff worldlist$
if null worldlist then nil
else union_edges (s_edgelist_world car worldlist,
                  s_actual_coeff cdr worldlist) $

symbolic procedure world_from_atlas atlas$
%TOP LEVEL PROCEDURE$
 constr_worlds (atlas,old_edge_list )$


%END$  %cvit16.red
%^^^^^^^^^^^^^^^^^^^^^^^^^^ CALCULATION OF WORLDS ^^^^^^^^^^^^^^^^^^^ $
           %26.03.88$
lisp$

symbolic procedure s_world_names world$
for each edge in s_world_edges world
  collect s_edge_name edge$

symbolic procedure calc_world (world,alst)$
% ALST LIST OF VALUES OF EXTERNAL EDGES: (... (EDGNAME . NUMBER) ...)$
begin
  scalar s,v$
  alst:=actual_alst (alst,                   %SELECT ONLY THOSE
                     s_world_names world)$    %EDGES WICH ARE IN WORLD
  v:=s_world_var world $                      %SELECT DATA BASE
  s:=assoc(alst,cdr v)$                       %CALC. PREVIOSLY?
  if s then return cdr s$                     %PREV. RESULT$
  s:=reval
     calc_atlas (s_world_atlas world,alst)$   %REAL CALCULATION
  nconc (v,list(alst . s))$                   %MODIFY DATA BASE
  return s
end$

symbolic procedure actual_alst (alst,namelist)$
if null alst then nil
else
  if memq(caar alst,namelist) then
     car alst . actual_alst (cdr alst,namelist)
  else actual_alst (cdr alst,namelist)$

symbolic procedure calc_atlas (atlas,alst)$
        calc_map_2d (s_atlas_map_ atlas,
                     s_atlas_den_om atlas,
                     s_atlas_coeff atlas,
                     alst) $

symbolic procedure calc_coeff (worldlist,alst)$
if null worldlist then list 1
else
 (lambda x$
      if x=0 then list 0
      else x . calc_coeff (cdr worldlist,alst))
  calc_world (car worldlist,alst)$

symbolic procedure calc_map_2d (map_2,den_om,coeff,alst)$
coeff_calc (mk_names_map_2 caar map_2 .
                          cdar map_2 .
                          cadr map_2 .
                          den_om     ,
            coeff,
            mk_binding (caddr map_2,alst)) $

symbolic procedure mk_names_map_2 edgespair$
% EDGESPAIR IS PAIR OF LISTS OF EDGES
%   EDGELISTOLD . EDGELISTNEW         $
for each edge in append(car edgespair,cdr edgespair)
    collect s_edge_name edge$

symbolic procedure calc_coeffmap_ (s,coeff,alst)$
(lambda z$
    if z = 0 then 0
    else 'times . (z . calc_coeff (coeff,alst)))
 calc_map_ (s,alst)$

symbolic procedure calc_map_ (mvd,alst)$
begin
  scalar map_,v,names,s,den_om,al,d$
  names:=car mvd$                               %NAMES OF ALL EDGES
  map_:=cadr mvd$                               %SELECT MAP_
  v:=caddr mvd$                                 %SELECT DATA BASE
  den_om:=cdddr mvd$                            %SELECT DEN_OMINATOR
  al:=actual_alst (alst,names)$                 %ACTUAL ALIST
  if null al and names then return 0$           %NO VARIANTS OF
                                                %COLOURING
  s:=assoc(al,cdr v)$                           %PREV.CALCULATED?
  if s then  s:=cdr s                           %YES, TAKE IT
  else <<                                       %ELSE
       s:=reval calc_map_tar (map_,al)$         %REAL CALCULATION
       nconc(v,list(al . s))                    %MODIFY DATA BASE
       >>  $
  d:=calc_den_tar (den_om,alst)$                %CALC. DEN_OMINATOR
  return
        if d = 1 then s
        else list('quotient,s,d)                % 09.06.90 RT
end$

%SYMBOLIC PROCEDURE CALC_MAP_TAR (MAP_,BINDING)$
%1$

%SYMBOLIC PROCEDURE CALC_DEN_TAR (DEN_OMINATOR,BINDING)$
%1$

symbolic procedure coeff_calc (s,coeff,binding)$
%S IS EDGENAMES . MAP_ . DATABASE . DEN_OMINATOR $
 reval
     ('plus . coeff1_calc (s,coeff,binding))$

symbolic procedure coeff1_calc (s,coeff,binding)$
if null binding then list 0
else calc_coeffmap_ (s,coeff,car binding) .
     coeff1_calc (s,coeff,cdr binding) $

%TOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOP$

symbolic procedure calc_spur0 u$
begin
 scalar s$
 if null u then return u$
 s:=transform_map_ u$
 old_edge_list := !_0edge . old_edge_list $
 s:=find_bubltr s$
 return
        calc_world (world_from_atlas s,
                     for each edge in old_edge_list
                         collect s_edge_name edge .
                                 car s_edge_prop_ edge )
end$

symbolic procedure calc_spur u$
 simp!* calc_spur0 u$                %FOR KRYUKOV NEEDS$

endmodule;

end;