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

module map2strn;

%************* TRANSFORMATION OF MAP TO STRAND **********************$
%                                                                    $
%                       25.11.87                                     $
%                                                                    $
%********************************************************************$

  exports    color!-strand,contract!-strand $
  imports  nil$
  
%---------------- utility added 09.06.90 ---------------------------
symbolic procedure constimes u;
% u=list of terms
% inspect u, delete all 1's
% and form smar product   $
 cstimes(u,nil)$
 
symbolic procedure cstimes(u,s);
if null u then
  if null s then 1
  else if null cdr s then car s 
       else 'times . s 
else if car u = 1 then cstimes(cdr u,s)
     else cstimes(cdr u,car u . s)$
     
symbolic procedure consrecip u;
% do same as consTimes
if or(car u = 1,car u = -1) then car u
else 'recip . u$

symbolic procedure listquotient(u,v)$
% the same !!!
if v=1 then u 
else 
  if v = u then 1
  else list('quotient,u,v)$

symbolic procedure consplus u;
% u=list of terms
% inspect u, delete all 0's
% and form smar sum   $
 csplus(u,nil)$
 
symbolic procedure csplus(u,s);
if null u then
  if null s then 0
  else if null cdr s then car s 
       else 'plus . s 
else if car u = 0 then csplus(cdr u,s)
     else csplus(cdr u,car u . s)$
     
%--------------------------------------------------------------------
   
  

%---------------- CONVERTING OF MAP TO STRAND DIAGRAM ---------------$

symbolic procedure map_!-to!-strand(edges,map_)$
%.....................................................................
% ACTION: CONVERTS "MAP_" WITH "EDGES" INTO STRAND DIAGRAM.
% STRAND ::= <LIST OF STRAND VERTICES>,
% STRAND VERTEX ::= <SVERTEX NAME> . (<LIST1 OF ROADS> <LIST2 ...>),
% ROAD ::= <ATOM> . <NUMBER>.
% LIST1,2 CORRESPOND TO OPPOSITE SIDES OF STRAND VERTEX.
% ROADS LISTED CLOCKWISE.
%....................................................................$
if null edges then nil
else mk!-strand!-vertex(car edges,map_) .
                                map_!-to!-strand(cdr edges,map_)$

%YMBOLIC PROCEDURE MAP_!-TO!-STRAND(EDGES,MAP_)$
%F NULL EDGES THEN NIL
%LSE (LAMBDA SVERT$ IF SVERT THEN SVERT .
%                               MAP_!-TO!-STRAND(CDR EDGES,MAP_)
%                   ELSE MAP_!-TO!-STRAND(CDR EDGES,MAP_) )
%          MK!-STRAND!-VERTEX(CAR EDGES,MAP_)$

symbolic procedure mk!-strand!-vertex(edge,map_)$
begin
  scalar vert1,vert2,tail$
	 tail:=incident(edge,map_,1)$
         vert1:=car tail$
	 tail:=incident(edge,cdr tail,add1 cdar vert1)$
         vert2:= if null tail then mk!-external!-leg edge
                 else car tail$
   return %F NULL VERT2 THEN NIL
	       mk!-strand!-vertex2(edge,vert1,vert2)
end$

symbolic procedure incident(edge,map_,vertno)$
if null map_ then nil
else (lambda z$ if z then  z . cdr map_
		else incident(edge,cdr map_,add1 vertno) )
	     incident1(              edge,car map_,vertno)$

symbolic procedure incident1(edname,vertex,vertno)$
if eq(edname,s!-edge!-name car vertex) then
	     mk!-road!-name(cadr vertex,caddr vertex,vertno)
else if eq(edname,s!-edge!-name cadr vertex) then
	 mk!-road!-name(caddr vertex,car vertex,vertno)
     else if eq(edname,s!-edge!-name caddr vertex) then
		 mk!-road!-name(car vertex,cadr vertex,vertno)
          else nil$

symbolic procedure mk!-strand!-vertex2(edge,vert1,vert2)$
list(edge,   vert1,             vert2)$

%------------------ COLOURING OF ROADS IN STRAND --------------------$

symbolic procedure color!-strand(alst,map_,count)$
%.....................................................................
% ACTION: GENERATE REC. ALIST COLORING STRAND, CORRESPONDING TO "MAP_".
% COLORING OF STRAND INDUCED BY "MAP_" COLORING, DEFINED BY ALIST
% "ALST". "COUNT" COUNTS MAP_ VERTICES. INITIALLY IS 1.
% REC.ALIST::= ( ... <(ATOM1 . COL1 ATOM2 . COL2 ...) . NUMBER> ... )
% WHERE COL1 IS COLOR OF ROAD=ATOM1 . NUMBER.
%....................................................................$
if null map_ then nil
else  (color!-roads(alst,car map_) . count) .
			  color!-strand(alst,cdr map_,add1 count)$

symbolic procedure color!-roads(alst,vertex)$
begin
    scalar e1,e2,e3,lines$
    e1:=getedge(s!-edge!-name car vertex,alst)$
    e2:=getedge(s!-edge!-name cadr vertex,alst)$
    e3:=getedge(s!-edge!-name caddr vertex,alst)$
    lines:=(e1+e2+e3)/2$
    e1:=lines-e1$
    e2:=lines-e2$
    e3:=lines-e3$
  return list(
               s!-edge!-name car vertex . e1,
               s!-edge!-name cadr vertex . e2,
               s!-edge!-name caddr vertex . e3)
end$

symbolic procedure zero!-roads l$
%---------------------------------------------------------------------
% L IS OUTPUT OF COLOR!-STRAND
%--------------------------------------------------------------------$
if null l then nil
else (lambda z$ if z then z . zero!-roads cdr l
                else zero!-roads cdr l)
              z!-roads car l$

symbolic procedure z!-roads y$
(lambda w$  w and (car w . cdr y))
    ( if (0=cdr caar y)then caar y
      else if  (0=cdr cadar y) then cadar y
           else if (0=cdr caddar y) then caddar y
                else nil)$

%------------------- CONTRACTION OF STRAND --------------------------$

symbolic procedure deletez1(strand,alst)$
%.....................................................................
% ACTION: DELETES FROM "STRAND" VERTICES WITH NAMES HAVING 0-COLOR
% VIA MAP_-COLORING ALIST "ALST".
%....................................................................$
if null strand then nil
else if 0 = cdr assoc(caar strand,alst) then
			  deletez1(cdr strand,alst)
     else car strand . deletez1(cdr strand,alst)$

symbolic procedure contract!-strand(strand,slst)$
%.....................................................................
% ACTION: CONTRACTS "STRAND".
% "SLST" IS REC. ALIST COLORING "STRAND"
%....................................................................$
contr!-strand(strand,zero!-roads slst)$

symbolic procedure contr!-strand(strand,zlst)$
if null zlst then strand
else contr!-strand(contr1!-strand(strand,car zlst),cdr zlst)$

symbolic procedure contr1!-strand(strand,rname)$
contr2!-strand(strand,rname,nil,nil)$

symbolic procedure contr2!-strand(st,rname,rand,flag_)$
if null st then rand
else (lambda z$
          if z then
	    if member(car z,cdr z) then sappend(st,rand)  % 16.12 ****$
            else
                if null flag_ then
		  contr2!-strand(contr2(z,cdr st,rand),rname,nil,t)
		else contr2(z,cdr st,rand)
	  else contr2!-strand(cdr st,rname,car st . rand,nil)  )
      contrsp(car st,rname)$

symbolic procedure contrsp(svertex,rname)$
contrsp2(cadr svertex,caddr svertex,rname)
                or
contrsp2(caddr svertex,cadr svertex,rname)$

symbolic procedure contrsp2(l1,l2,rname)$
if 2 = length l1 then
 if rname = car l1 then (cadr l1) . l2
 else if rname = cadr l1 then (car l1) . l2
else nil$

symbolic procedure contr2(single,st,rand)$
if null st then contr(single,rand)
else if null rand then contr(single,st)
     else split!-road(single,car st) . contr2(single,cdr st,rand)$

symbolic procedure contr(single,strand)$
if null strand then nil
else split!-road(single,car strand) . contr(single,cdr strand)$

symbolic procedure split!-road(single,svertex)$
list(car svertex,
sroad(car single,cdr single,cadr svertex),
	     sroad(car single,cdr single,caddr svertex))$

symbolic procedure sroad(line_,lines,lst)$
if null lst then nil
else if line_ = car lst then sappend(lines,cdr lst)
     else car lst . sroad(line_,lines,cdr lst)$

endmodule;

end;