123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660 |
- module cvit; % Header module for CVIT package.
- % Authors: A.Kryukov, A.Rodionov, A.Taranov.
- % Copyright (C) 1988,1990, Institute of Nuclear Physics, Moscow State
- % University.
- % Modifications for Reduce 3.4.1 by John Fitch.
- % The CVITMAC module can be loaded for compilation only,
- % and need not be present during run time.
- % The High Energy Physics package must be loaded first.
- load_package hephys;
- endmodule;
- module cvitmac; % smacro procedures for Cvitanovich package.
- % COPYRIGHT (C) 1988,1990, INSTITUTE OF NUCLEAR PHYSICS, MOSCOW STATE
- % UNIV.
- % AUTHOR A.KRYUKOV, A.RODIONOV, A.TARANOV
- % VERSION 2.1
- % RELEASE 11-MAR-90
- % 07.06.90 all MAP replaced by MAP_ RT
- % 08.06.90 SOME MACROS FROM CVITMAP FILE ADDED to section IV RT
- % 10.06.90 SOME MACROS FROM CVITMAP FILE ADDED RT
- % These fluids and globals have been moved here for cleaner compilation.
-
- fluid '(!*msg ndims!* dindices!*)$
- global '(windices!* indices!* !*cvit gamma5!* !*g5cvit)$
- if null windices!*
- then windices!*:=
- '(nil !_f0 !_f1 !_f2 !_f3 !_f4 !_f5 !_f6 !_f7 !_f8 !_f9)$
- if null gamma5!*
- then gamma5!*:=
- '(nil !_a0 !_a1 !_a2 !_a3 !_a4 !_a5 !_a6 !_a7 !_a8 !_a9)$
- %GGGGGGGGGGGGGGGGGGGGGGGGG GLOBALS & FLUIDS FFFFFFFFFFFFFFFFFFFFFFFFF$
- global '( !_0edge)$
- fluid '( new_edge_list old_edge_list )$
- % NEW_EDGE_LIST - LIST OF CREATED EDGES$
- % OLD_EDGE_LIST - LIST OF INITIAL EDGES$
- fluid '(n_edge)$
- % N_EDGE - NUMBER OF CREATED EDGES$
- %************ SECTION I ************************************
- smacro procedure hvectorp x$
- get(x,'rtype) eq 'hvector$
- smacro procedure windexp x$
- x memq car windices!*$
- smacro procedure replace_by_indexp v$
- get(v,'replace_by_index)$
- smacro procedure indexp i$
- i memq indices!*$
- smacro procedure replace_by_vectorp i$
- get(i,'replace_by_vector)$
- smacro procedure replace_by_vector i$
- get(i,'replace_by_vector) or i$
- smacro procedure gamma5p x$
- memq(x,car gamma5!*)$
- smacro procedure nospurp x$
- flagp(x,'nospur)$
- smacro procedure clear_gamma5()$
- gamma5!* := nil . append(reverse car gamma5!*,cdr gamma5!*)$
- %********************* SECTION II **************************
- symbolic smacro procedure p_empty_map_ map_$
- % IS MAP_ EMPTY ? $
- null map_$
- symbolic smacro procedure p_empty_vertex vertex$
- % IS VERTEX EMPTY ? $
- null vertex$
- %++++++++++++++++++++++++++ SELECTORS +++++++++++++++++++++++++++++++$
- symbolic smacro procedure s_vertex_first map_$
- % SELECT FIRST VERTEX IN MAP_ $
- car map_$
- symbolic smacro procedure s_map__rest map_$
- % SELECT TAIL OF MAP_ $
- cdr map_$
- symbolic smacro procedure s_vertex_second map_$
- % SELECT SECOND VERTEX IN MAP_ $
- s_vertex_first s_map__rest map_$
- symbolic smacro procedure first_edge vertex$
- % SELECT FIRST EDGE IN VERTEX $
- car vertex$
- symbolic smacro procedure s_vertex_rest vertex$
- % SELECT TAIL OF VERTEX $
- cdr vertex$
- symbolic smacro procedure second_edge vertex$
- % SELECT SECOND EDGE IN VERTEX $
- first_edge s_vertex_rest vertex$
- symbolic smacro procedure s_edge_name edge$
- % SELECT EDGE'S NAME $
- car edge$
- symbolic smacro procedure s_edge_prop_ edge$
- % SELECT PROP_ERTY OF AN EDGE (NAMES OF PARENTS OR NUMBERS)$
- cadr edge$
- symbolic smacro procedure s_edge_type edge$
- % SELEC TYPE (PARITY) OF AN EDGE$
- caddr edge$
- %?????????????????????? CONSTRUCTORS ??????????????????????????????$
- symbolic smacro procedure add_vertex (vertex,map_)$
- % ADD VERTEX TO MAP_ $
- vertex . map_ $
- symbolic smacro procedure add_edge (edge,vertex)$
- % ADD EDGE TO VERTEX$
- edge . vertex$
- symbolic smacro procedure append_map_s (map_1,map_2)$
- % APPEND TWO MAP_S $
- append(map_1,map_2)$
- symbolic smacro procedure conc_map_s (map_1,map_2)$
- % APPEND TWO MAP_S $
- nconc(map_1,map_2)$
- symbolic smacro procedure conc_vertex (vertex1,vertex2)$
- % APPEND TWO VERTICES
- nconc(vertex1,vertex2)$
- symbolic smacro procedure mk_name1 name$
- explode name$
- symbolic smacro procedure mk_edge_prop_ (prop_1,prop_2)$
- prop_1 . prop_2 $
- symbolic smacro procedure mk_edge_type (typ1,typ2)$
- % DEFINED EDGE <=> TYPE T,
- % UNDEFINED EDGE <=> TYPE NIL$
- typ1 and typ2 $
- symbolic smacro procedure mk_edge (name,prop_,type)$
- % MAKE UP NEW EDGE $
- list(name,prop_,type)$
- symbolic smacro procedure mk_edge3_vertex (edge1,edge2,edge3)$
- % MAKES PRIMITIVE VERTEX $
- list(edge1,edge2,edge3)$
- symbolic smacro procedure mk_empty_map_ ()$
- % GENERATE EMPTY MAP_ $
- nil $
- symbolic smacro procedure mk_empty_vertex ()$
- % GENERATE EMPTY VERTEX $
- nil $
- symbolic smacro procedure mk_vertex1_map_ vertex1$
- % MAKE MAP_ OF ONE VERTEX $
- list(vertex1)$
- symbolic smacro procedure mk_vertex2_map_ (vertex1,vertex2)$
- % MAKE MAP_ OF TWO VERTICES $
- list(vertex1,vertex2)$
- symbolic smacro procedure mk_edge2_vertex (edge1,edge2)$
- %MAKES VERTEX FROM TWO EDGES$
- list(edge1,edge2)$
- symbolic smacro procedure conc_vertex (vertex1,vertex2)$
- nconc(vertex1,vertex2)$
- symbolic smacro procedure cycl_map_ map_$
- % MAKES CYCLIC PERMUTATION OF MAP_$
- append(cdr map_,list car map_)$
- symbolic smacro procedure cycl_vertex vertex$
- % MAKES CYCLIC PERMUTATION OF VERTEX$
- append(cdr vertex,list car vertex)$
- symbolic smacro procedure mk_world (actedges,world1)$
- list(actedges,list nil,world1)$
- %====================== PREDICATES (CONTINUE) =====================$
- symbolic smacro procedure p_member_edge (edge,vertex)$
- % IS EDGE (WITH THE SAME NAME) CONTAINS IN VERTEX ?$
- assoc(s_edge_name edge,vertex)$
- symbolic smacro procedure equal_edges (edge1,edge2)$
- % IF EDGES HAVE THE SAME NAMES ? $
- eq ( s_edge_name edge1, s_edge_name edge2)$
- symbolic smacro procedure single_no_parents edges$
- length edges = 1 $
- symbolic smacro procedure resto_map__order map_$
- % REVERSE (BETTER REVERSIP) MAP_ $
- reverse map_$
- symbolic smacro procedure map__length map_$
- % NUMBER OF VERTICES IN MAP_$$
- length map_$
- symbolic smacro procedure vertex_length vertex$
- % NUMBER OF EDGES IN VERTEX $
- length vertex$
- symbolic smacro procedure prepare_map_ map_$
- for each x in map_
- collect mk_old_edge x$
- symbolic smacro procedure p_vertex_prim vertex$
- % IS VERTEX PRIMITIVE ? $
- vertex_length (vertex) <= 3 $
- %************ SECTION III ************************************
- symbolic smacro procedure s!-edge!-name edge$ car edge$
- symbolic smacro procedure sappend(x,y)$ append(x,y)$
- symbolic smacro procedure sreverse y $ reverse y$
- symbolic smacro procedure getedge(x,y)$ cdr assoc(x,y)$
- symbolic smacro procedure mk!-road!-name(x,y,n)$
- list(car x . n,car y . n)$
- symbolic smacro procedure mk!-external!-leg edge$
- %< FLAG(LIST EDGE,'EXTRNL)$
- list( edge . 0) $
- symbolic smacro procedure index!-in(ind,l)$
- if atom ind then nil
- else member(ind,l)$
- %************ SECTION IV ************************************
- symbolic smacro procedure reverse_map_ map_$
- reverse map_$
- symbolic smacro procedure mk_edge1_vertex edge$
- list edge$
- symbolic smacro procedure mk_edges_vertex edges$
- edges$
- symbolic smacro procedure reversip_vertex vertex$
- reversip vertex$
- symbolic smacro procedure append_vertex (vertex1,vertex2)$
- append(vertex1,vertex2)$
- %symbolic smacro procedure conc_vertex (vertex1,vertex2)$
- % nconc(vertex1,vertex2)$
- symbolic smacro procedure mk_edge4_vertex (edge1,edge2,edge3,edge4)$
- list(edge1,edge2,edge3,edge4)$
- symbolic smacro procedure p_old_edge edge$
- assoc(s_edge_name edge,old_edge_list )$
- symbolic smacro procedure s_atlas_map_ atlas$
- car atlas$
- symbolic smacro procedure s_atlas_coeff atlas$
- cadr atlas$
- symbolic smacro procedure s_atlas_den_om atlas$
- caddr atlas$
- symbolic smacro procedure mk_atlas (map_,atlases,den_om)$
- list(map_,atlases,den_om)$
- symbolic smacro procedure vertex_edges edge$
- edge$
- symbolic smacro procedure s_coeff_world1 world1$
- cadr world1 $
- symbolic smacro procedure s_edgelist_world world$
- car world$
- symbolic smacro procedure s_world1 world$
- caddr world $
- symbolic smacro procedure s_world_var world$
- cadr world$
- symbolic smacro procedure s_world_atlas world$
- caddr world$
- symbolic smacro procedure s_world_edges world$
- car world$
- endmodule;
- module red_to_cvit_interface$
- % COPYRIGHT (C) 1988,1990,INSTITUTE OF NUCLEAR PHYSICS,MOSCOW STATE
- % UNIV.
- % PURPOSE INTERFACE BETWEEN REDUCE AND CVITANOVICH ALGORITHM.
- % AUTHOR A.KRYUKOV
- % VERSION 2.1
- % RELEASE 11-MAR-90
- exports isimp1,replace_by_vector,replace_by_vectorp,gamma5p$
- imports calc_spur,isimp2$
- switch cvit$ % CVITANOVICH ALGORITHM SWITCH
- !*cvit := t$ % DEFAULT ON
- %************ ISIMP1 REDEFINITION ************************
- remflag('(isimp1),'lose)$
- symbolic procedure isimp1(u,i,v,w,x)$
- if null u then nil
- else if domainp u
- then if x then multd(u,if !*cvit
- then calc_spurx (i,v,w,x)
- else spur0 (car x,i,v,w,cdr x)
- )
- else if v then multd(u,index_simp (1,i,v,w))
- else if w then multfs(emult w,isimp1(u,i,v,nil,nil))
- else u
- else addfs(isimp2(car u,i,v,w,x),isimp1(cdr u,i,v,w,x))$
- flag('(isimp1),'lose)$
- %************* INDEX_SIMP *******************************
- symbolic procedure index_simp (u,i,v,w)$
- if v then index_simp (multf(mksprod(caar v,cdar v),u),
- update_index (i,car v),cdr v,w)
- else isimp1(u,i,nil,w,nil)$
- symbolic procedure mksprod(x,y)$
- mkdot(if indexp x then replace_by_vector x else x,
- if indexp y then replace_by_vector y else y)$
- symbolic procedure update_index (i,v)$
- % I - LIST OF UNMATCH INDICES
- % V - PAIR: (I/V . I/V)
- % VALUE - UPDATE LIST OF INDICES
- delete(cdr v,delete(car v,i))$
- %************ CALC_SPURX - MAIN PROCEDURE ***************
- symbolic procedure calc_spurx (i,v,w,x)$
- % I - LIST OF INDICES
- % V - LIST OF SCALAR PRODUCT:(<I/V> . <I/V>)
- % W - EPS-EXPR
- % X - LIST OF SPURS
- % VALUE - CALCULATED SPUR(S.F.)
- begin scalar u, % SPUR: (LNAME G5SWITCH I/V I/V ... )
- x1, % (UN ... U1)
- dindices!*,% A-LIST OF DUMMY INDICES: (I . NIL/T)
- c$ % COEFFICIENT GENERATIED BY GX*GX
- if numberp ndims!* and null evenp ndims!*
- then cviterr list('calc_spur,":",ndims!*,
- "is not even dimension of G-matrix space")$
- c := 1$ % INITIAL VALUE
- while x
- do << if nospurp caar x
- then cviterr list "Nospur not yet implemented"$
- u := cdar x$
- x := cdr x$
- if car u
- then if evenp ndims!*
- then u := next_gamma5() . reverse cdr u
- else cviterr
- list("G5 invalid for non even dimension")
- else u := reverse cdr u$
- if null u then nil % SP()
- else if null evenp length(if gamma5p car u and cdr u
- then cdr u
- else u)
- then x := c := nil % ODD - VALUE=0
- else << u := remove_gx!*gx u$
- c := multf(car u,c)$
- u := replace_vector(cdr u,i,v,w)$
- i := cadr u$
- v := caddr u$
- w := cadddr u$
- if u then x1 := car u . x1
- >>
- >>$
- x1 := if null c then nil ./ 1 % ZERO
- else if x1 then multsq(c ./ 1,calc_spur x1)
- else c ./ 1$
- if denr x1 neq 1 then cviterr list('calc_spurx,":",x1,
- "has non unit denominator")$
- clear_windices ()$
- clear_gamma5 ()$
- return isimp1(numr x1,i,v,w,nil)
- end$
- symbolic procedure third_eq_indexp i$
- begin scalar z$
- if null(z := assoc(i,dindices!*))
- then dindices!* := (i . nil) . dindices!*
- else if null cdr z
- then dindices!* := (i . t) . delete(z,dindices!*)$
- return if z then cdr z else nil
- end$
- symbolic procedure replace_vector(u,i,v,w)$
- % U - SPUR (INVERSE)
- % I - LIST OF UNMATCH INDICES
- % V - A-LIST OF SCALAR PRODUCT
- % W - EPS-EXPRESION
- % VALUE - LIST(U,UPDATE I,UPDATE V,UPDATE W)
- begin scalar z,y,x, % WORK VARIABLES
- u1$ % SPUR WITHOUT VECTOR
- while u
- do << z := car u$
- u := cdr u$
- if indexp z
- then << % REMOVE DUMMY INDICES
- while (y := bassoc(z,v))
- do << i := delete(z,i)$
- v := delete(y,v)$
- % W := ....
- x := if z eq car y then cdr y
- else car y$
- if indexp x then z := x
- else if gamma5p x
- then cviterr list "G5 bad structure"
- else replace_by_index (x,z)
- >>$
- u1 := z . u1
- >>
- else if gamma5p z then u1 := z . u1
- else << z := replace_by_index (z,next_windex())$
- u1 := z . u1
- >>
- >>$
- return list(reverse u1,i,v,w)
- end$
- symbolic procedure replace_by_index (v,y)$
- begin scalar z$
- if (z := replace_by_vectorp y) eq v
- then cviterr list('replace_by_index,":",y,
- "is already defined for vector",z)$
- put(y,'replace_by_vector ,v)$
- return y
- end$
- symbolic procedure remove_gx!*gx u$
- begin scalar x,c$
- integer l,l1$
- c := 1$
- l1 := l := length u$
- u := for each z in u % MAKE COPY
- collect << if indexp z then
- if third_eq_indexp z
- then cviterr list("Three indices have name",z)
- else nil
- else if null hvectorp z then
- if cvitdeclp(z,'vector)
- then vector1 list z
- else cviterr nil
- else nil$
- z
- >>$
- if l < 2 then return u$
- x := u$
- while cdr x do x := cdr x$
- rplacd(x,u)$ % MAKE CYCLE
- while l1 > 0
- do if car u eq cadr u % EQUAL ?
- then << c := multf(if indexp car u then ndims!*
- else mkdot(car u,car u)
- ,c)$
- rplaca(u,caddr u)$ % YES - DELETE
- rplacd(u,cdddr u)$
- l1 := l := l - 2
- >>
- else << u := cdr u$ % NO - CHECK NEXT PAIR
- l1 := l1 - 1
- >>$
- x := cdr u$
- rplacd(u,nil)$ % CUT CYCLE
- return (c . if cdr x and car x eq cadr x then nil else x)
- end$
- %************* ERROR,MESSAGE *****************************
- symbolic procedure cviterr u$
- << clear_windices()$
- clear_gamma5()$
- if u then rederr u else error(0,nil) >>$
- symbolic procedure cvitdeclp(u,v)$
- if null !*msg then nil
- else if terminalp()
- then yesp list("Declare",u,v,"?")
- else << lprim list(u,"Declare",v)$ t >>$
- %*********** WORK INDICES & VECTOR ***********************
- symbolic procedure clear_windices ()$
- while car windices!*
- do begin scalar z$
- z := caar windices!*$
- windices!* := cdar windices!* . z . cdr windices!*$
- remprop(z,'replace_by_vector)$
- indices!* := delete(z,indices!*)$
- end$
- symbolic procedure next_windex()$
- begin scalar i$
- windices!* := if null cdr windices!*
- then (intern gensym() . car windices!*) .
- cdr windices!*
- else (cadr windices!* . car windices!*) .
- cddr windices!*$
- i := caar windices!*$
- vector1 list i$
- indices!* := i . indices!*$
- return i
- end$
- symbolic procedure next_gamma5()$
- begin scalar v$
- cviterr list "GAMMA5 is not yet implemented. use OFF CVIT";
- gamma5!* := if null cdr gamma5!*
- then (intern gensym() . car gamma5!*) .
- cdr gamma5!*
- else (cadr gamma5!* . car gamma5!*) .
- cddr gamma5!*$
- v := list caar gamma5!*$
- vector1 v$
- return car v
- end$
- %************ END ****************************************
- %prin2t "_Cvitanovich_algorithm_is_ready"$
- endmodule$
- module map_to_strand$
- %************* 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$
- %********************************************** **********************
- %******************** INTERACTION WITH ALG MODE **********************
- %******************** 11.12.87 **********************
- %******************** VARIANT WITHOUT NONLOCALS **********************
- %********************************************************************$
- module eval_map_s$
- exports strand!-alg!-top $
- imports color!-strand,contract!-strand $
- lisp$
- %------------------ AUXILIARRY ROUTINES -----------------------------$
- symbolic procedure permpl(u,v)$
- if null u then t
- else if car u = car v then permpl(cdr u,cdr v)
- else not permpl(cdr u,l!-subst1(car v,car u,cdr v))$
- symbolic procedure repeatsp u$
- if null u then nil
- else (member(car u,cdr u) or repeatsp cdr u )$
- symbolic procedure l!-subst1(new,old,l)$
- if null l then nil
- else if old = car l then new . cdr l
- else (car l) . l!-subst1(new,old,cdr l)$
- %-------------------FORMING ANTISYMMETRIHERS -----------------------$
- symbolic procedure propagator(u,v)$
- if null u then 1
- else if (repeatsp u) or (repeatsp v) then 0
- else 'plus . propag(u,permutations v,v)$
- symbolic procedure propag(u,l,v)$
- if null l then nil
- else (if permpl(v,car l) then 'times . prpg(u,car l)
- else list('minus,'times . prpg(u,car l) ) ) . propag(u,cdr l,v)$
- symbolic procedure prpg(u,v)$
- if null u then nil
- else list('cons,car u,car v) . prpg(cdr u,cdr v)$
- symbolic procedure line(x,y)$
- propagator(cdr x,cdr y)$
- %------------------ INTERFACE WITH CVIT3 ---------------------------$
- symbolic procedure strand!-alg!-top(strand,map_,edlst)$
- begin
- scalar rlst$
- strand:=deletez1(strand,edlst)$
- rlst:=color!-strand(edlst,map_,1)$
- strand:=contract!-strand(strand,rlst) $
- %RINT STRAND$ TERPRI()$
- %RINT RLST$ TERPRI()$
- %RINT EDLST$ TERPRI()$
- return dstr!-to!-alg(strand,rlst,nil)
- %ATHPRINT REVAL(W)$ RETURN W
- end$
- symbolic procedure mktails(side,rlst,dump)$
- begin
- scalar pntr,newdump,w,z$
- if null side then return nil . dump$
- pntr:=side$
- newdump:=dump$
- while pntr do << w:=mktails1(car pntr,rlst,newdump)$
- newdump:=cdr w$
- z:=sappend(car w,z)$
- pntr:=cdr pntr >>$
- return z . newdump
- end$
- symbolic procedure mktails1(rname,rlst,dump)$
- begin
- scalar color,prename,z$
- color:=getroad(rname,rlst)$
- if 0 = color then return nil . dump$
- if 0 = cdr rname then
- return (list replace_by_vector car rname) . dump$
- % IF FREEIND CAR RNAME THEN RETURN (LIST CAR RNAME) . DUMP$
- z:=assoc(rname,dump)$
- if z then return
- if null cddr z then cdr z . dump
- else (sreverse cdr z) . dump$
- % PRENAME:=APPEND(EXPLODE CAR RNAME,EXPLODE CDR RNAME)$
- prename:=rname$
- z:= mkinds(prename,color)$
- return z . ((rname . z) . dump)
- end$
- symbolic procedure mkinds(prename,color)$
- if color = 0 then nil
- else
- begin
- scalar indx$
- % INDX:=INTERN COMPRESS APPEND(PRENAME,EXPLODE COLOR)$
- indx:= prename . color $
- return indx . mkinds(prename,sub1 color)
- end$
- symbolic procedure getroad(rname,rlst)$
- if null rlst then 1 % ******EXT LEG IS ALWAYS SUPPOSET TO BE SIMPLE $
- else if cdr rname = cdar rlst then
- cdr qassoc(car rname,caar rlst)
- else getroad(rname,cdr rlst) $
- symbolic procedure qassoc(atm,alst)$
- if null alst then nil
- else if eq(atm,caar alst) then car alst
- else qassoc(atm,cdr alst)$
- %------------- INTERACTION WITH RODIONOV ---------------------------$
- symbolic procedure from!-rodionov x$
- begin scalar strand,edges,edgelsts,map_,w$
- edges:=car x$
- map_:=cadr x$
- edgelsts:=cddr x$
- strand := map_!-to!-strand(edges,map_)$
- w:= for each edlst in edgelsts collect
- strand!-alg!-top(strand,map_,edlst)$
- return reval('plus . w )
- end$
- symbolic procedure top1 x$
- mathprint from!-rodionov to_taranov x$
- %----------------------- COMBINATORIAL COEFFITIENTS -----------------$
- symbolic procedure f!^(n,m)$
- if n<m then cviterr "Incorrect args of f!^"
- else if n = m then 1
- else n*f!^(sub1 n,m)$
- %% This exists in basic REDUCE these days -- JPff
- %%symbolic procedure factorial n$
- %%f!^(n,0)$
- symbolic procedure mk!-coeff1(alist,rlst)$
- if null alist then 1
- else
- eval ('times .
- for each x in alist collect factorial getroad(car x,rlst) )$
- %--------------- CONTRACTION OF DELTA'S -----------------------------$
- symbolic procedure prop!-simp(l1,l2)$
- prop!-simp1(l1,l2,nil,0,1)$
- symbolic procedure prop!-simp1(l1,l2,s,lngth,sgn)$
- if null l2 then list(lngth,sgn) . (l1 . sreverse s)
- else
- (lambda z$ if null z then
- prop!-simp1(l1,cdr l2,car l2 . s,lngth,sgn)
- else prop!-simp1(cdr z,cdr l2,s,add1 lngth,
- (car z)*sgn*(-1)**(length s)) )
- prop!-simp2(l1,car l2)$
- symbolic procedure prop!-simp2(l,ind)$
- begin
- scalar sign$
- if sign:=index!-in(ind,l) then
- return ((-1)**(length(l)-length(sign))) . delete(ind,l)
- else return nil
- end$
- symbolic procedure mk!-contract!-coeff u$
- if caar u = 0 then 1
- else
- begin
- scalar numr,denr,pk,k$
- pk:=caar u$
- k:=length cadr u$
- numr:=constimes ((cadar u) .mk!-numr(ndim!*,k,k+pk))$
- % denr:=f!^(pk+k,k)*(cadar u)$
- return numr
- end$
- symbolic procedure mk!-numr(n,k,p)$
- if k=p then nil
- else (if k=0 then n else list('difference,n,k)) . mk!-numr(n,add1 k,p)$
- symbolic procedure mod!-index(term,dump)$
- %-------------------------------------------------------------------
- % MODYFIES INDECES OF "DUMP" VIA DELTAS IN "TERM"
- % DELETES UTILIZED DELTAS FROM "TERM"
- % RETURNS "TERM" . "DUMP"
- %------------------------------------------------------------------$
- begin
- scalar coeff,sign$
- coeff:=list 1$
- term:= if sign:= eq(car term,'minus) then cdadr term
- else cdr term$
- while term do << if free car term then
- coeff:=(car term) . coeff
- else dump:=mod!-dump(cdar term,dump)$
- term:=cdr term >>$
- return
- ( if sign then
- if null cdr coeff then (-1)
- else 'minus . list(constimes coeff)
- else if null cdr coeff then 1
- else constimes coeff ) . dump
- end$
- symbolic procedure dpropagator(l1,l2,dump)$
- (lambda z$
- if z=0 then z
- else if z=1 then nil . dump
- else for each trm in cdr z collect
- mod!-index(trm,dump) )
- propagator(l1,l2)$
- symbolic procedure dvertex!-to!-projector(svert,rlst,dump)$
- begin
- scalar l1,l2,coeff,w$
- l1:=mktails(cadr svert,rlst,dump)$
- if repeatsp car l1 then return 0$
- l2:= mktails(caddr svert,rlst,cdr l1)$
- if repeatsp car l2 then return 0$
- dump:=cdr l2$
- w:=prop!-simp(car l1,sreverse car l2)$
- coeff:=mk!-contract!-coeff w$
- return coeff . dpropagator(cadr w,cddr w,dump)
- end$
- %SYMBOLIC PROCEDURE DSTR!-TO!-ALG(STRAND,RLST,DUMP)$
- %IF NULL STRAND THEN LIST('RECIP,MK!-COEFF1(DUMP,RLST))
- %ELSE
- % BEGIN
- % SCALAR VRTX$
- % VRTX:=DVERTEX!-TO!-PROJECTOR(CAR STRAND,RLST,DUMP)$
- % IF 0=VRTX THEN RETURN 0$
- % IF NULL CADR VRTX THEN RETURN
- % LIST('TIMES,CAR VRTX,DSTR!-TO!-ALG(CDR STRAND,RLST,CDDR VRTX))$
- %
- % RETURN LIST('TIMES,CAR VRTX,
- % 'PLUS . (FOR EACH TRM IN CDR VRTX COLLECT
- % LIST('TIMES,CAR TRM,DSTR!-TO!-ALG(CDR STRAND,RLST,CDR TRM))) )
- %===MODYFIED 4.07.89
- remflag('(dstr!-to!-alg),'lose)$
- symbolic procedure dstr!-to!-alg(strand,rlst,dump)$
- %IF NULL STRAND THEN LIST('RECIP,MK!-COEFF1(DUMP,RLST))
- if null strand then consrecip list(mk!-coeff1(dump,rlst))
- else
- begin
- scalar vrtx$
- vrtx:=dvertex!-to!-projector(car strand,rlst,dump)$
- if 0=vrtx then return 0$
- if null cadr vrtx then return
- if 1 = car(vrtx) then
- dstr!-to!-alg(cdr strand,rlst,cddr vrtx)
- else
- cvitimes2(car vrtx,
- dstr!-to!-alg(cdr strand,rlst,cddr vrtx))$
- return
- cvitimes2(car vrtx,
- consplus (for each trm in cdr vrtx collect
- cvitimes2(car trm,
- dstr!-to!-alg(cdr strand,rlst,
- cdr trm))))$
- end$
- flag('(dstr!-to!-alg),'lose)$
- symbolic procedure cvitimes2(x,y)$
- if (x=0) or (y=0) then 0
- else if x = 1 then y
- else if y = 1 then x
- else list('times,x,y)$
- symbolic procedure free dlt$
- (freeind cadr dlt) and (freeind caddr dlt)$
- symbolic procedure freeind ind$
- atom ind $
- % AND
- %LAGP(IND,'EXTRNL)$
- symbolic procedure mod!-dump(l,dump)$
- if not freeind car l then mod!-dump1(cadr l,car l,dump)
- else mod!-dump1(car l,cadr l,dump)$
- symbolic procedure mod!-dump1(new,old,dump)$
- if null dump then nil
- else ( (caar dump) . l!-subst(new,old,cdar dump) ) .
- mod!-dump1(new,old,cdr dump)$
- symbolic procedure l!-subst(new,old,l)$
- if null l then nil
- else if old = car l then new . l!-subst(new,old,cdr l)
- else car l . l!-subst(new,old,cdr l) $
- endmodule$
- %********************************************************************$
- % $
- % INTERFACE WITH RODIONOV!-FIERZING ROUTE. 17.02.88 $
- % $
- %********************************************************************$
- module interfierz$
- exports calc_map_tar,calc_den_tar,pre!-calc!-map_ $
- imports mk!-numr,map_!-to!-strand $
- lisp$
- %----------- DELETING VERTS WITH _0'S ------------------------------$
- %symbolic procedure sort!-map_(map_,tadepoles,deltas,s)$
- %if null map_ then list(s,tadepoles,deltas)
- %else
- % begin
- % scalar vert,edges$
- % vert:=incident1('!_0,car map_,'ll)$
- % return
- % if null vert then sort!-map_(cdr map_,tadepoles,deltas,
- % car map_ . s)
- % else if car vert = cadr vert then
- % sort!-map_(cdr map_,caar vert . tadepoles,deltas,s)
- % else sort!-map_(cdr map_,tadepoles,list('cons,caar vert,
- % caadr vert) . deltas,s)
- % end$
- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- %%%%% modified 17.09.90 A.Taranov %%%%%%%%%%%%%%%%%%%%%
- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- symbolic procedure sort!-map_(map_,tadepoles,deltas,poles,s)$
- % tadepoles are verts with 1 0_ edge and contracted others
- % deltas are verts with 1 0_ edge
- % poles are verts with at list 2 0_ edges
- if null map_ then list(s,tadepoles,deltas,poles)
- else
- begin
- scalar vert,tdp$
- vert:=incident1('!_0,car map_,'ll)$
- if null vert then tdp:=tadepolep car map_
- else %%%% vertex contain !_0 edge
- return
- if (caar vert = '!_0) then
- sort!-map_(cdr map_,tadepoles,deltas,caadr vert . poles,s)
- else if (caadr vert = '!_0) then
- sort!-map_(cdr map_,tadepoles,deltas,caar vert . poles,s)
- else if car vert = cadr vert then
- sort!-map_(cdr map_,caar vert . tadepoles,deltas,
- poles,s)
- else sort!-map_(cdr map_,tadepoles,list('cons,
- caar vert,caadr vert) . deltas,poles,
- s)$
- %%%%% here car Map_ was checked to be a real tadpole
- return
- if null tdp then sort!-map_(cdr map_,tadepoles,deltas,
- poles,car map_ . s)
- else sort!-map_(cdr map_,cadr tdp . tadepoles,deltas,
- caar tdp . poles,s)
- end$
-
- symbolic procedure tadepolep vrt; %%%%%% 17.09.90
- % return edge1 . edge2 if vrt is tadpole,
- % NIL otherwise.
- % edge1 correspond to 'pole', edge2 - to 'loop' of a tadpole.
- if car vrt = cadr vrt then caddr vrt . car vrt
- else if car vrt = caddr vrt then cadr vrt . car vrt
- else if cadr vrt = caddr vrt then car vrt . cadr vrt
- else nil;
- symbolic procedure del!-tades(tades,edges)$
- if null tades then edges
- else del!-tades(cdr tades,delete(car tades,edges))$
- symbolic procedure del!-deltas(deltas,edges)$
- if null cdr deltas then edges
- else del!-deltas(cdr deltas,del!-tades(cdar deltas,edges))$
- %--------------- EVALUATING MAP_S -----------------------------------$
- symbolic procedure pre!-calc!-map_(map_,edges)$
- % : (STRAND NEWMAP_ TADEPOLES DELTAS)$
- begin
- scalar strand,w$
- w:=sort!-map_(map_,nil,list 1,nil,nil)$
-
- % delete from edge list deltas,poles and tades
- edges:=del!-deltas(caddr w,
- del!-tades(cadr w,delete('!_0,edges)))$
- strand:= if car w then map_!-to!-strand(edges,car w)
- else nil$
- return strand . w
- end$
- symbolic procedure calc_map_tar(gstrand,alst)$
- % THIRD VERSION.$
- begin
- scalar poles,edges,strand,deltas,tades,map_$
- strand:=car gstrand$
- map_:=cadr gstrand$
- tades:=caddr gstrand $
- deltas:=car cdddr gstrand $
- poles:= car cddddr gstrand $
- if ev!-poles(poles,alst) then return 0; %%%%% result is zero
- return constimes list(constimes deltas,
- constimes ev!-tades(tades,alst),
- (if null map_ then 1
- else strand!-alg!-top(strand,map_,alst)))
- end$
- symbolic procedure ev!-poles(poles,alst)$ %%% 10.09.90
- if null poles then nil
- else if getedge(car poles,alst) = 0 then ev!-poles(cdr poles,alst)
- else poles$
- symbolic procedure ev!-deltas(deltas)$
- if null deltas then list 1
- else ('cons . car deltas) . ev!-deltas(cdr deltas)$
- symbolic procedure ev!-tades(tades,alst)$
- if null tades then list 1
- else binc(ndim!*,getedge(car tades,alst))
- . ev!-tades(cdr tades,alst)$
- %------------------------ DENOMINATOR CALCULATION -------------------$
- symbolic procedure ev!-edgeloop(edge,alst)$
- % EVALUATES LOOP OF 'EDGE' COLORED VIA 'ALST'$
- binc(ndim!*,getedge(s!-edge!-name edge,alst) )$
- symbolic procedure ev!-denom2(vert,alst)$
- % EVALUATES DENOM FOR PROPAGATOR$
- ev!-edgeloop(car vert,alst)$
- symbolic procedure ev!-denom3(vert,alst)$
- % EVALUATES DENOM FOR 3 - VERTEX$
- begin
- scalar e1,e2,e3,lines,sign,!3j,numr$
- e1:=getedge(s!-edge!-name car vert,alst)$
- e2:=getedge(s!-edge!-name cadr vert,alst)$
- e3:=getedge(s!-edge!-name caddr vert,alst)$
- lines:=(e1+e2+e3)/2$
- e1:=lines-e1$
- e2:=lines-e2$
- e3:=lines-e3$
- sign:=(-1)**(e1*e2+e1*e3+e2*e3)$
- numr:=mk!-numr(ndim!*,0,lines)$
- numr:=(if numr then (constimes numr)
- else 1)$
- !3j:=listquotient(numr,
- factorial(e1)*factorial(e2)*factorial(e3)*sign)$
- return !3j
- end$
- symbolic procedure binc(n,p)$
- % BINOMIAL COEFF C(N,P)$
- if 0 = p then 1 else
- listquotient(constimes mk!-numr(n,0,p),factorial p)$
- symbolic procedure calc_den_tar(den_,alst)$
- (lambda u$ if null u then 1
- else if null cdr u then car u
- else constimes u )
- denlist(den_,alst)$
- symbolic procedure denlist(den_,alst)$
- if null den_ then nil
- else if length car den_ = 2 then
- ev!-denom2(car den_,alst) . denlist(cdr den_,alst)
- else ev!-denom3(car den_,alst) . denlist(cdr den_,alst)$
- endmodule$
- module cvitmapping$
- 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;
|