cvitmap.red 79 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384
  1. module cvitmap;
  2. exports calc_spur$
  3. imports simp!*,reval,calc_map_tar ,calc_den_tar,spaces$
  4. % SIMP!* AND REVAL REDUCE SYSTEM GENERAL FUNCTIONS FOR
  5. % EVALUATING ALGEBRAIC EXPRESSIONS.
  6. %*********************************************************************
  7. % *
  8. % FOR CVITANOVIC GAMMA MATRICES *
  9. % CALCULATIONS *
  10. % *
  11. % *
  12. % 18.03.88 10.06.90 15.06.90 31.08.90 *
  13. % 01.09.90 11.09.90 14.09.90 *
  14. %********************************************************************$
  15. lisp$
  16. % 07.06.90 all MAP was replaced by MAP_
  17. % 07.06.90 all DEN was replaced by DEN_
  18. % 07.06.90 all PROP was replaced by PROP_
  19. % SOME FUNCTIONS WAS MOVED TO SMACRO SECTION 08.06.90 10.06.90
  20. %**********************************************************************
  21. % *
  22. % _DATA_STRUCTURE *
  23. % *
  24. % WORLD::=(EDGELIST,VARIANTS,WORLD1) *
  25. % WORLD1::=(MAP_2,COEFF,DEN_OM) *
  26. % MAP_2::=(MAP_S,VARIANTS,PLAN) *
  27. % MAP_S::=(EDGEPAIR . GSTRAND) *
  28. % MAP_1::=(EDGEPAIR . MAP_) *
  29. % EDGEPAIR::=(OLDEDGELIST . NEWEDGELIST) *
  30. % COEFF::=LIST OF WORLDS (UNORDERED) *
  31. % ATLAS::=(MAP_,COEFF,DEN_OM) *
  32. % MAP_::=LIST OF VERTICES (UNORDERED) *
  33. % VERTEX::=LIST OF EDGES (CYCLIC ORDER) *
  34. % VERTEX::=(NAME,PROP_ERTY,TYPE) *
  35. % NAME::=ATOM *
  36. % PROP_ERTY::= (FIRSTPARENT . SECONDPARENT) *
  37. % TYPE::=T OR NIL *
  38. % *
  39. %*********************************************************************$
  40. %========================== PREDICATES =============================$
  41. symbolic procedure is_indexp x$ % 01.09.90 RT
  42. (lambda z$
  43. z and cdr z)
  44. assoc(s_edge_name x,dindices!*)$
  45. symbolic procedure mk_edge_name (name1,name2)$
  46. % GENERATE NEW EDGE NAME $
  47. << n_edge := n_edge +1$
  48. %INTERN COMPRESS APPEND(MK_NAME1 NAME1,
  49. compress append(mk_name1 name1,
  50. append ( mk_name1 n_edge ,
  51. mk_name1 name2)) >> $
  52. symbolic procedure new_edge (fedge,sedge)$
  53. % GENERATE NEW EDGE $
  54. begin
  55. scalar s$
  56. s:=
  57. mk_edge ( mk_edge_name ( s_edge_name fedge,
  58. s_edge_name sedge),
  59. mk_edge_prop_ ( s_edge_name fedge,
  60. s_edge_name sedge),
  61. mk_edge_type ( nil,
  62. nil))$
  63. % MK_EDGE_TYPE ( S_EDGE_TYPE FEDGE,
  64. % S_EDGE_TYPE SEDGE))$
  65. new_edge_list := s . new_edge_list $
  66. return s
  67. end$
  68. symbolic procedure delete_vertex (vertex,map_)$
  69. %DELETS VERTEX FROM MAP_$
  70. if p_empty_map_ map_ then mk_empty_map_ ()
  71. else
  72. if p_eq_vertex (vertex,s_vertex_first map_)
  73. then s_map__rest map_
  74. else
  75. add_vertex (s_vertex_first map_,
  76. delete_vertex (vertex,s_map__rest map_))$
  77. %====================== PREDICATES (CONTINUE) =====================$
  78. symbolic procedure p_eq_vertex (vertex1,vertex2)$
  79. % VERTICES ARE EQ IF THEY HAVE EQUAL NUMBER OF EDGES
  80. % IN THE SAME ORDER WITH EQUAL _NAMES $
  81. if p_empty_vertex vertex1 then p_empty_vertex vertex2
  82. else
  83. if p_empty_vertex vertex2 then nil
  84. else
  85. if equal_edges (first_edge vertex1,
  86. first_edge vertex2)
  87. then p_eq_vertex (s_vertex_rest vertex1,
  88. s_vertex_rest vertex2)
  89. else nil$
  90. %::::::::::::::::::::::: SOME ROUTINES :::::::::::::::::::::::::::::$
  91. symbolic procedure mk_old_edge x$
  92. begin
  93. scalar s$
  94. s:=assoc(x,old_edge_list )$
  95. if s then return s$
  96. s:=mk_edge ( x,
  97. if not gamma5p x
  98. then mk_edge_prop_ (1,1) %10.06.90 RT
  99. else mk_edge_prop_ (ndim!*,ndim!*),
  100. mk_edge_type (t,t))$
  101. old_edge_list :=cons(s,old_edge_list )$
  102. return s
  103. end$
  104. symbolic procedure change_name (name,edge)$
  105. % CHANGES EDGE'S NAME $
  106. mk_edge (name,
  107. s_edge_prop_ edge,
  108. s_edge_type edge )$
  109. %======================= PREDICATES (CONTINUE) ================== $
  110. symbolic procedure is_tadpole vertex$ %11.09.90 RT
  111. % RETURNS T IF THERE IS ONLY ONE EXTERNAL LEG
  112. is_tadpolen(vertex) < 2$
  113. symbolic procedure is_tadpolen vertex$ %11.09.90 RT
  114. % RETURNS NUMBER OF EXTERNAL LEGS
  115. vertex_length diff_legs(vertex,mk_empty_vertex())$
  116. symbolic procedure diff_legs(vertex,vertex1)$ %11.09.90 RT
  117. % RETURNS LIST OF EXTERNAL LEGS
  118. if p_empty_vertex vertex then vertex1
  119. else if p_member_edge(first_edge vertex,
  120. s_vertex_rest vertex)
  121. or
  122. p_member_edge(first_edge vertex,
  123. vertex1)
  124. then diff_legs(s_vertex_rest vertex,vertex1)
  125. else diff_legs(s_vertex_rest vertex,
  126. add_edge(first_edge vertex,vertex1))$
  127. symbolic procedure is_buble (vertex1,vertex2)$
  128. % RETURNS NIL IF VERTEX1 AND VERTEX2 DOES NOT FORMED A BUBLE,
  129. % OR N . MAP_ ,WHERE N IS A NUMBER OF EXTERNAL LINES ( 0 OR 2 ),
  130. % MAP_ IS A MAP_ CONTAINING THIS BUBLE $
  131. %NOT(IS_TADPOLE VERTEX1) AND NOT(IS_TADPOLE VERTEX2) AND %14.09.90 RT
  132. (lambda z$ if z >= 2 then nil
  133. else (2*z) . mk_vertex2_map_ (vertex1,vertex2))
  134. vertex_length ( diff_vertex (vertex1,vertex2))$
  135. %^^^^^^^^^^^^^^^^^^^^^^^ MAIN PROGRAM ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^$
  136. symbolic procedure transform_map_ map_$
  137. % GENERATE SIMPLE MAP_ (ONLY PRIMITIVE VERTICES) FROM INITIAL ONE$
  138. begin
  139. scalar n_edge$
  140. n_edge := 0$
  141. new_edge_list :=nil$
  142. old_edge_list :=nil$
  143. return
  144. mk_simple_map_
  145. (for each vertex in map_ collect
  146. prepare_map_ vertex)$
  147. end$
  148. %,,,,,,,,,,,,,,,,,,,,,RODIONOV & TARANOV INTERFACE ,,,,,,,,,,,,,,,$
  149. global '(bubltr freemap_)$
  150. symbolic procedure to_taranov map_$
  151. % MAP_ IS INITIAL MAP_,
  152. % RETURNS (FULL LIST OF EDGES (INITIAL AND GENERATED) .
  153. % (MAP_ OF PRIMITIVE VERTICES ) .
  154. % (LIST OF ALL POSSIBLE ENUMERATION OF MAP_'S EDGES) $
  155. begin
  156. scalar new_edge_list ,old_edge_list ,full_edge_list ,
  157. new_map_ ,free_map_ ,marks ,variants ,alst ,bubles$
  158. new_map_ :=transform_map_ map_$
  159. free_map_ :=find_bubltr new_map_ $
  160. bubles:=car free_map_ $
  161. bubltr:=bubles $
  162. free_map_ := cdr free_map_ $
  163. freemap_:=free_map_ $
  164. full_edge_list := for each edge in old_edge_list collect
  165. s_edge_name edge $
  166. alst:=nconc(for each x in full_edge_list collect (x . 1) ,
  167. list('!_0 . 0) ) $ %ADD EMPTY EDGE $
  168. marks:=set_mark (new_edge_list ,
  169. nil,
  170. buble_proves bubles,
  171. new_map_ ,
  172. add_tadpoles (bubles,alst))$
  173. variants:=edge_bind (marks,alst)$
  174. full_edge_list :=nconc (for each edge in new_edge_list collect
  175. s_edge_name edge,
  176. full_edge_list )$
  177. return full_edge_list .
  178. new_map_ .
  179. variants
  180. end$
  181. % TEST TEST TEST TEST TEST TEST TEST TEST TEST TEST $
  182. % TO_TARANOV '((A B C C B A)) $
  183. %END$ %cvit2.red
  184. %********************************************************************
  185. % NOW WE MARKED THE MAP_ *
  186. %*******************************************************************$
  187. % 09.03.88 $
  188. lisp$
  189. global '(ndim!* )$
  190. %ERROERRORERRORERRORERROR ERROR ROUTINES ERRORERRORERRORERRORERROR $
  191. global '(!*cviterror)$
  192. flag('(cviterror),'switch)$
  193. !*cviterror:=t$ % IF T THEN ERROR MESSAGES WILL BE PRINTED$
  194. % The FEXPR for set_error has been re-written by JPff
  195. %%% symbolic fexpr procedure set_error u$
  196. %%% if !*cviterror then set_error0 (u,alst)
  197. %%% else
  198. %%% error(55,"ERROR IN MAP_ CREATING ROUTINES") $
  199. symbolic macro procedure set_error u$
  200. list('set_error_real,mkquote cadr u,cons('list,cddr u))$
  201. symbolic procedure set_error_real (u,v)$
  202. <<
  203. if !*cviterror then <<
  204. prin2 "Function: "$
  205. prin2 car u$
  206. prin2 " Arguments: "$
  207. if v then for each x in v do <<
  208. prin2 x$ prin2 " IS " $
  209. prin2 x$
  210. terpri() >>;
  211. >>;
  212. error(55,"Error in MAP_ creating routines")
  213. >>$
  214. %ERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERERE$
  215. symbolic procedure mark_edges (newedges,oldedges,map_)$
  216. mk_proves (map_,oldedges) .
  217. set_mark (newedges,nil,nil,map_,
  218. for each x in oldedges collect (s_edge_name x .
  219. car s_edge_prop_ x ) ) $
  220. symbolic procedure mk_proves (map_,oldedges)$
  221. if p_empty_map_ map_ then nil
  222. else
  223. if defined_vertex (s_vertex_first map_,oldedges) then
  224. s_vertex_first map_ .
  225. mk_proves (s_map__rest map_,oldedges)
  226. else
  227. mk_proves (s_map__rest map_,oldedges)$
  228. symbolic procedure defined_vertex (vertex,oldedges)$
  229. if p_empty_vertex vertex then t
  230. else
  231. memq_edgelist (first_edge vertex,oldedges)
  232. and
  233. defined_vertex (s_vertex_rest vertex,oldedges)$
  234. symbolic procedure set_mark (edges,notdef,toprove,map_,blst)$
  235. % EDGES - LIST OF NEW EDGES CREATED WHILE MAKING A MAP_,
  236. % NOTDEF - LIST OF EDGES WHICH CANNOT BE FULLY IDEN_TIFY,
  237. % TOPROVE - LIST OF VERTICES FOR CHECKING TRIANGLE RULE,
  238. % MAP_ - MAP_ CREATED EARLIER,
  239. % BLST - ALIST OF BINDED EDGES$
  240. if null edges then
  241. if notdef or toprove then % 15.06.90 RT
  242. set_error_real('set_mark,
  243. list(edges,notdef,toprove,map_,blst))
  244. else nil
  245. else
  246. (lambda z$
  247. if z then %THE EDGE IS FULLY DEFINED$
  248. set_prove (append(notdef, %RESTOR LIST OF EDGES$
  249. cdr edges),
  250. car edges,
  251. append(new_prove (car edges, %ADD CHECKS$
  252. map_),
  253. toprove),
  254. map_,
  255. (s_edge_name car edges . 0) .
  256. blst)
  257. else
  258. set_mark (cdr edges, %TRY NEXT$
  259. car edges . notdef, % ADD NOT DEF. LIST$
  260. toprove,
  261. map_,
  262. blst))
  263. ( assoc(caadar edges,blst) %CHECK IF BOTH PARENT IS $
  264. and %ALREADY DEFINED $
  265. assoc(cdadar edges,blst) ) $
  266. symbolic procedure new_prove (edge,map_)$
  267. % RETURNS NEW VERTEX FOR TRIANGLE RULE CHECKING LIST$
  268. if null map_ then nil
  269. else
  270. (lambda z$ if z then list z
  271. else new_prove (edge,cdr map_))
  272. new_provev (edge,car map_) $
  273. symbolic procedure new_provev (edge,vertex)$
  274. % CAN THIS VERTEX BE UTILIZED FOR CHECKING ? $
  275. if not member(edge,vertex) then nil
  276. else
  277. if (assoc(caadr edge,vertex)
  278. and
  279. assoc(cdadr edge,vertex))
  280. then nil
  281. else vertex $
  282. symbolic procedure is_son (edge,vertex)$
  283. assoc(car s_edge_prop_ edge,vertex)$
  284. symbolic procedure not_parents (edge,proves)$
  285. if null proves then nil
  286. else
  287. if is_son (edge,car proves)
  288. then cdr proves
  289. else car proves . not_parents (edge,cdr proves)$
  290. symbolic procedure set_prove (edges,edge,toprove,map_,blst)$
  291. % RETURNS A PAIR (EDGE . (LIST FOF VERICES FOR TRIANGLE RULE TEST))$
  292. (lambda z$
  293. (edge . not_parents (edge,car z)) .
  294. set_mark (edges,nil,cdr z,map_,blst))
  295. find_proved (toprove,nil,nil,blst)$
  296. symbolic procedure find_proved (toprove,proved,unproved,blst)$
  297. % RETURNS A PAIR ((LIST OF ALREADY DEFINED VERTICES) .
  298. % (LIST OF NOT YET DEFINED EDGES) ) $
  299. if null toprove then proved . unproved
  300. else
  301. if is_proved (car toprove,blst) then
  302. find_proved (cdr toprove,
  303. car toprove . proved,
  304. unproved,
  305. blst)
  306. else find_proved (cdr toprove,
  307. proved,
  308. car toprove . unproved,
  309. blst) $
  310. symbolic procedure is_proved (vertex,blst)$
  311. if null vertex then t
  312. else if assoc(caar vertex,blst) then is_proved (cdr vertex,blst)
  313. else nil $
  314. %@@@@@@@@@@@@@@@@@@@@@@@ NOW GENERATES ALL POSSIBLE NUMBERS @@@@@@@@$
  315. symbolic procedure mk_binding (provedge,blst)$
  316. can_be_proved (car provedge,blst)
  317. and
  318. edge_bind (cdr provedge,blst)$
  319. symbolic procedure edge_bind (edgelist,blst)$
  320. if null edgelist then list blst
  321. else
  322. begin
  323. scalar defedge,prop_,p,emin,emax,s,proves,i$
  324. % DEFEDGE - EDGE WITH DEFINED RANG,
  325. % PROP_ - ITS PROP_ERTY: (NUM1 . NUM2),
  326. % P - ITS NAME,
  327. % EMIN AND EMAX - RANGE OF P,
  328. % S - TO STORE RESULTS,
  329. % PROVES - CHECKS OF TRIANGLE LAW$
  330. defedge:=car edgelist$
  331. proves:=cdr defedge$
  332. defedge:=car defedge$
  333. edgelist:=cdr edgelist$
  334. p:=s_edge_name defedge$
  335. prop_:=s_edge_prop_ defedge$
  336. emin:=assoc(car prop_,blst)$
  337. emax:=assoc(cdr prop_,blst)$
  338. if null emin or null emax
  339. then set_error_real ('edge_bind,list(prop_,blst))$
  340. prop_:=(cdr emin) . (cdr emax)$
  341. emin:=abs((car prop_)-(cdr prop_))$
  342. emax:=(car prop_)+(cdr prop_)$
  343. if numberp ndim!* then %NUMERICAL DIMENSIONAL$
  344. << emax:=min(emax,ndim!*)$
  345. if emin > ndim!* then return nil >> $
  346. i:=emin$
  347. loop:
  348. if i > emax then return s$
  349. if can_be_proved (proves,(p . i) . blst)
  350. then s:=append(edge_bind (edgelist,
  351. (p . i) . blst),
  352. s) $
  353. i:=i+2$
  354. go loop
  355. end$
  356. symbolic procedure can_be_proved (proves,blst)$
  357. if null proves then t
  358. else if can_be_p (car proves,blst) then
  359. can_be_proved (cdr proves,blst)
  360. else nil$
  361. symbolic procedure can_be_p (vertex,blst)$
  362. %CHECKS TRIANGLE RULE$
  363. begin
  364. scalar i,j,k$
  365. i:=assoc(car car vertex,blst)$
  366. j:=assoc(car cadr vertex,blst)$
  367. k:=assoc(car caddr vertex,blst)$
  368. if null i or null j or null k then set_error_real('can_be_proved,
  369. list(vertex,%%edge,
  370. blst))$
  371. i:=cdr i$
  372. j:=cdr j$
  373. k:=cdr k$
  374. if numberp ndim!* and (i+j+k) > (2*ndim!*) then
  375. return nil $ %SINCE S+T+U<NDIM!* $
  376. % ======== NOW CHECK TRIANGLE RULE ======= $
  377. return
  378. if not evenp(i+j+k) or
  379. k < abs(i-j) or
  380. k > (i+j)
  381. then nil
  382. else t
  383. end$
  384. %END$ %cvit4.red
  385. %OOOOOOOOOOOOOOOOOOOOOOOOO ROUTINES TO SELECT BUBLES OOOOOOOOOOOOOOOO$
  386. lisp$ %24.05.88$
  387. symbolic procedure find_bubles atlas$
  388. find_bubles1 (atlas,old_edge_list )$
  389. symbolic procedure find_bubles_coeff (atlaslist,edgelist,bubles)$
  390. %F NULL BUBLES THEN NIL . ATLASLIST
  391. %LSE
  392. find_bubles1_coeff (atlaslist,nil,edgelist,bubles)$
  393. symbolic procedure find_bubles1_coeff (atlaslist,passed,edgelist,
  394. bubles)$
  395. if null atlaslist then bubles . passed
  396. else
  397. (lambda z$ %Z - PAIR = (BUBLES . REDUCED MAP_)
  398. find_bubles1_coeff (cdr atlaslist,
  399. cdr z . passed,
  400. edgelist,
  401. if null car z then bubles else
  402. car z . bubles) )
  403. find_bubles1 (car atlaslist,edgelist) $
  404. symbolic procedure mk_atlaslist (map_,coeff,den_om)$
  405. list mk_atlas (map_,coeff,den_om)$
  406. symbolic procedure find_bubles1 (atlas,edgelist)$
  407. select_bubles (nil,
  408. s_atlas_map_ atlas,
  409. nil,
  410. s_atlas_coeff atlas,
  411. s_atlas_den_om atlas,
  412. edgelist)$
  413. symbolic procedure select_bubles(bubles,map_,passed,coeff,den_om,al)$
  414. % RETURNS (LIST OF BUBLES ) . ATLAS,
  415. % WHERE BUBLES ARE TWO OR ONE VERTICES MAP_S $
  416. if p_empty_map_ map_ then
  417. (lambda x$
  418. car x .
  419. mk_atlas (passed,cdr x,den_om))
  420. find_bubles_coeff (coeff,
  421. union_edges (map__edges passed,
  422. al),
  423. bubles)
  424. else
  425. if (map__length map_ + map__length passed) < 3 then
  426. select_bubles (bubles,
  427. mk_empty_map_ (),
  428. append_map_s(map_,
  429. passed),
  430. coeff,
  431. den_om,
  432. al)
  433. else
  434. (lambda z$ % Z IS NIL OR A PAIR
  435. % N . MAP_ ,WHERE
  436. % N - NUMBER OF FREE EDGES$
  437. if z then %A BUBLE IS FIND$
  438. (lambda d$
  439. (lambda bool$ %BOOL=T IFF ALL EDGES CAN BE DEFINED$
  440. if car z = 0 then %NO EXTERNAL LINES$
  441. if bool then
  442. select_bubles ( z . bubles,
  443. mk_empty_map_ (),
  444. cdr z,
  445. mk_atlaslist ( conc_map_s (passed,
  446. delete_vertex (
  447. s_vertex_second
  448. cdr z,
  449. s_map__rest
  450. map_)),
  451. coeff,
  452. den_om),
  453. nil,
  454. al)
  455. else
  456. select_bubles ( z . bubles, %ADD BUBLE$
  457. delete_vertex (s_vertex_second cdr z,
  458. s_map__rest map_),
  459. passed,
  460. try_sub_atlas (mk_atlas (cdr z,
  461. nil,
  462. nil),
  463. coeff),
  464. den_om,
  465. al)
  466. else
  467. if not p_old_vertex d then
  468. if bool then
  469. select_bubles (z . bubles,
  470. mk_empty_map_ (),
  471. cdr z,
  472. mk_atlaslist (conc_map_s (passed,
  473. buble_vertex (
  474. cdr z,
  475. delete_vertex (
  476. s_vertex_second
  477. cdr z,
  478. s_map__rest
  479. map_ ),
  480. al)),
  481. coeff,
  482. den_om),
  483. list d,
  484. al)
  485. else
  486. select_bubles ( z . bubles, %ADD NEW BUBLE$
  487. buble_vertex (cdr z, %RENAME EDGES $
  488. conc_map_s (passed,
  489. delete_vertex (s_vertex_second cdr z,
  490. s_map__rest map_)),
  491. al),
  492. mk_empty_map_ (),
  493. try_sub_atlas (mk_atlas (cdr z,nil,list d),
  494. coeff),
  495. den_om,
  496. al)
  497. else
  498. if bool then
  499. select_bubles (z . bubles,
  500. mk_empty_map_ (),
  501. ren_vertmap_ (d,cdr z),
  502. mk_atlaslist (
  503. conc_map_s (
  504. passed,
  505. add_vertex (add_edge (!_0edge ,d),
  506. delete_vertex (
  507. s_vertex_second cdr z,
  508. s_map__rest map_ ))),
  509. coeff,
  510. den_om),
  511. list ren_vertices (d,d),
  512. al)
  513. else
  514. select_bubles (z . bubles,
  515. add_vertex (add_edge (!_0edge ,d),
  516. delete_vertex(s_vertex_second cdr z,
  517. s_map__rest map_)
  518. ),
  519. passed,
  520. try_sub_atlas (mk_atlas (ren_vertmap_
  521. (d,cdr z),
  522. nil,
  523. list
  524. ren_vertices (d,d)
  525. ),
  526. coeff),
  527. den_om,
  528. al )
  529. )
  530. % ALL_DEFINED (CDR Z,AL))
  531. t )
  532. delta_edges cdr z
  533. else
  534. select_bubles (bubles,
  535. s_map__rest map_,
  536. add_vertex (s_vertex_first map_,passed),
  537. coeff,
  538. den_om,
  539. al )
  540. )
  541. find_buble (s_vertex_first map_,
  542. s_map__rest map_ ) $
  543. symbolic procedure p_old_vertex vertex$
  544. % RETURNS T IFF ALL EDGES OF VERTEX ARE OLD OR VERTEX IS EMPTY ONE$
  545. if p_empty_vertex vertex then t
  546. else p_old_edge first_edge vertex
  547. and
  548. p_old_vertex s_vertex_rest vertex$
  549. symbolic procedure renames_edges (vertex,al)$
  550. rename_edges_par (first_edge vertex,
  551. second_edge vertex,
  552. al)$
  553. symbolic procedure rename_edges_par (vertex1,vertex2,al)$
  554. % Here VERTEX1 and VERTEX2 are edges!
  555. if defined_edge (vertex1,al)
  556. and not p_old_edge(vertex2) then % 14.09.90 RT
  557. replace_edge (vertex2,vertex1,new_edge_list )
  558. else
  559. if defined_edge (vertex2,al)
  560. and not p_old_edge(vertex1) then % 14.09.90 RT
  561. replace_edge (vertex1,vertex2,new_edge_list )
  562. else
  563. if p_old_edge (vertex1)
  564. and not p_old_edge(vertex2) then % 14.09.90 RT
  565. replace_edge (vertex2,vertex1,new_edge_list )
  566. else
  567. if p_old_edge (vertex2)
  568. and not p_old_edge(vertex1) then % 14.09.90 RT
  569. replace_edge (vertex1,vertex2,new_edge_list )
  570. else rename_edges (vertex1,vertex2)$
  571. symbolic procedure buble_vertex (map_2,map_,al)$
  572. if p_empty_map_ map_2 then mk_empty_map_ ()
  573. else
  574. << renames_edges (delta_edges map_2,al)$
  575. map_ >> $
  576. symbolic procedure delta_edges map_2$
  577. % MAP_2 - MAP_ OF TWO VERTICES $
  578. mk_edge2_vertex (
  579. first_edge
  580. diff_vertex (s_vertex_first map_2,
  581. s_vertex_second map_2),
  582. first_edge
  583. diff_vertex (s_vertex_second map_2,
  584. s_vertex_first map_2 )
  585. )$
  586. symbolic procedure delta_names map_2$
  587. % MAP_2 - MAP_ OF TWO VERTICES $
  588. (lambda z$
  589. s_edge_name first_edge car z .
  590. s_edge_name first_edge cdr z )
  591. (diff_vertex (s_vertex_first map_2,
  592. s_vertex_second map_2) .
  593. diff_vertex (s_vertex_second map_2,
  594. s_vertex_first map_2) ) $
  595. symbolic procedure old_rename_edges (names,map_)$
  596. if p_empty_map_ map_ then mk_empty_map_ ()
  597. else add_vertex (ren_edge (names,s_vertex_first map_),
  598. old_rename_edges (names,
  599. s_map__rest map_) ) $
  600. symbolic procedure ren_vertmap_ (vertex1,map_)$
  601. % VERTEX1 MUST BE TWO EDGE VERTEX,
  602. % EDGES OF VERTEX2 TO BE RENAME$
  603. if vertex_length vertex1 neq 2 then set_error_real ('ren_vertmap_ ,
  604. list(vertex1,map_))
  605. else old_rename_edges (s_edge_name first_edge vertex1 .
  606. s_edge_name second_edge vertex1,
  607. map_)$
  608. symbolic procedure ren_vertices (vertex1,vertex2)$
  609. % VERTEX1 MUST BE TWO EDGE VERTEX,
  610. % EDGES OF VERTEX2 TO BE RENAME$
  611. if vertex_length vertex1 neq 2
  612. then set_error_real ('ren_vertices,list(vertex1,vertex2))
  613. else ren_edge (s_edge_name first_edge vertex1 .
  614. s_edge_name second_edge vertex1,
  615. vertex2)$
  616. symbolic procedure ren_edge (names,vertex)$
  617. % NAMES IS NAME1 . NAME2,
  618. % CHANGE NAME1 TO NAME2$
  619. if null assoc(car names,vertex) then vertex %NO SUCH EDGES IN VERTEX$
  620. else ren_edge1 (names,vertex)$
  621. symbolic procedure ren_edge1 (names,vertex)$
  622. if p_empty_vertex vertex then mk_empty_vertex ()
  623. else if car names =s_edge_name first_edge vertex then
  624. add_edge ( change_name (cdr names,first_edge vertex),
  625. ren_edge1 (names ,s_vertex_rest vertex))
  626. else
  627. add_edge ( first_edge vertex,
  628. ren_edge1 (names,s_vertex_rest vertex))$
  629. symbolic procedure find_buble (vertex,map_)$
  630. if p_empty_map_ map_ then mk_empty_map_ ()
  631. else
  632. is_buble (vertex,s_vertex_first map_)
  633. or
  634. find_buble (vertex,s_map__rest map_) $
  635. symbolic procedure diff_vertex (vertex1,vertex2)$
  636. if p_empty_vertex vertex1 then mk_empty_vertex ()
  637. else
  638. if p_member_edge (first_edge vertex1,vertex2)
  639. and
  640. not equal_edges (first_edge vertex1,!_0edge )
  641. then diff_vertex (s_vertex_rest vertex1,vertex2)
  642. else
  643. add_edge (first_edge vertex1,
  644. diff_vertex (s_vertex_rest vertex1,vertex2)) $
  645. %SSSSSSSSSSSSSSSSSSSSSSSSSS NOW MAKES PROVES FROM BUBLE PPPPPPPPPPPPPP$
  646. global '(!_0edge )$
  647. !_0edge :=mk_edge ('!_0 ,
  648. mk_edge_prop_ (0,0),
  649. mk_edge_type (t,t)) $
  650. symbolic procedure buble_proves bubles$
  651. if null bubles then nil
  652. else
  653. if caar bubles = 0 %NO EXTERNAL LINES $
  654. then buble_proves cdr bubles
  655. else if caar bubles = 2 then
  656. mk_edge3_vertex (
  657. first_edge diff_vertex (
  658. s_vertex_first cdar bubles,
  659. s_vertex_second cdar bubles),
  660. first_edge diff_vertex (
  661. s_vertex_second cdar bubles,
  662. s_vertex_first cdar bubles),
  663. !_0edge ) .
  664. buble_proves cdr bubles
  665. else
  666. if caar bubles = 3 then
  667. car cdar bubles .
  668. buble_proves cdr bubles
  669. else buble_proves cdr bubles $
  670. symbolic procedure try_sub_atlas (atlas,atlaslist)$
  671. if null atlaslist then list atlas
  672. else
  673. if sub_map__p (s_atlas_map_ atlas,
  674. s_atlas_den_om car atlaslist)
  675. then try_sub_atlas (mk_sub_atlas (atlas,car atlaslist),
  676. % THEN TRY_SUB_ATLAS (MK_SUB_ATLAS (CAR ATLASLIST,
  677. % ATLAS ),
  678. cdr atlaslist)
  679. else car atlaslist .
  680. try_sub_atlas (atlas,cdr atlaslist)$
  681. symbolic procedure sub_map__p (map_1,den_)$
  682. %MAP_1 AND DEN_ HAVE COMMON VERTEX (DEN_ - DEN_OMINATOR)$
  683. if p_empty_map_ map_1 then nil
  684. else sub_vertex_map_ (s_vertex_first map_1,den_)
  685. or
  686. sub_map__p (s_map__rest map_1,den_)$
  687. symbolic procedure sub_vertex_map_ (vertex,den_)$
  688. if null den_ then nil
  689. else p_common_den_ (vertex,car den_)
  690. or
  691. sub_vertex_map_ (vertex,cdr den_)$
  692. symbolic procedure p_common_den_ (vertex,vertexd)$
  693. (lambda n$
  694. if n = 3 then %TRIANGLE
  695. p_eq_vertex (vertex,vertexd)
  696. else
  697. if n = 2 then %KRONEKER
  698. p_member_edge (first_edge vertexd,vertex)
  699. else nil )
  700. vertex_length vertexd $
  701. symbolic procedure mk_sub_atlas (atlas1,atlas2)$
  702. mk_atlas (s_atlas_map_ atlas1,
  703. atlas2 . s_atlas_coeff atlas1,
  704. s_atlas_den_om atlas1)$
  705. symbolic procedure all_defined (map_,al)$
  706. all_defined_map_ (map_,
  707. defined_append(map__edges map_,al))$
  708. symbolic procedure all_defined_map_ (map_,al)$
  709. al1_defined_map_ (map_,mk_empty_map_ (),al)$
  710. symbolic procedure al1_defined_map_ (map_,passed,al)$
  711. % T IF ALL EDGES IN MAP_ CAN BE DEFINED $
  712. if p_empty_map_ map_ then
  713. if p_empty_map_ passed then t
  714. else nil
  715. else
  716. if all_defined_vertex (s_vertex_first map_,al) then
  717. al1_defined_map_ (conc_map_s(passed,s_map__rest map_),
  718. mk_empty_map_ (),
  719. append(vertex_edges s_vertex_first map_ ,al))
  720. else
  721. al1_defined_map_ (s_map__rest map_,
  722. add_vertex (s_vertex_first map_,passed),
  723. al)$
  724. symbolic procedure all_defined_vertex (vertex,al)$
  725. al1_defined_vertex (vertex,mk_empty_vertex (),
  726. mk_empty_vertex (),al)$
  727. symbolic procedure al1_defined_vertex (vertex,passed,defined,al)$
  728. % T IF ALL EDGES IN VERTEX CAN BE DEFINED $
  729. if p_empty_vertex vertex then
  730. if p_empty_vertex passed then t
  731. else re_parents (passed,defined)
  732. else
  733. if defined_edge (first_edge vertex,al)
  734. then
  735. al1_defined_vertex (conc_vertex(passed,s_vertex_rest vertex),
  736. mk_empty_vertex (),
  737. add_edge (first_edge vertex,defined),
  738. first_edge vertex . al)
  739. else
  740. al1_defined_vertex (s_vertex_rest vertex,
  741. add_vertex (first_edge vertex,passed),
  742. defined,
  743. al)$
  744. symbolic procedure re_parents (passed,defined)$
  745. %TRY TO MAKE NEW PARENTS
  746. if vertex_length passed = 1 and vertex_length defined = 2
  747. then make_new_parents (first_edge passed,defined)
  748. else nil$
  749. symbolic procedure make_new_parents (edge,vertex)$
  750. %VERTEX CONSISTS OF TWO EDGES
  751. add_parents0 (edge,
  752. s_edge_name first_edge vertex .
  753. s_edge_name second_edge vertex ,
  754. t)$
  755. %^.^.^.^.^.^.^.^.^.^.^.^.^.^.^..^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^.^
  756. % 13.05.88
  757. symbolic procedure p_def_edge edge$
  758. s_edge_type edge$
  759. %P_OLD_EDGE EDGE$
  760. symbolic procedure defined_edge (edge,al)$
  761. p_old_edge edge
  762. or
  763. defined_all_edge (all_edge (s_edge_name edge,new_edge_list ),
  764. nil,
  765. al) $
  766. symbolic procedure all_edge (edgename,edgelist)$
  767. if null edgelist then nil
  768. else
  769. if edgename eq s_edge_name car edgelist then
  770. car edgelist . all_edge (edgename,cdr edgelist)
  771. else all_edge (edgename,cdr edgelist)$
  772. symbolic procedure def_edge (edge,al)$
  773. (lambda z$
  774. assoc(car z,al) and assoc(cdr z,al))
  775. s_edge_prop_ edge$
  776. symbolic procedure defined_all_edge (edgelist,passed,al)$
  777. if null edgelist then nil
  778. else
  779. if def_edge (car edgelist,al) then
  780. if p_def_edge car edgelist then t %REPLACE WAS ALREADY DONE
  781. else rep_edge_prop_ (nconc(passed,edgelist),
  782. s_edge_prop_ car edgelist . list t)
  783. else defined_all_edge (cdr edgelist,
  784. car edgelist . passed,
  785. al)$
  786. symbolic procedure rep_edge_prop_ (edgelist,prop_)$
  787. if null edgelist then t
  788. else << rplacd(car edgelist,prop_)$ %CHANGE EDGE PARENTS
  789. rep_edge_prop_ (cdr edgelist,prop_) >> $
  790. %END$ %cvit6.red
  791. %<><><><><><><><><><><> ROUTINES FOR SELECTING TRIANGLES <><><><><><>$
  792. %24.05.88$
  793. global '(!*cvitbtr !*cviterror)$
  794. flag('(cvitbtr),'switch)$
  795. !*cvitbtr:=t$ %IF T THEN BUBLES AND TRIANGLES WILL BE
  796. % FACTORIZED
  797. !*cviterror:=t$ %IF T THEN ERROR MESSAGES WILL BE PRINTED
  798. symbolic procedure find_triangles atlas$
  799. find_triangles1 (atlas,old_edge_list)$
  800. symbolic procedure find_triangles1 (atlas,al)$
  801. select_triangles (nil,
  802. s_atlas_map_ atlas,
  803. nil,
  804. s_atlas_coeff atlas,
  805. s_atlas_den_om atlas,
  806. al)$
  807. symbolic procedure find_triangl_coeff (atlaslist,edgelist,triangles)$
  808. find_triangle_coeff (atlaslist,nil,edgelist,triangles)$
  809. symbolic procedure find_triangle_coeff(atlaslist,passed,edgelist,
  810. triangles)$
  811. if null atlaslist then triangles . passed
  812. else
  813. (lambda z$ % Z - PAIR= (TRIANGLES . REDUCED MAP_)
  814. find_triangle_coeff (cdr atlaslist,
  815. cdr z . passed,
  816. edgelist,
  817. if null car z then triangles
  818. else car z . triangles))
  819. find_triangles1 (car atlaslist,edgelist)$
  820. symbolic procedure select_triangles (triangles,map_,passed,
  821. coeff,den_om,al)$
  822. %RETURNS A PAIR OF THE FORM ( (LIST OF TRIANGLES) . (ATL.WITHOUT TR.))$
  823. if p_empty_map_ map_ then %No triangles found.
  824. (lambda x$
  825. car x .
  826. mk_atlas (passed,cdr x,den_om))
  827. find_triangl_coeff (coeff,
  828. union_edges (map__edges passed,al),
  829. triangles)
  830. else
  831. if (map__length map_ + map__length passed) < 4 then
  832. select_triangles (triangles,
  833. mk_empty_map_ (),
  834. append_map_s (map_,passed),
  835. coeff,
  836. den_om,
  837. al)
  838. else
  839. (lambda z$
  840. if z then %TRIANGLE IS FOUND$
  841. (lambda trn$ %TRN - NEW VERTEX $
  842. %IF ALL_DEFINED (CDDR Z,AL) THEN
  843. if t then
  844. select_triangles (
  845. z . triangles,
  846. mk_empty_map_ (),
  847. add_vertex (trn,cddr z),
  848. mk_atlaslist (
  849. conc_map_s (
  850. mk_vertex1_map_ trn,
  851. conc_map_s (passed,delete_map_s (cddr z,map_))
  852. ),
  853. coeff,
  854. % TRN . DEN_OM ),
  855. den_om ),
  856. % NIL,
  857. list trn,
  858. al )
  859. else
  860. select_triangles ( z . triangles, %ADD NEW TRIANGLE $
  861. % SELECT_TRIANGLES ( CDDR Z . TRIANGLES, %ADD NEW TRIANGLE$
  862. conc_map_s (mk_vertex1_map_
  863. trn, %ADD NEW VERTEX$
  864. conc_map_s (passed,
  865. delete_map_s(cddr z,
  866. map_)
  867. )
  868. ),
  869. mk_empty_map_ (),
  870. try_sub_atlas (
  871. mk_atlas (add_vertex (trn,cddr z),
  872. nil,
  873. list trn),
  874. coeff ),
  875. den_om,
  876. al
  877. )
  878. )
  879. sk_vertextr z
  880. else
  881. select_triangles (triangles,
  882. s_map__rest map_,
  883. add_vertex (s_vertex_first map_,passed),
  884. coeff,
  885. den_om,
  886. al
  887. ) )
  888. reduce_triangle
  889. find_triangle (s_vertex_first map_,
  890. s_map__rest map_) $
  891. symbolic procedure vertex_neighbour (vertex,map_)$
  892. %RETURNS A MAP_ OF VERTEX NEIGHBOURS $
  893. if p_empty_vertex vertex
  894. or
  895. p_empty_map_ map_ then mk_empty_map_ ()
  896. else
  897. (lambda z$ %Z - NIL OR A PAIR (EDGE . ADJACENT EDGE )$
  898. if z then
  899. add_vertex (cdr z,
  900. vertex_neighbour (delete_edge (car z,vertex),
  901. delete_vertex (cdr z,map_)))
  902. else
  903. vertex_neighbour (vertex,s_map__rest map_))
  904. is_neighbour (vertex,
  905. s_vertex_first map_)$
  906. symbolic procedure delete_map_s (map_1,map_2)$
  907. if p_empty_map_ map_1 then map_2
  908. else delete_map_s (s_map__rest map_1,
  909. delete_vertex (s_vertex_first map_1,map_2) ) $
  910. symbolic procedure delete_edge (edge,vertex)$
  911. %DELETES EDGE FROM VERTEX $
  912. if p_empty_vertex vertex then mk_empty_vertex ()
  913. else
  914. if equal_edges (edge,first_edge vertex)
  915. then s_vertex_rest vertex
  916. else
  917. add_edge (first_edge vertex,
  918. delete_edge (edge,
  919. s_vertex_rest vertex ) ) $
  920. symbolic procedure is_neighbourp (vertex1,vertex2)$
  921. % ARE VERTEX1 AND VERTEX2 NEIGHBOURS ?
  922. if p_empty_vertex vertex1 then nil % NIL IF NOT NEIGHBOURS$
  923. else
  924. p_member_edge (first_edge vertex1,vertex2)
  925. or
  926. is_neighbourp (s_vertex_rest vertex1,vertex2)$
  927. symbolic procedure is_neighbour (vertex1,vertex2)$
  928. % ARE VERTEX1 AND VERTEX2 NEIGHBOURS ?
  929. % IF THEY ARE THEN RETURN A PAIR: (ADJ.EDGE . VERTEX2)$
  930. if p_empty_vertex vertex1 then nil % NIL IF NOT NEIGHBOURS$
  931. else
  932. (lambda z$
  933. if z then %FIRTS VERTEX IS ADJACENT TO VERTEX2$
  934. first_edge vertex1 . vertex2
  935. else is_neighbour (s_vertex_rest vertex1,
  936. vertex2 ) )
  937. p_member_edge (first_edge vertex1,
  938. vertex2)$
  939. symbolic procedure find_triangle (vertex,map_)$
  940. %FINDS TRIANGLE WICH INCLUDES THE VERTEX.
  941. %RETURNS MAP_ OF THREE VERTICES (TRIANGLE) OR NIL $
  942. (lambda z$ %Z - MAP_ OF VERTICES WICH ARE NEIGHBOURS
  943. % OF VERTEX OR (IF NO NEIGHBOURS) EMPTY MAP_$
  944. if map__length z neq 2 then nil
  945. else add_vertex (vertex,z) )
  946. is_closed vertex_neighbour (vertex,map_)$
  947. symbolic procedure is_closed map_$
  948. if p_empty_map_ map_ or
  949. p_empty_map_ s_map__rest map_ then mk_empty_map_ ()
  950. else
  951. two_neighbour (s_vertex_first map_,
  952. s_map__rest map_)
  953. or
  954. is_closed s_map__rest map_$
  955. symbolic procedure two_neighbour (vertex,map_)$
  956. % HAS VERTEX A NEIGHBOUR IN THE MAP_ ? $
  957. if p_empty_map_ map_ then nil
  958. else
  959. if is_neighbourp (vertex,s_vertex_first map_)
  960. then mk_vertex2_map_ (vertex,s_vertex_first map_)
  961. else two_neighbour (vertex,s_map__rest map_)$
  962. symbolic procedure mk_vertextr map_$
  963. %MAKES VERTEX FROM TRIANGLE MAP_$
  964. if map__length map_ neq 3 then set_error_real ('mk_vertextr ,list(map_))
  965. else
  966. mk_vertextr3 (map_,3)$
  967. symbolic procedure add_edge1(edge,vertex)$ % 14.09.90 RT
  968. if null edge then vertex
  969. else add_edge(edge,vertex)$
  970. symbolic procedure mk_vertextr3 (map_,n)$
  971. if n <= 0 then mk_empty_map_ ()
  972. else
  973. add_edge1 (take_edge (s_vertex_first map_,
  974. s_map__rest map_),
  975. mk_vertextr3 (cycl_map_ map_,n-1)) $
  976. symbolic procedure take_edge (vertex,map_)$
  977. if p_empty_vertex vertex then nil %14.09.90 RT
  978. % SET_ERROR ('TAKE_EDGE ,VERTEX,MAP_) % 14.09.90 RT
  979. else
  980. % IF P_EMPTY_VERTEX S_VERTEX_REST VERTEX THEN FIRST_EDGE VERTEX
  981. % ELSE % 14.09.90 RT
  982. if contain_edge (first_edge vertex,map_)
  983. and
  984. not equal_edges (first_edge vertex,!_0edge )
  985. then take_edge (s_vertex_rest vertex,map_)
  986. else first_edge vertex$
  987. symbolic procedure contain_edge (edge,map_)$
  988. % IS THERE A VERTEX IN THE MAP_ CONTAINING THE EDGE? $
  989. if p_empty_map_ map_ then nil
  990. else
  991. p_member_edge (edge,s_vertex_first map_)
  992. or
  993. contain_edge (edge,s_map__rest map_) $
  994. % ,,,,,,,,,,,,,,,,,,,,,,,,,,,,SORTING AFTER FACTORIZATION ,,,,,,,,,,,$
  995. % 19.05.88 $
  996. symbolic procedure find_bubltr atlas$
  997. if null !*cvitbtr then atlas else
  998. begin
  999. scalar s$
  1000. s:=errorset(list('find_bubltr0 ,mkquote atlas),
  1001. !*cviterror,
  1002. !*backtrace)$
  1003. return
  1004. if atom s then atlas
  1005. else car s
  1006. end$
  1007. symbolic procedure find_bubltr0 atlas$
  1008. %(LAMBDA Z$
  1009. % IF CAR Z THEN SORT_ATLAS CDR Z %FACTORIZATION HAPPENED
  1010. % ELSE CDR Z)
  1011. sort_atlas cdr
  1012. find_bubltr1 (atlas,old_edge_list )$
  1013. % ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,$
  1014. symbolic procedure find_bubltr1 (atlas,al)$
  1015. %FINDS BOTH BUBLES AND TRIANGLES IN ATLAS$
  1016. begin
  1017. scalar s,c,bubles$
  1018. s:=find_bubles1 (atlas,al)$
  1019. c:=car s$
  1020. atlas:=cdr s$
  1021. bubles:=append(c,bubles)$
  1022. loop:
  1023. s:=find_triangles1 (atlas,al)$
  1024. c:=car s$
  1025. atlas:=cdr s$
  1026. bubles:=append(c,bubles)$
  1027. if null c then return bubles . atlas$
  1028. s:=find_bubles1 (atlas,al)$
  1029. c:=car s$
  1030. atlas:=cdr s$
  1031. bubles:=append(c,bubles)$
  1032. if null c then return bubles . atlas$
  1033. go loop
  1034. end$
  1035. symbolic procedure reduce_triangle triangle$
  1036. % RETURN (N . VERTEX . TRIANGLE) OR NIL,
  1037. % N - NUMBER OF EXTERNAL EDGES$
  1038. if null triangle then nil
  1039. else
  1040. begin
  1041. scalar extedges,vertex,n$
  1042. %EXTEDGES - LIST OF EXTERNAL EDGES,
  1043. % N - NUMBER OF EXTERNAL EDGES,
  1044. %VERTEX - NEW VERTEX,MADE FROM TRIANGLE$
  1045. vertex:=mk_vertextr triangle$
  1046. extedges:=ext_edges vertex$
  1047. n:=length extedges$
  1048. return
  1049. if n = 1 then nil % 14.09.90 RT
  1050. else % 14.09.90 RT
  1051. n . vertex . triangle
  1052. end$
  1053. symbolic procedure sk_vertextr z$
  1054. % Z IS (N . VERTEX . TRIANGLE) $
  1055. if car z = 1 then mk_empty_vertex ()
  1056. else
  1057. if car z = 3 then cadr z
  1058. else set_error_real ('sk_vertextr,list z) $
  1059. symbolic procedure ext_edges vertex$
  1060. %SELECT EXTERNAL EDGES IN VERTEX $
  1061. if p_empty_vertex vertex then nil
  1062. else
  1063. if p_member_edge (first_edge vertex,s_vertex_rest vertex)
  1064. or
  1065. equal_edges (first_edge vertex,!_0edge )
  1066. then ext_edges delete_edge (first_edge vertex,
  1067. s_vertex_rest vertex)
  1068. else first_edge vertex .
  1069. ext_edges s_vertex_rest vertex $
  1070. symbolic procedure ext_edges_map_ map_$
  1071. %SELECT EXTERNAL EDGES OF MAP_$
  1072. if p_empty_map_ map_ then nil
  1073. else
  1074. ext_map__ver (ext_edges s_vertex_first map_,
  1075. ext_edges_map_ s_map__rest map_)$
  1076. symbolic procedure ext_map__ver (vlist,mlist)$
  1077. if null vlist then mlist
  1078. else
  1079. if memq(car vlist,mlist) then
  1080. ext_map__ver (cdr vlist,
  1081. delete(car vlist,mlist))
  1082. else ext_map__ver (cdr vlist,car vlist . mlist)$
  1083. symbolic procedure add_tadpoles (bubles,alst)$
  1084. if null bubles then alst
  1085. else
  1086. if caar bubles = 1 then
  1087. add_tadpoles (cdr bubles,
  1088. cons(cons(car mk_vertextr cadr car bubles,
  1089. 0),
  1090. alst))
  1091. else add_tadpoles (cdr bubles,alst)$
  1092. %END$ %cvit8.red
  1093. %::::::::::::::::::::::: ATLAS SORTING ROUTINES ********************** $
  1094. % 13.06.88$
  1095. lisp$
  1096. global '(!*cvitrace)$
  1097. !*cvitrace:=nil$ %IF T THEN TRACE BACTRAKING WHILE ATLAS SORTING$
  1098. flag('(cvitrace),'switch)$
  1099. symbolic procedure sort_atlas atlas$
  1100. %TOP LEVEL PROCEDURE
  1101. if null atlas then atlas
  1102. else
  1103. (lambda z$
  1104. if z then z %ATLAS FULLY SORTED
  1105. else set_error_real ('sort_atlas ,list atlas))
  1106. sort_atlas1 atlas $
  1107. symbolic procedure sort_atlas1 atlas$
  1108. (lambda z$
  1109. if z then z %ATLAS FULLY SORTED
  1110. else
  1111. if !*cviterror then print_atlas_sort (atlas,nil)
  1112. else nil )
  1113. atlas_sort (atlas,old_edge_list )$
  1114. symbolic procedure print_atlas_sort (atlas,edgelist)$
  1115. << print "Atlas not sorted "$
  1116. print_atlas atlas$
  1117. if edgelist then
  1118. << print "Defined edges: "$
  1119. for each edge in edgelist do print edge >> $
  1120. nil >> $
  1121. symbolic procedure atlas_sort (atlas,edgelist)$
  1122. begin
  1123. scalar z,newedges$
  1124. newedges:=store_edges new_edge_list$
  1125. z:=
  1126. errorset(list('atlas_sort1 ,mkquote atlas,mkquote edgelist),
  1127. !*cvitrace,
  1128. !*backtrace)$
  1129. return
  1130. if atom z then %ATLAS NOT SORTED
  1131. << restor_edges (newedges,new_edge_list)$ %RESTORE EDGES PARENTS
  1132. if !*cvitrace then print_atlas_sort (atlas,edgelist)
  1133. else nil >>
  1134. else car z
  1135. end$
  1136. symbolic procedure store_edges edgelist$
  1137. for each edge in edgelist collect
  1138. (car edge . cdr edge)$
  1139. symbolic procedure restor_edges (edgelist,newedgelist)$
  1140. if null edgelist then
  1141. if newedgelist
  1142. then set_error_real ('restor_edges ,list(edgelist,newedgelist))
  1143. else nil
  1144. else
  1145. if null newedgelist then
  1146. set_error_real ('restor_edges ,list(edgelist,newedgelist))
  1147. else
  1148. if s_edge_name car edgelist = s_edge_name car newedgelist then
  1149. << rplacd(car newedgelist,cdar edgelist)$
  1150. car newedgelist . restor_edges (cdr edgelist,
  1151. cdr newedgelist) >>
  1152. else
  1153. set_error_real ('restor_edges ,list(edgelist,newedgelist))$
  1154. symbolic procedure defined_atlas (atlas,edgelist)$
  1155. (lambda edges$
  1156. defined_edges (edges,
  1157. % DEFINED_APPEND(EDGES,EDGELIST)))
  1158. edgelist))
  1159. atlas_edges atlas$
  1160. symbolic procedure defined_append (edges,edgelist)$
  1161. if null edges then edgelist
  1162. else if defined_edge (car edges,edgelist) then
  1163. car edges . defined_append (cdr edges,edgelist)
  1164. else defined_append (cdr edges,edgelist) $
  1165. symbolic procedure defined_edges (edges,edgelist)$
  1166. if null edges then t
  1167. else
  1168. if defined_edge (car edges,edgelist)
  1169. then
  1170. defined_edges (cdr edges,car edges . edgelist)
  1171. else definedl_edges (cdr edges,list car edges,edgelist)$
  1172. symbolic procedure definedl_edges (edges,passed,edgelist)$
  1173. if null edges then null passed
  1174. else
  1175. if defined_edge (car edges,edgelist) then
  1176. defined_edges (nconc(passed,cdr edges),car edges . edgelist)
  1177. else definedl_edges (cdr edges,car edges . passed,edgelist)$
  1178. symbolic procedure atlas_sort1 (atlas,edgelist)$
  1179. if all_defined (s_atlas_map_ atlas,edgelist) then
  1180. mk_atlas (s_atlas_map_ atlas,
  1181. coeff_sortl( s_atlas_coeff atlas,
  1182. nil,
  1183. nconc( map__edges s_atlas_map_ atlas,
  1184. edgelist)),
  1185. s_atlas_den_om atlas)
  1186. else coeff_sort (coeff_ordn (s_atlas_coeff atlas,edgelist),
  1187. %LSE COEFF_SORT (S_ATLAS_COEFF ATLAS,
  1188. mk_atlaslist (s_atlas_map_ atlas,
  1189. nil,
  1190. s_atlas_den_om atlas),
  1191. edgelist)$
  1192. symbolic procedure coeff_sortl (atlaslist,passed,edgelist)$
  1193. coeff_sortl1 (coeff_ordn (atlaslist,edgelist),passed,edgelist)$
  1194. symbolic procedure coeff_sort (atlaslist,passed,edgelist)$
  1195. if atlaslist then
  1196. (lambda z$ %Z - NIL OR SORDET ATLAS
  1197. if z then %FIRST ATLAS ALREADY DEFINED
  1198. mk_atlas (s_atlas_map_ z,
  1199. coeff_sortl (append(s_atlas_coeff z,
  1200. append(cdr atlaslist,passed)),
  1201. nil,
  1202. nconc(map__edges s_atlas_map_ z,
  1203. edgelist)),
  1204. s_atlas_den_om z)
  1205. else
  1206. coeff_sort (cdr atlaslist,
  1207. car atlaslist . passed,
  1208. edgelist))
  1209. atlas_sort (car atlaslist,edgelist)
  1210. else coeff_sort_f (passed,nil,edgelist)$
  1211. symbolic procedure coeff_sort_f (passed,farewell,edgelist)$
  1212. if null passed then
  1213. if null farewell then nil
  1214. else error(51,nil)
  1215. else
  1216. if s_atlas_coeff car passed then %NOT EMPTY COEFF
  1217. coeff_sort (append(
  1218. s_atlas_coeff car passed,
  1219. mk_atlas (s_atlas_map_ car passed,
  1220. nil,
  1221. s_atlas_den_om car passed) .
  1222. append(cdr passed,farewell)),
  1223. nil,
  1224. edgelist)
  1225. else coeff_sort_f (cdr passed,
  1226. car passed . farewell,
  1227. edgelist) $
  1228. %.......... 31.05.88 ::::::::::: $
  1229. symbolic procedure coeff_ordn (atlaslist,edgelist)$
  1230. for each satlas in
  1231. coeff_ordn1 (mk_spec_atlaslist (atlaslist,edgelist),nil)
  1232. collect cdr satlas$
  1233. symbolic procedure mk_spec_atlaslist (atlaslist,edgelist)$
  1234. for each atlas in atlaslist collect mk_spec_atlas (atlas,edgelist)$
  1235. symbolic procedure mk_spec_atlas (atlas,edgelist)$
  1236. %RETURN PAIR (PAIR1 . ATLAS)
  1237. %WHERE PAIR1 IS A PAIR - EDGES . PARENTS
  1238. %WHERE EDGES - ALL EDGES OF ATLAS
  1239. %WHERE PARENTS-THOSE PARENTS OF EDGES WICH NOT CONTAITED IN EDGELIST
  1240. (lambda edges$
  1241. (edges . diff_edges (edges_parents edges,edgelist)) . atlas)
  1242. atlas_edges atlas$
  1243. symbolic procedure edges_parents edgelist$
  1244. if null edgelist then nil
  1245. else
  1246. (lambda z$
  1247. append(z ,edges_parents cdr edgelist))
  1248. edge_new_parents car edgelist$
  1249. symbolic procedure edge_new_parents edge$
  1250. % SELECT EDGE PARENTS FROM NEW_EDGE_LIST$
  1251. if p_old_edge edge then nil else
  1252. (lambda names$
  1253. edge_new_parent list(car names,cdr names))
  1254. s_edge_prop_ edge$
  1255. symbolic procedure edge_new_parent namelist$
  1256. if null namelist then nil
  1257. else
  1258. (lambda z$
  1259. if z then z . edge_new_parent cdr namelist
  1260. else edge_new_parent cdr namelist)
  1261. assoc(car namelist,new_edge_list) $
  1262. symbolic procedure diff_edges (edgelist1,edgelist2)$
  1263. if null edgelist1 then nil
  1264. else
  1265. if p_member_edge (car edgelist1,edgelist2) then
  1266. diff_edges (cdr edgelist1,edgelist2)
  1267. else car edgelist1 .
  1268. diff_edges (cdr edgelist1,edgelist2)$
  1269. symbolic procedure coeff_ordn1 (satlaslist,passed)$
  1270. if null satlaslist then passed
  1271. else
  1272. %IF NULL CAAR SATLASLIST THEN %ATLAS HAS NO UNDEFINED
  1273. % COEFF_ORDN1 (CDR SATLASLIST,CAR SATLASLIST . PASSED)
  1274. %ELSE
  1275. (lambda z$ % Z - NIL OR SATLASLIST
  1276. if z then % SUBATLAS FINED AND ADDED$
  1277. coeff_ordn1 (z,passed)
  1278. else coeff_ordn1 (cdr satlaslist,car satlaslist . passed) )
  1279. p_subsatlaslist (car satlaslist,cdr satlaslist,nil)$
  1280. symbolic procedure p_subsatlaslist (satlas,satlaslist,passed)$
  1281. if null satlaslist then nil
  1282. else
  1283. if or_subsatlas(satlas,car satlaslist) then
  1284. embed_satlases (satlas,car satlaslist) .
  1285. nconc(passed,cdr satlaslist)
  1286. else p_subsatlaslist (satlas,
  1287. cdr satlaslist,
  1288. car satlaslist . passed)$
  1289. symbolic procedure or_subsatlas (satlas1,satlas2)$
  1290. p_subsatlas (satlas1,satlas2)
  1291. or
  1292. p_subsatlas (satlas2,satlas1) $
  1293. symbolic procedure p_subsatlas (satlas1,satlas2)$
  1294. p_subedgelist (caar satlas1,caar satlas2)
  1295. or
  1296. p_inbothlists (cdar satlas1,caar satlas2) $
  1297. symbolic procedure p_inbothlists (edgelist1,edgelist2)$
  1298. if null edgelist1 then nil
  1299. else p_member_edge (car edgelist1,edgelist2)
  1300. or
  1301. p_inbothlists (cdr edgelist1,edgelist2)$
  1302. symbolic procedure p_subedgelist (edgelist1,edgelist2)$
  1303. if null edgelist1 then t
  1304. else
  1305. p_member_edge (car edgelist1,edgelist2)
  1306. and
  1307. p_subedgelist (cdr edgelist1,edgelist2)$
  1308. symbolic procedure embed_satlases (satlas1,satlas2)$
  1309. if p_subsatlas (satlas1,satlas2) then embed_satlas (satlas1,satlas2)
  1310. else
  1311. if p_subsatlas (satlas2,satlas1) then embed_satlas (satlas2,satlas1)
  1312. else set_error_real ('embed_satlases,list(satlas1,satlas2)) $
  1313. symbolic procedure embed_satlas (satlas1,satlas2)$
  1314. car satlas2 . embed_atlas (cdr satlas1,cdr satlas2)$
  1315. symbolic procedure embed_atlas (atlas1,atlas2)$
  1316. %EMBED ATLAS1 INTO ATLAS2
  1317. mk_atlas (s_atlas_map_ atlas2,
  1318. atlas1 . s_atlas_coeff atlas2,
  1319. s_atlas_den_om atlas2)$
  1320. symbolic procedure coeff_sortl1 (atlaslist,passed,edgelist)$
  1321. if null atlaslist then
  1322. if null passed then nil
  1323. else list coeff_sort_f (passed,nil,edgelist)
  1324. else
  1325. (lambda z$
  1326. if z then %ATLAS SORTED
  1327. z . coeff_sortl1 (cdr atlaslist,passed,edgelist)
  1328. else coeff_sortl1 (cdr atlaslist,car atlaslist . passed,edgelist))
  1329. atlas_sort (car atlaslist,edgelist)$
  1330. % ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,$
  1331. %END$ %cvit82.red
  1332. %:*:*:*:*:*:*:*:*:*:*:*:* FACTORIZATION OF MAP_S :*:*:*:*:*:*:*:*:*:$
  1333. % 19.05.88 $
  1334. lisp$
  1335. symbolic procedure renamel_edges edges$
  1336. if not equal_edges (car edges,cadr edges) then
  1337. rename_edges (car edges ,cadr edges)$
  1338. symbolic procedure map__vertex_first map_$
  1339. mk_vertex1_map_
  1340. s_vertex_first map_$
  1341. symbolic procedure both_empty_map_s (map_1,map_2)$
  1342. p_empty_map_ map_1
  1343. and
  1344. p_empty_map_ map_2 $
  1345. symbolic procedure has_parents edge$
  1346. (lambda z$
  1347. car z neq '!? and
  1348. cdr z neq '!? )
  1349. s_edge_prop_ edge $
  1350. symbolic procedure less_edge (edge1,edge2,edgelist)$
  1351. % EDGE1 < EDGE2 IFF EDGE1 WAS CREATED EARLIER$
  1352. less_edge_name (s_edge_name edge1,
  1353. s_edge_name edge2,
  1354. edgelist)$
  1355. symbolic procedure less_edge_name (name1,name2,edgelist)$
  1356. if null edgelist then set_error_real ('less_edge_name ,
  1357. list(name1,name2,edgelist))
  1358. else
  1359. if name1 eq s_edge_name car edgelist then nil
  1360. else
  1361. if name2 eq s_edge_name car edgelist then t
  1362. else less_edge_name (name1,name2,cdr edgelist)$
  1363. symbolic procedure rename_edges (edge1,edge2)$
  1364. if p_old_edge edge1 then
  1365. %IF P_OLD_EDGE EDGE2 THEN OLD_EDGE_LIST
  1366. if p_old_edge edge2 then replace_old_edge (edge1,edge2)
  1367. else replace_edge (edge2,edge1,new_edge_list )
  1368. else
  1369. if p_old_edge edge2 then replace_edge (edge1,edge2,
  1370. new_edge_list )
  1371. else
  1372. if has_parents edge1 then
  1373. if has_parents edge2 then replace_new_edge (edge1,edge2)
  1374. else replace_edge (edge2,edge1,new_edge_list )
  1375. else
  1376. if has_parents edge2 then
  1377. replace_edge (edge1,edge2,new_edge_list )
  1378. else replace_new_edge (edge1,edge2)$
  1379. symbolic procedure replace_new_edge (edge1,edge2)$
  1380. replace_o_edge (edge1,edge2,new_edge_list )$
  1381. symbolic procedure replace_old_edge (edge1,edge2)$
  1382. % 31.08.90 RT
  1383. if is_indexp edge1 then
  1384. if is_indexp edge2 then
  1385. replace_o_edge (edge1,edge2,old_edge_list )
  1386. else replace_edge (edge1,edge2,old_edge_list)
  1387. else
  1388. if is_indexp edge2 then
  1389. replace_edge (edge2,edge1,old_edge_list)
  1390. else
  1391. replace_o_edge (edge1,edge2,old_edge_list )$
  1392. symbolic procedure replace_o_edge (edge1,edge2,edgelist)$
  1393. if less_edge (edge1,edge2,edgelist) then
  1394. replace_edge (edge2,edge1,edgelist)
  1395. else replace_edge (edge1,edge2,edgelist)$
  1396. symbolic procedure copy_edge edge$
  1397. car edge . cadr edge . caddr edge . nil $
  1398. symbolic procedure replace_edge2 (oldedge,newedge)$
  1399. << rplaca(oldedge,car newedge)$
  1400. rplacd(oldedge,cdr newedge) >> $
  1401. symbolic procedure replace_edge (oldedge,newedge,edgelist)$
  1402. replace1_edge (copy_edge oldedge,newedge,edgelist)$
  1403. symbolic procedure replace1_edge (oldedge,newedge,edgelist)$
  1404. if null edgelist then nil
  1405. else
  1406. << if equal_edges (oldedge,car edgelist) then
  1407. replace_edge2 (car edgelist,newedge)$
  1408. replace1_parents (oldedge,newedge,car edgelist)$
  1409. replace1_edge (oldedge,newedge,cdr edgelist) >> $
  1410. symbolic procedure replace1_parents (oldedge,newedge,edge)$
  1411. replace2_parents (s_edge_name oldedge,
  1412. s_edge_name newedge,
  1413. s_edge_prop_ edge)$
  1414. symbolic procedure replace2_parents (oldname,newname,edgeprop_)$
  1415. << if oldname = car edgeprop_ then rplaca(edgeprop_,newname)$
  1416. if oldname = cdr edgeprop_ then rplacd(edgeprop_,newname) >> $
  1417. symbolic procedure mk_simple_map_ inmap_$
  1418. mk_simple_map_1 (inmap_,mk_empty_map_ (),nil,nil)$
  1419. symbolic procedure both_old edges$
  1420. p_old_edge car edges
  1421. and
  1422. p_old_edge cadr edges$
  1423. symbolic procedure both_vectors edges$ % 31.08.90 RT
  1424. not is_indexp car edges
  1425. and
  1426. not is_indexp cadr edges$
  1427. symbolic procedure old_renamel_edv (vertex,edges)$
  1428. % RENAMES EDGES IN VERTEX$
  1429. ren_edge (s_edge_name car edges .
  1430. s_edge_name cadr edges,vertex)$
  1431. symbolic procedure mk1_simple_map_ map_d$
  1432. %MAP_D IS A PAIR (MAP_.DEN_OM)$
  1433. mk_simple_map_1 (car map_d,mk_empty_map_ (),list cdr map_d,nil)$
  1434. symbolic procedure mk_simple_map_1 (inmap_,outmap_,den_om,coeff)$
  1435. if p_empty_map_ inmap_ then <<
  1436. % FIND_BUBLTR
  1437. outmap_ := mk_parents_map_ outmap_;
  1438. mk_atlas (outmap_ ,
  1439. if null coeff then nil
  1440. else for each map_ in coeff
  1441. collect mk1_simple_map_ map_,
  1442. den_om) >>
  1443. else
  1444. (lambda edges$
  1445. (lambda n$
  1446. if p_vertex_prim s_vertex_first inmap_ then
  1447. if n=2 then % VERTEX=(A,B)=DELTA(A,B) $
  1448. if both_old edges and both_vectors edges then % 31.08.90
  1449. mk_simple_map_1 (s_map__rest inmap_,
  1450. add_vertex (s_vertex_first inmap_,outmap_),
  1451. den_om,
  1452. coeff)
  1453. else
  1454. << renamel_edges edges$
  1455. if both_empty_map_s (s_map__rest inmap_,outmap_) then
  1456. mk_simple_map_1 (s_map__rest inmap_,
  1457. add_vertex (s_vertex_first inmap_,outmap_),
  1458. den_om,
  1459. coeff)
  1460. else
  1461. mk_simple_map_1 (s_map__rest inmap_,
  1462. outmap_,
  1463. den_om,
  1464. coeff )
  1465. >>
  1466. else
  1467. mk_simple_map_1 ( s_map__rest inmap_,
  1468. add_vertex ( s_vertex_first inmap_,outmap_),
  1469. den_om,
  1470. coeff)
  1471. else
  1472. if n=2 then
  1473. if both_old edges and both_vectors edges then %11.09.90 RT
  1474. mk_simple_map_1 (add_vertex (mk_edges_vertex edges,
  1475. s_map__rest inmap_),
  1476. outmap_,
  1477. den_om,
  1478. (mk_vertex1_map_ (
  1479. old_renamel_edv(s_vertex_first inmap_,edges))
  1480. . old_renamel_edv(mk_edges_vertex edges,edges))
  1481. . coeff )
  1482. else
  1483. << renamel_edges edges$
  1484. mk_simple_map_1 (s_map__rest inmap_,
  1485. outmap_,
  1486. den_om,
  1487. (map__vertex_first inmap_ . edges) . coeff)
  1488. >>
  1489. else
  1490. if n=3 and
  1491. ((map__length (inmap_) + map__length (outmap_)) > 2 )
  1492. then
  1493. (lambda v$
  1494. mk_simple_map_1 (add_vertex (v,s_map__rest inmap_),
  1495. outmap_,
  1496. den_om,
  1497. (add_vertex (v,map__vertex_first inmap_) . v)
  1498. . coeff))
  1499. mk_edges_vertex edges
  1500. else
  1501. if
  1502. (lambda k$
  1503. k > 4 and
  1504. n < k ) %NOT ALL LINES EXTERNAL $
  1505. vertex_length s_vertex_first inmap_
  1506. then
  1507. (lambda firz$
  1508. mk_simple_map_1 (append_map_s (firz,s_map__rest inmap_),
  1509. outmap_,
  1510. den_om,
  1511. coeff) )
  1512. (mk_firz_op s_vertex_first inmap_) %26.04.88
  1513. else if t then
  1514. mk_simple_map_1 (s_map__rest inmap_,
  1515. add_vertex (s_vertex_first inmap_,outmap_),
  1516. den_om,
  1517. coeff)
  1518. else
  1519. mk_simple_map_1 (append_map_s (mk_simple_vertex
  1520. s_vertex_first inmap_,
  1521. s_map__rest inmap_),
  1522. outmap_,
  1523. den_om,
  1524. coeff) )
  1525. length edges)
  1526. (ext_edges s_vertex_first inmap_) $
  1527. % ?^?^?^?^?^?^?^?^?^?^?^?^? FIERZ OPTIMIZATION ?^?^?^?^?^?^?^?^?^?^?^?$
  1528. % 13.05.88$
  1529. global '(!*cvitop)$
  1530. flag('(cvitop),'switch)$
  1531. symbolic procedure mk_firz_op vertex$
  1532. if null !*cvitop then mk_firz vertex
  1533. else firz_op vertex$
  1534. symbolic procedure firz_op vertex$
  1535. mk_firz find_cycle (optimal_edge vertex,
  1536. vertex,
  1537. mk_empty_vertex ())$
  1538. symbolic procedure find_cycle (edge,vertex,passed)$
  1539. if equal_edges (edge,first_edge vertex) then
  1540. append_vertex (vertex,reversip_vertex passed)
  1541. else find_cycle (edge,
  1542. s_vertex_rest vertex,
  1543. add_edge (first_edge vertex,passed))$
  1544. symbolic procedure optimal_edge vertex$
  1545. optimal1_edge
  1546. internal_edges (vertex,mk_empty_vertex ())$
  1547. symbolic procedure internal_edges (vertex1,vertex2)$
  1548. if p_empty_vertex vertex1 then vertex2
  1549. else
  1550. if p_member_edge (first_edge vertex1,s_vertex_rest vertex1)
  1551. or
  1552. p_member_edge (first_edge vertex1,vertex2)
  1553. then internal_edges (s_vertex_rest vertex1,
  1554. add_edge (first_edge vertex1,vertex2))
  1555. else internal_edges (s_vertex_rest vertex1,vertex2)$
  1556. symbolic procedure optimal1_edge vertex$
  1557. % VERTEX CONTAINS ONLY PAIRED EDGES
  1558. (lambda (l,z)$
  1559. opt_edge (z,
  1560. edge_distance (z,vertex,l),
  1561. s_vertex_rest vertex,
  1562. add_edge (z,mk_empty_vertex ()),
  1563. l))
  1564. (vertex_length vertex,
  1565. first_edge vertex)$
  1566. symbolic procedure edge_distance (edge,vertex,l)$
  1567. % L - FULL VERTEX LENGTH
  1568. (lambda n$
  1569. min(n,l - n - 2))
  1570. edge_dist (edge,s_vertex_rest vertex)$
  1571. symbolic procedure edge_dist (edge,vertex)$
  1572. if equal_edges (edge,first_edge vertex) then 0
  1573. else add1 edge_dist (edge,s_vertex_rest vertex)$
  1574. symbolic procedure opt_edge (edge,distance,vertex,passed,n)$
  1575. % N - FULL VERTEX LENGTH
  1576. if distance = 0 or p_empty_vertex vertex then edge
  1577. else
  1578. (lambda firstedge$
  1579. if p_member_edge (firstedge,passed) then
  1580. opt_edge (edge,
  1581. distance,
  1582. s_vertex_rest vertex,
  1583. passed,
  1584. n)
  1585. else
  1586. (lambda dist$
  1587. if dist < distance then
  1588. opt_edge (firstedge,
  1589. dist,
  1590. s_vertex_rest vertex,
  1591. add_edge (firstedge,passed),
  1592. n)
  1593. else opt_edge (edge,
  1594. distance,
  1595. s_vertex_rest vertex,
  1596. add_edge (firstedge,passed),
  1597. n))
  1598. edge_distance (firstedge,vertex,n))
  1599. first_edge vertex $
  1600. %<?><?><?><?><?><?><?> END OF OPTIMIZATION PART <?><?><?><?><?><?> $
  1601. symbolic procedure mk_firz vertex$
  1602. % VERTEX=(A1,...,AM,Z,B1,...,BN,Z,C1,...,CK)
  1603. % RETURNS UNION MAP_ WHERE
  1604. % MAP_ =MAP_1 & MAP_2 WHERE
  1605. % MAP_1=((B1,...,BN,X)(Y,C1,...,CK,A1,...,AM)),
  1606. % MAP_2=((Z,X,Z,Y)) $
  1607. mk_firz1 (vertex,mk_empty_vertex ())$
  1608. symbolic procedure mk_firz1 (vertex1,vertex2)$
  1609. if p_empty_vertex vertex1 then reversip_vertex vertex2
  1610. else
  1611. (lambda z$
  1612. if z then %FIRST EDGE CONTAINS TWICE$
  1613. mk_firz2 (first_edge vertex1,
  1614. car z,
  1615. append_vertex (cdr z,reversip_vertex vertex2))
  1616. else
  1617. mk_firz1 (s_vertex_rest vertex1,
  1618. add_edge (first_edge vertex1,vertex2) ) )
  1619. mp_member_edge (first_edge vertex1,
  1620. s_vertex_rest vertex1)$
  1621. symbolic procedure mk_firz2 (edge,vertex1,vertex2)$
  1622. %RETURNS MAP_ =MAP_1 & MAP_2 ,
  1623. %VERTEX1=(B1,...,BN),
  1624. %VERTEX2=(C1,...,CK,A1,...,AM) $
  1625. (lambda (nedge,nedg1)$
  1626. append_map_s (
  1627. mk_coeff2 (edge,nedge,nedg1),
  1628. mk_vertex2_map_ (conc_vertex (vertex1,mk_edge1_vertex nedge),
  1629. add_edge (nedg1,vertex2))
  1630. ))
  1631. (mk_nedge (),
  1632. mk_nedge ()) $
  1633. symbolic procedure mk_coeff2 (edge,nedge,nedg1)$
  1634. mk_vertex1_map_ mk_edge4_vertex (edge,nedge,edge,nedg1)$
  1635. symbolic procedure mk_nedge $
  1636. (lambda edge$
  1637. new_edge (edge,edge))
  1638. mk_edge ('!?,'!? . '!?,nil) $
  1639. symbolic procedure mp_member_edge (edge,vertex)$
  1640. % RETURNS NIL OR PAIR.
  1641. % IF VERTEX=(A1,...,AM,EDGE,...,B1,...,BN) THEN
  1642. % PAIR= (A1,...,AM) . (B1,...,BM) $
  1643. mp_member1_edge (edge,vertex,mk_empty_vertex ())$
  1644. symbolic procedure mp_member1_edge (edge,vertex,tail)$
  1645. if p_empty_vertex vertex then nil
  1646. else
  1647. if
  1648. equal_edges (edge,first_edge vertex) then
  1649. reversip_vertex tail .
  1650. s_vertex_rest vertex
  1651. else mp_member1_edge (edge,
  1652. s_vertex_rest vertex,
  1653. add_edge (first_edge vertex,tail) ) $
  1654. %END$ %cvit10.red
  1655. % ()()()()()()()()()()()()()() PRINTING ATLAS AND MAP_ ROUTINES ()()().
  1656. lisp$ %30.01.87$
  1657. fluid '(ntab!*)$
  1658. symbolic procedure print_atlas atlas$
  1659. begin
  1660. scalar ntab!*$
  1661. ntab!*:=0$
  1662. prin2_atlas atlas$
  1663. end$
  1664. symbolic procedure prin2_atlas atlas$
  1665. if null atlas then nil
  1666. else
  1667. << print_map_ s_atlas_map_ atlas$
  1668. print_den_om s_atlas_den_om atlas$
  1669. print_coeff s_atlas_coeff atlas
  1670. >> $
  1671. symbolic procedure print_map_ map_$
  1672. << pttab ntab!*$
  1673. prin2 "Map_ is: ("$
  1674. prin2_map_ map_$
  1675. prin2 " )"$
  1676. terpri() >> $
  1677. symbolic procedure prin2_map_ map_$
  1678. if p_empty_map_ map_ then nil
  1679. else
  1680. << print_vertex s_vertex_first map_$
  1681. prin2_map_ s_map__rest map_ >> $
  1682. symbolic procedure print_vertex vertex$
  1683. <<
  1684. prin2 "( "$
  1685. prin2_vertex vertex$
  1686. prin2 ")" >> $
  1687. symbolic procedure prin2_vertex vertex$
  1688. if p_empty_vertex vertex then nil
  1689. else
  1690. << print_edge first_edge vertex$
  1691. prin2_vertex s_vertex_rest vertex >> $
  1692. symbolic procedure print_edge edge$
  1693. << prin2_edge edge$
  1694. prin2 " " >> $
  1695. symbolic procedure prin2_edge edge$
  1696. prin2 s_edge_name edge $
  1697. symbolic procedure pttab n$
  1698. << spaces n $ % TTAB N$ % 07.06.90
  1699. prin2 n$
  1700. prin2 ":" >> $
  1701. symbolic procedure print_coeff coeff$
  1702. << ntab!*:=ntab!*+1$
  1703. prin2_coeff coeff$
  1704. ntab!*:=ntab!*-1 >> $
  1705. symbolic procedure prin2_coeff atlases$
  1706. if null atlases then nil
  1707. else << prin2_atlas car atlases$
  1708. prin2_coeff cdr atlases >> $
  1709. symbolic procedure print_den_om den_list$
  1710. << pttab ntab!*$
  1711. prin2 "DEN_OM is: "$
  1712. if null den_list then prin2 nil
  1713. else prin2_map_ den_list $
  1714. terpri() >> $
  1715. unfluid '(ntab!*)$
  1716. symbolic procedure print_old_edges ()$
  1717. print_edge_list old_edge_list $
  1718. symbolic procedure print_new_edges ()$
  1719. print_edge_list new_edge_list $
  1720. symbolic procedure print_edge_list edgelist$
  1721. if null edgelist then nil
  1722. else << print car edgelist$
  1723. print_edge_list cdr edgelist >> $
  1724. %END$ %cvit12.red
  1725. %---------------------- MAKES PARENTS AFTER FIERZING ----------------$
  1726. %24.05.88$
  1727. lisp$
  1728. symbolic procedure mk_simpl_map_ map_$
  1729. mk_simpl_map_1 (map_,mk_empty_map_ ())$
  1730. symbolic procedure mk_simpl_map_1 (inmap_,outmap_)$
  1731. if p_empty_map_ inmap_ then resto_map__order outmap_
  1732. else
  1733. if p_vertex_prim s_vertex_first inmap_ then
  1734. mk_simpl_map_1 ( s_map__rest inmap_,
  1735. add_vertex(mk_parents_prim s_vertex_first inmap_,
  1736. outmap_))
  1737. else
  1738. mk_simpl_map_1 (append_map_s(mk_simple_vertex s_vertex_first inmap_,
  1739. s_map__rest inmap_),
  1740. outmap_)$
  1741. symbolic procedure mk_simple_vertex vertex$
  1742. % VERTEX => MAP_ $
  1743. begin
  1744. scalar nedge,fedge,sedge$
  1745. fedge:=first_edge vertex$
  1746. sedge:=second_edge vertex$
  1747. if not has_parents fedge or not has_parents sedge then
  1748. return mk_simple_vertex cycl_vertex vertex$
  1749. nedge:=new_edge (fedge,sedge)$
  1750. vertex:=s_vertex_rest
  1751. s_vertex_rest vertex$
  1752. return
  1753. mk_vertex2_map_ ( mk_edge3_vertex (nedge,fedge,sedge),
  1754. add_edge (nedge,vertex))
  1755. end$
  1756. symbolic procedure mk_parents_map_ map_$
  1757. %MAKES PARENTS FOR ALL EDGES IN MAP_.
  1758. %THIS CAN BE DONE BECAUSE NEW EDGES NEVER CREATE CYCLES$
  1759. standard_map_
  1760. mk_simpl_map_
  1761. mk_parents1_map_ (map_,mk_empty_map_ (),mk_empty_map_ ())$
  1762. symbolic procedure standard_map_ map_$
  1763. if p_empty_map_ map_ then mk_empty_map_ ()
  1764. else
  1765. if vertex_length s_vertex_first map_ > 2 then
  1766. add_vertex (s_vertex_first map_,
  1767. standard_map_ s_map__rest map_)
  1768. else standard_map_ add_vertex (add_0_edge s_vertex_first map_,
  1769. s_map__rest map_)$
  1770. symbolic procedure add_0_edge vertex$
  1771. %ADDS SPECIAL VERTEX$
  1772. add_edge (!_0edge ,vertex)$
  1773. symbolic procedure mk_parents1_map_ (inmap_,outmap_,passed)$
  1774. if p_empty_map_ inmap_ then
  1775. if p_empty_map_ passed then outmap_ %ALL EDGES HAVE PARENTS$
  1776. else mk_parents1_map_ (passed,outmap_,mk_empty_map_ ())
  1777. else
  1778. (lambda edges$
  1779. if null edges then %IN FIRST VERTEX ALL EDGES HAVE PARENTS$
  1780. mk_parents1_map_ (s_map__rest inmap_,
  1781. add_vertex (s_vertex_first inmap_,outmap_),
  1782. passed)
  1783. else
  1784. if single_no_parents edges then %ONLY ONE EDGE IN THE VERTEX$
  1785. %HAS NO PARENTS$
  1786. mk_parents1_map_ (s_map__rest inmap_,
  1787. append_map_s (mk_parents_vertex
  1788. s_vertex_first inmap_,
  1789. outmap_),
  1790. passed)
  1791. else
  1792. mk_parents1_map_ (s_map__rest inmap_,
  1793. outmap_,
  1794. add_vertex (s_vertex_first inmap_,passed)))
  1795. s_noparents s_vertex_first inmap_ $
  1796. symbolic procedure s_noparents vertex$
  1797. %SELECTS EDGES WITHOUT PARENTS IN VERTEX$
  1798. if p_empty_vertex vertex then nil
  1799. else
  1800. if has_parents first_edge vertex then
  1801. s_noparents s_vertex_rest vertex
  1802. else
  1803. first_edge vertex .
  1804. s_noparents s_vertex_rest vertex$
  1805. symbolic procedure mk_parents_vertex vertex$
  1806. %MAKES PARENTS FOR THE SINGLE EDGE WITHOUT PARENTS IN VERTEX,
  1807. % (VERTEX HAS ONLY ONE EDGE WITHOUT PARENTS ^) $
  1808. mk_simpl_map_ mk_vertex1_map_ vertex$
  1809. symbolic procedure mk_parents_prim pvertex$
  1810. % CREATES PARENTS FOR THE ONLY EDGE WITHOUT PARENTS IN PRIMITIVE
  1811. % (THREE EDGES) VERTEX $
  1812. if vertex_length pvertex neq 3 then pvertex
  1813. else
  1814. (lambda edges$
  1815. if null edges then pvertex
  1816. else
  1817. << mk_edge_parents (pvertex,car edges)$
  1818. pvertex >> )
  1819. s_noparents pvertex$
  1820. symbolic procedure mk_edge_parents (vertex,edge)$
  1821. mk_edge1_parents (delete_edge (edge,vertex),edge)$
  1822. symbolic procedure mk_edge1_parents (vertex2,edge)$
  1823. add_parents (edge,
  1824. mk_edge_prop_ (
  1825. s_edge_name first_edge vertex2,
  1826. s_edge_name second_edge vertex2))$
  1827. symbolic procedure add_parents (edge,names)$
  1828. add_parents0(edge,names,nil)$
  1829. symbolic procedure add_parents0 (edge,names,bool)$
  1830. addl_parents (new_edge_list,edge,names . list bool)$
  1831. symbolic procedure addl_parents (edgelist,edge,names)$
  1832. % NAMES IS A PAIR NAME1 . NAME2 $
  1833. if null edgelist then nil
  1834. else
  1835. (if equal_edges (car edgelist,edge) then
  1836. rep_parents (car edgelist,names)
  1837. else car edgelist) .
  1838. addl_parents (cdr edgelist,edge,names) $
  1839. symbolic procedure rep_parents (edge,names)$
  1840. << rplacd(edge,names)$
  1841. edge >> $
  1842. %END$ %cvit14.red
  1843. %EEEEEEEEEEEEEEEEEEEEEEEEE SELECT ALL EDGES %%%%%%%%%%%%%%%%%%%%%%%%% $
  1844. % 07.06.88$
  1845. lisp$
  1846. symbolic procedure atlas_edges atlas$
  1847. union_edges (
  1848. union_edges (map__edges s_atlas_map_ atlas,
  1849. den__edges s_atlas_den_om atlas),
  1850. coeff_edges s_atlas_coeff atlas)$
  1851. symbolic procedure den__edges den_om$
  1852. map__edges den_om$
  1853. symbolic procedure coeff_edges atlaslist$
  1854. if null atlaslist then nil
  1855. else union_edges (atlas_edges car atlaslist,
  1856. coeff_edges cdr atlaslist) $
  1857. symbolic procedure map__edges map_$
  1858. if p_empty_map_ map_ then nil
  1859. else union_edges (vertex_edges s_vertex_first map_,
  1860. map__edges s_map__rest map_)$
  1861. symbolic procedure union_edges (newlist,oldlist)$
  1862. if null newlist then oldlist
  1863. else union_edges (cdr newlist,
  1864. union_edge (car newlist,oldlist))$
  1865. symbolic procedure union_edge (edge,edgelist)$
  1866. if memq_edgelist (edge,edgelist) then edgelist
  1867. else edge . edgelist$
  1868. symbolic procedure memq_edgelist (edge,edgelist)$
  1869. assoc(s_edge_name edge,
  1870. edgelist)$
  1871. symbolic procedure exclude_edges (edgelist,exclude)$
  1872. % EXCLUDE IS A LIST OF EDGES TO BE EXCLUDED FROM EDGELIST$
  1873. if null edgelist then nil
  1874. else
  1875. if memq_edgelist (car edgelist,exclude) then
  1876. exclude_edges (cdr edgelist,exclude)
  1877. else car edgelist .
  1878. exclude_edges (cdr edgelist,exclude) $
  1879. symbolic procedure constr_worlds (atlas,edgelist)$
  1880. (lambda edges$
  1881. actual_edges_world (
  1882. mk_world1 (actual_edges_map_ (edges,
  1883. edgelist,
  1884. s_atlas_map_ atlas),
  1885. constr_coeff (s_atlas_coeff atlas,
  1886. union_edges (edges,edgelist)),
  1887. s_atlas_den_om atlas
  1888. )
  1889. ) )
  1890. union_edges(
  1891. den__edges s_atlas_den_om atlas,
  1892. map__edges s_atlas_map_ atlas)$
  1893. symbolic procedure constr_coeff (atlases,edgelist)$
  1894. if null atlases then nil
  1895. else
  1896. constr_worlds (car atlases,edgelist) .
  1897. constr_coeff (cdr atlases,edgelist)$
  1898. symbolic procedure actual_edges_map_ (edges,edgelist,map_)$
  1899. actedge_map_ (edges,edgelist,list_of_parents(edges,edgelist),nil)
  1900. %ACTEDGE_MAP_ (EDGES,EDGELIST,NIL,NIL)
  1901. . map_$
  1902. symbolic procedure list_of_parents (edges,edgelist)$
  1903. if null edges then nil
  1904. else append(list_of_parent (car edges,edgelist),
  1905. list_of_parents (cdr edges,edgelist))$
  1906. symbolic procedure list_of_parent (edge,edgelist)$
  1907. if p_old_edge edge or memq_edgelist (edge,edgelist) then nil
  1908. %IF EDGE IS DEF. THEN NO NEED IN ITS PARENTS
  1909. else
  1910. begin$
  1911. scalar pr1,pr2,p,s$
  1912. p:=s_edge_prop_ edge$
  1913. pr1:=assoc(car p,edgelist)$
  1914. if pr1 then s:=pr1 . s$
  1915. pr2:=assoc(cdr p,edgelist)$
  1916. if pr2 then s:=pr2 . s$
  1917. %IF NULL PR1 OR NULL PR2 THEN
  1918. % SET_ERROR (LIST_OF_PARENTS ,EDGE,EDGELIST)$
  1919. return s
  1920. end$
  1921. symbolic procedure actedge_map_ (edges,edgelist,old,new)$
  1922. if null edges then old . new
  1923. else
  1924. if memq_edgelist (car edges,edgelist) then
  1925. actedge_map_ (cdr edges,edgelist,car edges . old,new)
  1926. else actedge_map_ (cdr edges,edgelist,old,car edges . new) $
  1927. symbolic procedure actual_edges_world world1$
  1928. mk_world (actual_world (s_actual_world1 world1,
  1929. s_actual_coeff s_coeff_world1 world1),
  1930. world1)$
  1931. symbolic procedure mk_world1 (edges!-map_,coeff,den_om)$
  1932. mk_atlas (map_2_from_map_1 edges!-map_,coeff,den_om)$
  1933. symbolic procedure map_2_from_map_1 map_1$
  1934. list(map_1_to_strand1 map_1,
  1935. list nil,
  1936. mark_edges (cdar map_1,
  1937. % UNION_EDGES(OLD_EDGE_LIST,CAAR MAP_1),
  1938. caar map_1,
  1939. cdr map_1))$
  1940. symbolic procedure map_1_to_strand1 map_1$
  1941. car map_1 .
  1942. pre!-calc!-map_ (cdr map_1,
  1943. names_edgepair map__edges cdr map_1)$
  1944. symbolic procedure names_edgepair edgepair$
  1945. %NCONC(FOR EACH EDGE IN CAR EDGEPAIR COLLECT S_EDGE_NAME EDGE,
  1946. % FOR EACH EDGE IN CDR EDGEPAIR COLLECT S_EDGE_NAME EDGE)$
  1947. for each edge in edgepair collect s_edge_name edge $
  1948. symbolic procedure s_actual_world1 world1$
  1949. %RETURNS PAIR: OLDEDGES . NEWEDGES $
  1950. caar s_atlas_map_ world1$
  1951. symbolic procedure actual_world (map_edges,coeffedges)$
  1952. %MAP_EDGES IS A PAIR OLD . NEW,
  1953. %COEFFEDGES IS LIST OF ACTUAL EDGES OF COEEF.$
  1954. union_edges (car map_edges,
  1955. exclude_edges (coeffedges,cdr map_edges)) $
  1956. symbolic procedure s_actual_coeff worldlist$
  1957. if null worldlist then nil
  1958. else union_edges (s_edgelist_world car worldlist,
  1959. s_actual_coeff cdr worldlist) $
  1960. symbolic procedure world_from_atlas atlas$
  1961. %TOP LEVEL PROCEDURE$
  1962. constr_worlds (atlas,old_edge_list )$
  1963. %END$ %cvit16.red
  1964. %^^^^^^^^^^^^^^^^^^^^^^^^^^ CALCULATION OF WORLDS ^^^^^^^^^^^^^^^^^^^ $
  1965. %26.03.88$
  1966. lisp$
  1967. symbolic procedure s_world_names world$
  1968. for each edge in s_world_edges world
  1969. collect s_edge_name edge$
  1970. symbolic procedure calc_world (world,alst)$
  1971. % ALST LIST OF VALUES OF EXTERNAL EDGES: (... (EDGNAME . NUMBER) ...)$
  1972. begin
  1973. scalar s,v$
  1974. alst:=actual_alst (alst, %SELECT ONLY THOSE
  1975. s_world_names world)$ %EDGES WICH ARE IN WORLD
  1976. v:=s_world_var world $ %SELECT DATA BASE
  1977. s:=assoc(alst,cdr v)$ %CALC. PREVIOSLY?
  1978. if s then return cdr s$ %PREV. RESULT$
  1979. s:=reval
  1980. calc_atlas (s_world_atlas world,alst)$ %REAL CALCULATION
  1981. nconc (v,list(alst . s))$ %MODIFY DATA BASE
  1982. return s
  1983. end$
  1984. symbolic procedure actual_alst (alst,namelist)$
  1985. if null alst then nil
  1986. else
  1987. if memq(caar alst,namelist) then
  1988. car alst . actual_alst (cdr alst,namelist)
  1989. else actual_alst (cdr alst,namelist)$
  1990. symbolic procedure calc_atlas (atlas,alst)$
  1991. calc_map_2d (s_atlas_map_ atlas,
  1992. s_atlas_den_om atlas,
  1993. s_atlas_coeff atlas,
  1994. alst) $
  1995. symbolic procedure calc_coeff (worldlist,alst)$
  1996. if null worldlist then list 1
  1997. else
  1998. (lambda x$
  1999. if x=0 then list 0
  2000. else x . calc_coeff (cdr worldlist,alst))
  2001. calc_world (car worldlist,alst)$
  2002. symbolic procedure calc_map_2d (map_2,den_om,coeff,alst)$
  2003. coeff_calc (mk_names_map_2 caar map_2 .
  2004. cdar map_2 .
  2005. cadr map_2 .
  2006. den_om ,
  2007. coeff,
  2008. mk_binding (caddr map_2,alst)) $
  2009. symbolic procedure mk_names_map_2 edgespair$
  2010. % EDGESPAIR IS PAIR OF LISTS OF EDGES
  2011. % EDGELISTOLD . EDGELISTNEW $
  2012. for each edge in append(car edgespair,cdr edgespair)
  2013. collect s_edge_name edge$
  2014. symbolic procedure calc_coeffmap_ (s,coeff,alst)$
  2015. (lambda z$
  2016. if z = 0 then 0
  2017. else 'times . (z . calc_coeff (coeff,alst)))
  2018. calc_map_ (s,alst)$
  2019. symbolic procedure calc_map_ (mvd,alst)$
  2020. begin
  2021. scalar map_,v,names,s,den_om,al,d$
  2022. names:=car mvd$ %NAMES OF ALL EDGES
  2023. map_:=cadr mvd$ %SELECT MAP_
  2024. v:=caddr mvd$ %SELECT DATA BASE
  2025. den_om:=cdddr mvd$ %SELECT DEN_OMINATOR
  2026. al:=actual_alst (alst,names)$ %ACTUAL ALIST
  2027. if null al and names then return 0$ %NO VARIANTS OF
  2028. %COLOURING
  2029. s:=assoc(al,cdr v)$ %PREV.CALCULATED?
  2030. if s then s:=cdr s %YES, TAKE IT
  2031. else << %ELSE
  2032. s:=reval calc_map_tar (map_,al)$ %REAL CALCULATION
  2033. nconc(v,list(al . s)) %MODIFY DATA BASE
  2034. >> $
  2035. d:=calc_den_tar (den_om,alst)$ %CALC. DEN_OMINATOR
  2036. return
  2037. if d = 1 then s
  2038. else list('quotient,s,d) % 09.06.90 RT
  2039. end$
  2040. %SYMBOLIC PROCEDURE CALC_MAP_TAR (MAP_,BINDING)$
  2041. %1$
  2042. %SYMBOLIC PROCEDURE CALC_DEN_TAR (DEN_OMINATOR,BINDING)$
  2043. %1$
  2044. symbolic procedure coeff_calc (s,coeff,binding)$
  2045. %S IS EDGENAMES . MAP_ . DATABASE . DEN_OMINATOR $
  2046. reval
  2047. ('plus . coeff1_calc (s,coeff,binding))$
  2048. symbolic procedure coeff1_calc (s,coeff,binding)$
  2049. if null binding then list 0
  2050. else calc_coeffmap_ (s,coeff,car binding) .
  2051. coeff1_calc (s,coeff,cdr binding) $
  2052. %TOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOPTOP$
  2053. symbolic procedure calc_spur0 u$
  2054. begin
  2055. scalar s$
  2056. if null u then return u$
  2057. s:=transform_map_ u$
  2058. old_edge_list := !_0edge . old_edge_list $
  2059. s:=find_bubltr s$
  2060. return
  2061. calc_world (world_from_atlas s,
  2062. for each edge in old_edge_list
  2063. collect s_edge_name edge .
  2064. car s_edge_prop_ edge )
  2065. end$
  2066. symbolic procedure calc_spur u$
  2067. simp!* calc_spur0 u$ %FOR KRYUKOV NEEDS$
  2068. endmodule;
  2069. end;