Artifact 28999bc6286a4c4e0258a040137a55889d8498c89625a9a82403559ea3d26d93:
- Executable file
r37/packages/hephys/map2strn.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7834) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/hephys/map2strn.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7834) [annotate] [blame] [check-ins using]
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;