12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384 |
- 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;
|