From 04511eb1680700d823b28744492806edbf609dd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20Cuevas-Rozo?= Date: Tue, 30 Jul 2019 20:12:32 +0200 Subject: [PATCH] vf-order.lisp file added --- kenzo.asd | 1 + src/finite-topological-spaces-class.lisp | 5 +- src/finite-topological-spaces-core.lisp | 62 ++-- src/kenzo.fas | Bin 63208 -> 63208 bytes src/vf-order.lisp | 400 +++++++++++++++++++++++ 5 files changed, 441 insertions(+), 27 deletions(-) create mode 100644 src/vf-order.lisp diff --git a/kenzo.asd b/kenzo.asd index b229f82..b01cb38 100644 --- a/kenzo.asd +++ b/kenzo.asd @@ -57,6 +57,7 @@ (:file "cl-space-efhm") (:file "whitehead") (:file "smith") + (:file "vf-order") (:file "sage-interface") (:file "finite-topological-spaces-aux") (:file "finite-topological-spaces-class") diff --git a/src/finite-topological-spaces-class.lisp b/src/finite-topological-spaces-class.lisp index 47edfdb..66e810e 100644 --- a/src/finite-topological-spaces-class.lisp +++ b/src/finite-topological-spaces-class.lisp @@ -77,8 +77,9 @@ (declare (type t-mat pc) (type list rslt)))))) -(DEFUN SUBMATRIX (mtrx rows cols) - #| Extract the submatrix of 'mtrx' formed by the rows whose indexes are in 'rows' and the columns whose indexes are in 'cols' |# +(DEFUN SUB-MATRIX (mtrx rows cols) + #| Extract the submatrix of 'mtrx' formed by the rows whose indexes are in 'rows' the columns whose indexes are in 'cols' |# + (declare (type matrice mtrx) (type list rows cols)) (let ((rslt (creer-matrice (length rows) (length cols)))) (do ((k 1 (1+ k)) (columnas cols (cdr columnas))) diff --git a/src/finite-topological-spaces-core.lisp b/src/finite-topological-spaces-core.lisp index 8d0e68d..ec76b09 100644 --- a/src/finite-topological-spaces-core.lisp +++ b/src/finite-topological-spaces-core.lisp @@ -25,7 +25,8 @@ +TRUE+)))) -(DEFUN UPBP (topogenous n list) ; T if Xn is an up beat point of the submatrix 'list'x'list' +(DEFUN UPBP (topogenous n list) + #| T if Xn is an up beat point of the submatrix 'list'x'list' |# (the boolean (let ((minimal (loop for k in (subseq list (1+ (position n list))) thereis (and (eq (terme topogenous n k) 1) k)))) @@ -35,7 +36,8 @@ +TRUE+)))) -(DEFUN BEATPOINT (topogenous n list) ; T if Xn is a beat point of the submatrix 'list'x'list' +(DEFUN BEATPOINT (topogenous n list) + #| T if Xn is a beat point of the submatrix 'list'x'list' |# (the boolean (if (< (1+ n) (/ (ncol topogenous) 2)) (if (downbp topogenous n list) @@ -46,7 +48,8 @@ (downbp topogenous n list))))) -(DEFUN CORE_LIST (topogenous list) ; List of the elements of the core of the submatrix 'list'x'list' +(DEFUN CORE_LIST (topogenous list) + #| List of the elements of the core of the submatrix 'list'x'list' |# (let ((eliminar NIL)) (setf eliminar (loop for n in list thereis (and (beatpoint topogenous n list) n))) @@ -55,29 +58,34 @@ (core_list topogenous (remove eliminar list))))) -(DEFMACRO Un-N (topogenous n list) ; List of the elements in Un-{Xn} - `(loop for i in (subseq ,list 0 (position ,n ,list)) - when (eq (terme ,topogenous i ,n) 1) - collect i)) +(DEFUN Un-N (topogenous n list) + #| List of the elements in Un-{Xn} |# + (loop for i in (subseq list 0 (position n list)) + when (eq (terme topogenous i n) 1) + collect i)) -(DEFMACRO Fn-N (topogenous n list) ; List of the elements in Fn-{Xn} - `(loop for j in (subseq ,list (1+ (position ,n ,list))) - when (eq (terme ,topogenous ,n j) 1) - collect j)) +(DEFUN Fn-N (topogenous n list) + #| List of the elements in Fn-{Xn} |# + (loop for j in (subseq list (1+ (position n list))) + when (eq (terme topogenous n j) 1) + collect j)) -(DEFMACRO LINK_LIST (topogenous n list) ; List of the elements in the link of Xn - `(append (Un-N ,topogenea ,n ,list) (Fn-N ,topogenous ,n ,list))) +(DEFUN LINK_LIST (topogenous n list) + #| List of the elements in the link of Xn |# + (append (Un-N topogenous n list) (Fn-N topogenous n list))) -(DEFUN WEAKPOINT (topogenous n list) ; T if Xn is a weak beat point of the submatrix 'list'x'list' +(DEFUN WEAKPOINT (topogenous n list) + #| T if Xn is a weak beat point of the submatrix 'list'x'list' |# (the boolean (or (eq (length (core_list topogenous (Un-N topogenous n list))) 1) (eq (length (core_list topogenous (Fn-N topogenous n list))) 1)))) -(DEFUN WEAKCORE_LIST (topogenous list) ; List of the elements of a "weak core" of the submatrix 'list'x'list' +(DEFUN WEAKCORE_LIST (topogenous list) + #| List of the elements of a "weak core" of the submatrix 'list'x'list' |# (let ((eliminar NIL)) (setf eliminar (loop for n in list thereis (and (or (beatpoint topogenous n list) (weakpoint topogenous n list)) n))) @@ -86,39 +94,43 @@ (weakcore_list topogenous (remove eliminar list))))) -(DEFMETHOD CORE ((topogenous matrice) &optional list) ; Matrice of the core of 'topogenous' +(DEFMETHOD CORE ((topogenous matrice) &optional list) + #| Matrice of the core of 'topogenous' |# (the matrice (let* ((list2 (if list list ( 1 (nlig topogenous)))) (corelist (core_list topogenous list2))) - (submatrix topogenous corelist corelist)))) + (sub-matrix topogenous corelist corelist)))) -(DEFMETHOD CORE ((finspace finite-space) &optional list) ; Finite-Space whose 'top' is the topogenous matrix of the core of (top 'finspace') - (let ((already (find `(CORE ,finspace) *finite-space-list* :test #'equal :key #'orgn))) +(DEFMETHOD CORE ((finspace finite-space) &optional list) + #| Finite-Space whose 'top' is the topogenous matrix of the core of (top 'finspace') |# + (let ((already (find `(CORE ,finspace ,list) *finite-space-list* :test #'equal :key #'orgn))) (declare (type (or finite-space null) already)) (if already already - (build-finite-space :orgn `(CORE ,finspace) + (build-finite-space :orgn `(CORE ,finspace ,list) :top (core (top finspace) list))))) -(DEFMETHOD WEAKCORE ((topogenous matrice) &optional list) ; Matrice of a "weak core" of 'topogenea' +(DEFMETHOD WEAKCORE ((topogenous matrice) &optional list) + #| Matrice of a "weak core" of 'topogenous' |# (the matrice (let* ((list2 (if list list ( 1 (nlig topogenous)))) (weakcorelist (weakcore_list topogenous (core_list topogenous list2)))) - (submatrix topogenous weakcorelist weakcorelist)))) + (sub-matrix topogenous weakcorelist weakcorelist)))) -(DEFMETHOD WEAKCORE ((finspace finite-space) &optional list) ; Finite-Space whose 'top' is the topogenous matrix of a "weak core" of (top 'finspace') - (let ((already (find `(WEAK-CORE ,finspace) *finite-space-list* :test #'equal :key #'orgn))) +(DEFMETHOD WEAKCORE ((finspace finite-space) &optional list) + #| Finite-Space whose 'top' is the topogenous matrix of a "weak core" of (top 'finspace') |# + (let ((already (find `(WEAK-CORE ,finspace ,list) *finite-space-list* :test #'equal :key #'orgn))) (declare (type (or finite-space null) already)) (if already already - (build-finite-space :orgn `(WEAK-CORE ,finspace) + (build-finite-space :orgn `(WEAK-CORE ,finspace ,list) :top (weakcore (top finspace) list))))) diff --git a/src/kenzo.fas b/src/kenzo.fas index db5ed5ff70c6497284d62809960eebc79b591a18..610b7f316b86057be9367c054ed20fc65d5ec9ba 100755 GIT binary patch delta 7464 zcmeI1dsq}#vcUUv^B5YY=^j+31#w_(W)MUWRMZerzyPA6>jM=PR1{wbg7}K!8{#7& zx1y`bYBXk};%eM)q8nWjWfK*5qbAW9eP94pC7c|5nAsEhp({wE|!inoiRN-+#9+l@p7vzN!S(V<>v$+vG(Vnvnfrr#?9i*>CNui4!-Gvg0i)a3Yt9*GO5E-bBFn7AS_B|afJ zJ~77DH$EA94w^519>{S)lS~|!3j+s*!ihmj!0;fB<4ykAL2$j;CcR`vExH`@;(6a& z5HusUcLTcfF$1tlI1r3t>=Ck>d~aaAa0Q3O#|jPH$`ljMsh;?vwMvN&#@7eb{Je=_~Yk__<$C+iB<4lj5(N`A7!H$`B)(skG zs_X^$Gd_31-E@`pgy0f2><#h^V$Y*%ndIk>imWS@QVKksp*kb6S5qh(jrP^jAsm&- z%J$%TtdS;>63$$x)Jji5b;bmC8k$RDReuQ$yMIZGCI*QpzqSKqlh^_gnd#?~F(SD`dBihThuW_DyZ;5V~0YZi7F7?$kAah3--!oUbh%<@by+?+L!?SpZ%GucYm zF}wSWGdOGJ>i)hM%#?=DPDAn0@hfb|Su_Q0D|=#vWgm{nd{__i2Bu|hFyi6znLp4) zfAYOdqHqcuoBw;W9un{wYEhxb9Gm$)oFcQYJ}b&!VZxjN>Lm(Qz-WGzV(MY8VZ988 z=H#$OcrYi@{w^jcb$*osU&SFyVGShSK{0r*zPSD}q|WWm*1@!_nJSNyDL)c?ak@Ic z6@c=;g|Q^xhZ|XTzIQN~vg26}^v$+w^D#A9^tsdt&Brk{InZZmD9Sb*i5%pUL-qHe zIyO(!+jB*)0N$W zzVo|G{1gY_!|^^o#WdnK(N&gD+cCc`m7IL$5srxKGS4kB@g6!EwY=z$Q*6kBIFPbz zqGl%C@IGZU`vvf>-phsg-698|#VTK-aZ}t+ym562<3fkBSQtK3#jHw(Ca}k_eJEvE zU)BXK4^1*>Q@@X?6)zrwPPyG!8w|)L?=iUvy=$m<3)9V#^Ls^*_FB*q!f1I+(sG)t z4!R;s+u?X_ba)shBwO{W1nC3~Ue%QpF5)pf%AL--L(#Bk=XHv?knKSSn{mKV7L`~%(`R>3F8u5QB%S??m6{07}*>N?n2%Muiwhv1 zU@u@)o0JM&7pi>3>u_nrQ>+M-yyz~v{hY^6&ga<$OvK4Wgi0_vZvgt$k-h{ixB+a224B;ba3rQA*N|T-^=Wt!gl0waJ zW@Ilm5FU<!5~&HcqoEp3;SAQRRwaQiegAk6hzf3Oz`*#?E+52HXy!{;d2zEN%KK5jc>B~g~Q4ex8 zAK3xVXDz%uCN3-!2g=z;qc5{BLYcQW<1rMthzK)$J|;3)-%Oi$&t?K;Y(dO^8qOAP zomUa06Ev+`^|6_x!4hm8tFcyS7@OnN#E(;B zH0t2j{Ak<}PH8IUBfr5vkIo6wDIBZ3m(Rd6pCXwgC>v+({WQ&cz20e_^c1b)0iO0| zzI21Uf5V?g??P!F&HF*!tweeN?~JqY;R-a5iww3i#X8q=LRIIcS+Ncv{@y{@E4jXYW! zbR~_8I118u3Ys`RDOjJD_l!7PL>p9$j~byT`k^;bY-%X(ll_q%$0X^wf2=F++%LNG znNHn(!dKxyY&ej=j!(tjHdkAr{{*S8-t1cYX4gGKruR8BO<7IOC4yE@ zeXgS;Q6^{;;qK)Ae4H8LrqBWmpOO=`v?7bKFS~Sf~d78dHALn}VV}ecILuZ{D@~|)6I)wu9;16L9&40u(Ofl&=P@74ZR+$xaWVX}Fv76`yEd8D zV52~C*@;3BT^D&y-icFXGEt3u15%5Ur3~_KsEVd6pF!m$$z|dwTBAmi7mI6Xm;8a`mEynQ z>8bYW-;(t-)$9^qq0QYy@;&yy+#+UB<{y#VDq3*zl#j1M%hZSwsg%QIsy8t$l{)^66q#vL zY3E%f#mcmA$?|7XY)oq;%QaG*Ol!euQ<_OhU|Jgtn-(3mlk8toRUXrFX?E|BlFzgy z@cgu4eOI8OJff;vrqK;Rc}z+j)2`#vD&LW^jYV6?jp^U~T`YR287$LN@q3UrU1b)S zJ>8z|pm7gkZ$#lGjb4(H3zz{nE50(&4d4;MoSXb1P3<{p9-yxJQ z;qvq(nXY^+g!-nR?zccKPUi6=F`_u3`xsmuD#~m=VG^za73H=sw>y(Ad}DC+O-zTJ zW3azC?muwzAGlHee{fSWw@Y;ogbt?0gBKgRy4c$tA%7Ye;q~^!)9frUjAB-Z{~0}f9=PF!;!xZls>^*~d>u0I#Ms9AgLdQ%VH4!d@_;~LmSaob^627W=uml1Mp zC^L{N?+M)UFDKlJD<|9ok4IJh(*);nsn2FK$tl7q>`B;cSoLPC4P$s0BZb zTjb`&EhE4`VAq0GW-G2Vr_RTXz|=z!UlE#V#u`7h7Hj-f7d}nuCaeiiQ}yi@j?X}K zAnuGHwG?Hux)iOFx*6qQ70^GJ>x>Myp`wr>PTj6l!`!?UfZr)EuieG3i@|H1+3V1M zA>rDhgiYu_v+MC(#D0_AyCB)?SU#kEq(*n?|pQ6XHrT;;_z z9y9mi8Yw!i^;$%@R=miIYlpC<7uU9<;>9&m2-jSTbX@yju@~27V>BHY8n|Z5rN$;s`vJ90!3kD%YEyM;Q*~-nb!t;}YEunr zvw5hk23sJt`7U!)o2pZrs#BY4P@4^@EqB?EsqNWiKZDxzEQ#9KvqWuWUZc2GQSSkckd1C%C(~+<-eXoFU-wI9%Rcas!2U)`BUO1o8UP@1;NpfoE?SrvwF zm}RRBQnUHfBAKK@xVXwOa0VXkZGvL?76D7t=uX#R3tg(jA0u2x8_tQtKsY^T-cbSl zRujS%u1+d25H1Iu@_2`VaHQn(4g=vxDdZgn!fi*Tgm<(@I7fSga~KHMif$`;$8Pv~ zwdyo*jjFcsjzrviN)B zp*NB}^hUCW-bnV)8_6DeBiTc5Bzx$MWDmWahP+x2y-~f1IShIuMP?3z-bk@Bhe2ajTC!ZsFyZW4$-jr^5#dFge-61)z7rI9HF2W0|}S zFDvY;N3pt%>*WO4bU`Vk$|`mT`=Os+*{+JsXTppBh2f|u-}t20;BP8QI-l-9cPh#w zA-x>0t5lRpe(5*SPDSB;)2&!XMLEjSd!sKExG6;-c-D}vUovh(OlPC?`~xsdRERW>sdT)?yS;Tl}79M zX)x+!i|d)jIzI53;bUy+iHZ8Z@oqHbxITT4`MP?Xoy^0>eioDd|G<&SiLMQQI>=n3 z&V8h~x;5APg#>YTF-iJ)q#D16LK`0nEnisKc#`k~iBDJB-+sljzHqH|f;(|n>dlSp z2chB2tsbu6+x-GqEbJCSpx|CNmISNr4P*d~_)GO#%N*;v}r1um}qNlw5Iu;Gqby){_^?!(*MinGuLzO zIrrRiUo-c+Hr)}L?g;y?v7Cm{muH=Ot7q$7nVlau)kmFLuy*lpIs6mwQSo8;1mIJ1 zGL~_zdZ$yJhEH33`u4x_&5zNlbyHKBeYANgNm4J&@xvp?9AMIN3)Id>F)Wys5?gAZRGGi@hwUImcbHH~=!R9oh!7Op9w4j9|2)6GmW?AZ1+&%YS|34S_YdAkEX>s z-o^zLBeziCk8rS}?I?+VMlocEzO3(rK+oxI*nB7$I9b_)%PlC!>}(x4mhFS**umyltLWUO{SQFBAm=)dIU*qB+GHO6Z5i)*Qxgt z>}8B<7dwHyQsJZ5!IdH1*-!}0a<XnYDPYs4s;i3D9)FWz*g54AED0~4OxX-l9Hj^+Jm z8N>~E`lN9@ErwOx2I?>;n*f=^dW)G9Y%)*#bc%QwHlU#moWim-G!1jGWC$J}hfCdI zxYqyIIF=TE^m3JE@eji|&an?$agN&nvidKIvTA&`JDn7O) zp3|A|tKsbi-9<0X@gt6%IpT28yrTh+qrgR<#nD)$Rs8>;ZwzkM7kPcR#^AykA`|ru zXDB>wI0zk)o3Md~x=#0{I-eqlQ)zx*)5mQR?^xjV5h`ndVG~?Bi57mZvH%a=ZVF%CVOfVx(;`{t?%+x9-fGbC3xloitEA?WIGb)d!;6QWVgC5_9E#Q2PH9Pl}eIv+wtQP52b?J#syScpC~zc*rW(Ho&+R9vc_>_uO) z*xXP&Z-9^VSSC@=|B|j?{%~%T!V=)CQ9UsF>MARA8!dLxU2b??XcfNj4v{9LQMcHQ z6#u9z@tpO5=w3AXX~y5j*Y22DjCNy83bTQnn}qV7YI_S>G?O?IigGn3!z;N~XB}=i zIf7QiWIl$=BU|h6B`&GeSR>o$j7Yp%02gwd>??SXo6@% z3R}i1;vaF}$U~{gPF^*^>9M`zcT;C$D5Yz>dWyd1<7%);Bd_+sHJ0#?@-AS)Dv)QoMOvI zH+eBRPZ88Q{SL7j_j;M2X2QL3UHPlQ(0)A4^pNoxSZ){}$vVP;@o}kL=w0-l(Ck}a zD1z~p`h!3*P2wSXnVlB&dB&X(oTr3j(S|)M=;w zxf<5ybxuBsBWen5qWLqwimgL$9j1#b9!->QQ|x;4T+Ao*YwGl(xfCAeMQhdAwaK&u z8wHWeW)ygNpmIj{vpZr=2DW+ zlYG(Kk^C=^e9b(Xdb~(-Bi?Q=Oh_7%NIiZ+H72Gu(JuOw6p5)8Qa&Ta%G7O?z;#mW zOr1`a8>GZDwGk&tZXhKI1HiKrowjtce?wJSOm)#*-XSH2sZ-(QiG#b8q9Q-0sv4%! z_gwxLDQlSe1umrgBPr{dQy@2{f5B^+^Fc6#74*P2cy@up1ejLfNWVl$^YM)B ztb@qHPCUNWvkH^^Ia~`4mKMeY=xDMT>I&Qa7fJq$B>ypz6ishk6^f|9ltjD;@X8}B z1?79Z^Y|%U@P^>8WTPCQbiuNPase+^CZ!(z0~G~Jv+@c01SvbQRj}g3(xTkL8d1r^ zGDPW$HIlLpWm%brZ9|n5Y!#-=!?LCF9@ex{E=ObNaOD72MJQ8IwkmD0RFwVLEK=DI zj^a1?J;89iIGokOm0}%|9u*TLC6xFesjHRaqCAk)NU{f#_8~Au)k1lR50aMQYcm>w9k4p%WtfdAdIfpi9qYymUbS*U4h;D_t^#8FDHEYgB`}E+* zM%dBcb-7hpKm3x7E+hI`Rc6pn))VAoDkt)3UryvRp!^q*4}Cy<#AD_@Vj@K+rj*%4Op|8&h-ojj^byk=sQ8G96e6bmvvp$n zaE_0dreZW7G0_|oF|C%IM!4W^7;3$56#?)U5NBF&!w(|$@lWG+w<0+Hg)Un7edVq;6KMzcG_>Rzl z>GSzkn+KREktcx(LKZ0OO-NXv!_lAxv3;L_Bka^5B@b`Z^Tv2QyhMtRm-^68A;?R6 z7Z5Lfyujckdz{h2Lru+E9OR7_1~rKuY9a@uCK$gklI6p^g$5v{c;QHI!r3=M!@@X& zIFHXrd z5GVtkvUtrvAX0L8%|IYh@_5Zapf^yN!fVYDNDJ5RT67to!)s^g3i?bFx-H_hwQzT_ z68|aP-O{OQJ+CF>UXnA&xt70( zm4QWKEMbvmU=b;4g4P_1Gy{tivk*=9N; z=sPfWX3=E)T~Hv4UGxB!ejW+1wk*x?0v0Wn2e3#az~Yzr0E-snX8?<$J_%Sw%e;W~ zEj9`wmq47ee+Mk8LBQI(%nMlLrUTa9WdvAZ%e{a_1_CVCaxY*}jTf*;_5v2kUce&R z3s@w30gGe;tlup60v6SH0gGfWV3F(vERwx|MY0#LNcI92$zH%B*$Y@C6JYhK@d6gr zn3!e&7AX?b48S7A$}|J8NU<}`04!4CnbwGtBsY+fgaP1qjTf+}DvN0bV3Cr;w5jl8 zjTf+}s)lI>V3D$hX$D}CvYy3z0E@I*7LS0nWCa1%sTBlR*H`!eOMVKkZ63hti$7Fw z4i8}Eq9JG@7VGf&39we8_5@%JSlJmb2@6*yuoJLTFE6c3NZE>?+g2UMs<>MOdk;HC z=D2o!@SDfR+(i@pJywi=*~Zs|G7KPT^i`FJsQr76Z0#^&z@3LQ8=?Ke`2Bg z`0>}6sc=q3;f#{}=`iJFW6KT|#bq4|Cr&RaDXK6cBu;b>IQ0teZvP(h4;t|7aJwrx zS^rP9FMprmPCPq~ckej2o57`kP?P?jbJ?Ae-9taTB)c6Ay8_@ZU$tR9;T|8svZxFl zgP){OE|~jiDcoKEvW>@E){Umoo}Ar1ZmnYQ)uI diff --git a/src/vf-order.lisp b/src/vf-order.lisp new file mode 100644 index 0000000..567f9ea --- /dev/null +++ b/src/vf-order.lisp @@ -0,0 +1,400 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -* + +;; VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER +;; VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER +;; VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER VF-ORDER + +(IN-PACKAGE #:cat) + +(PROVIDE "vf-order") + +#| + +Principe de l'algorithme. + +L'ETAT est un vecteur indexé par les lignes. +Chaque ligne peut avoir pour valeur: + 1 = source (peut avoir des prédécesseurs et des successeurs, non notés) + (...) = liste des prédécesseurs, éventuellement vide + => non source utilisABLE à condition que l'ensemble des successeurs attribués + soit disjoint de l'ensemble des prédécesseurs. + +Etat initial : tout à (). + +Les colonnes sont traitées successivement. + +On cherche sur cette colonne un indice de ligne non source avec inversible. + +La liste des successeurs désignés par la colonne doit avoir une intersection +vide avec la liste des précécesseurs. + +Si oui: + Cet indice devient source. + Pour chaque enfant DE CETTE NOUVELLE SOURCE. + Si c'est une source, tous les sans-enfants CITANT CETTE SOURCE sont mis à jour: + ajout de cette nouvelle source et de ses prédécesseurs. + Sinon cet enfant seul mis à jour avec + ajout de cette nouvelle source et de ses prédécesseurs. + + +|# + + +(DEFUN RANDOM-EXP (d cut) + (floor (log (- 1 cut)) (log (- 1 d)))) + +#| +() +(dotimes (i 20) + (print (random-exp 0.5 (random 1.0)))) +|# + +(DEFUN RANDOM-M (rown coln d1 d2) + ; d1 = exponential-probability to get a 0 + ; d2 = probability a non-null is invertible. + (let ((rslt (make-array coln :element-type 'list))) + (dotimes (i coln) + (let ((rslt2 '()) + (mark -1)) + (loop + (incf mark (1+ (random-exp d1 (random 1.0)))) + (when (>= mark rown) + (setf (svref rslt i) (nreverse rslt2)) + (return)) + (push (list mark (if (> (random 1.0) d2) 1 2)) + rslt2)))) + rslt)) + +(DEFUN DISPLAY-M (m) + (dotimes (i (length m)) + (print (svref m i)))) + +#| +() +(display-m (random-m 5 10 0.5 0.5)) +|# + +(DEFUN NULL-INTERSECTION-P (list1 list2) + (declare (type list list1 list2)) + (the boolean (progn + (unless (and list1 list2) (return-from null-intersection-p t)) + (let ((mark1 list1) + (mark2 list2)) + (declare (type list list1 list2)) + (loop + (let ((delta (- (car mark1) (car mark2)))) + (declare (type fixnum delta)) + (if (plusp delta) + (or (setf mark2 (cdr mark2)) + (return-from null-intersection-p t)) + (if (minusp delta) + (or (setf mark1 (cdr mark1)) + (return-from null-intersection-p t)) + (return-from null-intersection-p nil))))))))) + +#| +() +(null-intersection-p '(1 2 3) '()) +(null-intersection-p '() '(4 5 6)) +(null-intersection-p '(1 2 3) '(4 5 6)) +(null-intersection-p '(4 5 6) '(1 2 3)) +(null-intersection-p '(1 2 6) '(3 4 5)) +(null-intersection-p '(1 2 3) '(3 4 5)) +(null-intersection-p '(3 4 5) '(1 2 3)) +|# + +(DEFUN INSERT (n list) + (declare (type fixnum n) (type list list)) + (the list + (do ((rslt nil (cons (car mark) rslt)) + (mark list (cdr mark))) + ((endp mark) (nreverse (cons n rslt))) + (when (< n (car mark)) + (return-from insert + (nreconc rslt (cons n mark))))))) + +#| +() +(insert 4 '()) +(insert 5 '(6 7 8)) +(insert 5 '(3 7 8)) +(insert 5 '(1 2 3)) +|# + +(DEFUN UNION-MERGE (list1 list2) + (declare (type list list1 list2)) + (the list + (let ((rslt nil)) + (declare (type list rslt)) + (unless list1 (return-from union-merge list2)) + (unless list2 (return-from union-merge list1)) + (loop + (let ((n1 (car list1)) + (n2 (car list2))) + (declare (type fixnum n1 n2)) + (cond ((< n1 n2) + (push n1 rslt) + (or (setf list1 (cdr list1)) + (return-from union-merge (nreconc rslt list2)))) + ((= n1 n2) + (push n1 rslt) + (or (setf list1 (cdr list1)) + (return-from union-merge (nreconc rslt list2))) + (or (setf list2 (cdr list2)) + (return-from union-merge (nreconc rslt list1)))) + (t + (push n2 rslt) + (or (setf list2 (cdr list2)) + (return-from union-merge (nreconc rslt list1)))))))))) + +#| +() +(union-merge '() '(5 6 7)) +(union-merge '(5 6 7) '()) +(union-merge '(4 6 8) '(5 6 7)) +(union-merge '(5 6 7) '(4 6 8)) +|# + +(DEFUN M-VF-HARD (rown m) + (let ((status (make-array rown :initial-element '())) + (coln (length m)) + (vf '())) + (dotimes (i coln) + (let ((coli (svref m i))) + (when coli + (let ((rowilist (mapcar #'car coli))) + (declare (type list rowilist)) + (do ((rowilistmark rowilist (cdr rowilistmark)) + (termlistmark (mapcar #'cadr coli) (cdr termlistmark))) + ((endp rowilistmark)) + (let ((rowi (car rowilistmark))) + (declare (type fixnum rowi)) + (unless (eql 2 (car termlistmark)) + (let ((rowistatus (svref status rowi))) + (unless (eql 1 rowistatus) + (when (null-intersection-p rowistatus rowilist) + (setf (svref status rowi) 1) + (setf rowistatus (insert rowi rowistatus)) + (push (list rowi i) vf) + (dolist (item rowilist) + (unless (= item rowi) + (case (svref status item) + (1 (dotimes (rowj rown) + (let ((rowjstatus (svref status rowj))) + (unless (eql 1 rowjstatus) + (when (member item rowjstatus) + (setf (svref status rowj) + (union-merge rowistatus rowjstatus))))))) + (otherwise + (setf (svref status item) + (union-merge rowistatus (svref status item))))))) + (return))))))))))) + (return-from m-vf-hard (nreverse vf)))) + +(DEFUN M-VF (data) + (destructuring-bind (coln rown m) data + (declare (type fixnum rown) (ignore coln) (list m)) + (let ((status (make-array rown :initial-element 0)) + ;; 0 = unused + ;; 1 = source + ;; 2 = minimal + (vf '())) + (declare (type simple-vector status) (type list vf)) + (do ((mark m (cdr mark)) + (i 0 (1+ i))) + ((endp mark)) + (declare (type list mark) (type fixnum i)) + (let ((coli (car mark))) + (declare (type list coli)) + (when coli + (let ((rowilist (mapcar #'car coli)) + (termlist (mapcar #'cadr coli))) + (declare (type list rowilist termlist)) + (do ((rowimark rowilist (cdr rowimark)) + (termmark termlist (cdr termmark))) + ((endp rowimark)) + (declare (type list rowimark termmark)) + (let ((rowi (car rowimark))) + (declare (type fixnum rowi)) + (block block1 + (when (eql 2 (car termmark)) + (return-from block1)) + (let ((rowistatus (svref status rowi))) + (declare (type fixnum rowistatus)) + (when (eql 1 rowistatus) + (return-from block1)) + (when (eql 2 rowistatus) + (dolist (item rowilist) + (declare (type fixnum item)) + (when (eql 1 (svref status item)) + (return-from block1)))) + (push (list rowi i) vf) + (dolist (item rowilist) + (declare (type fixnum item)) + (when (eql 0 (svref status item)) + (setf (svref status item) 2))) + (setf (svref status rowi) 1) + (return))))))))) + (return-from m-vf (nreverse vf))))) + +(DEFUN MATRICE-TO-LMTRX (mtrx) + (let* ((column-n (ncol mtrx)) + (rslt (make-array column-n))) + (dotimes (j column-n) + (let ((rsltj '()) + (columnj-pair-list + (let ((ptc (basecol mtrx (1+ j))) + (res '())) + (do ((pc (up ptc) (up pc))) + ((eq pc ptc)) + (push (list (ilig pc) (val pc)) res)) + res))) + + (mapcar #'(lambda (pair) + (push (list (1- (first pair)) (second pair)) rsltj)) + columnj-pair-list) + + (setf (svref rslt j) (nreverse rsltj) ))) + rslt)) + +#| +() +(setf d8 (delta 8)) +(setf m (chcm-mat d8 3)) +(m-vf-hard 84 (matrice-to-lmtrx m)) + +(setf m (list 6 6 '( + ((0 2) (5 1)) + ((1 1) (5 2)) + ((0 2)) + ((1 1) (2 1) (5 1)) + ((3 1)) + ((2 2))))) +(m-vf m) + +(setf m (make-array 6 :initial-contents '( + ((0 1) (1 2) (4 2) (5 2)) + ((0 1)) + NIL + ((0 1) (1 1) (3 2)) + ((3 1) (5 2)) + ((3 2) (4 1)) ))) +(m-vf-hard 6 m) + +(setf m (make-array 8 :initial-contents '( ;; bug m-vf + ((0 1) (1 2) (2 2) (5 1) (6 2) (7 2)) ;; Différence entre m-vf et m-vf-soft + ((0 2) (3 1) (5 2) (6 2)) + ((2 2) (3 2) (5 2) (6 2) (7 2)) + ((1 1) (3 2) (5 2) (6 2)) + ((0 2) (1 2) (2 1) (4 2) (5 2)) + ((1 1) (6 2)) + ((3 2) (5 2) (6 1) (7 1)) + ((1 1) (2 1) (6 2))))) + +(display-m (setf m (random-m 8 8 0.5 0.5))) +(m-vf-hard 8 m) +(m-vf (list 8 8 (convertvector m))) +|# + + +#| +() +(setf m (make-array 6 :initial-contents '( + ((0 2) (5 1)) + ((1 1) (5 2)) + ((0 2)) + ((1 1) (2 1) (5 1)) + ((3 1)) + ((2 2))))) + +(setf m (make-array 6 :initial-contents '( + ((0 1) (1 2) (4 2) (5 2)) + ((0 1)) + NIL + ((0 1) (1 1) (3 2)) + ((3 1) (5 2)) + ((3 2) (4 1))))) + +(display-m (setf m (random-m 6 6 0.4 0.5))) +(m-vf 6 m) +|# + +(DEFUN READ-D-2 (file) + (declare (type string file)) + (the list + (with-open-file (file file :direction :input) + (declare (type stream file)) + (let ((rslt nil) + (next nil)) + (declare (type list rslt next)) + (loop + (setf next (read file nil nil)) + (if next + (push next rslt) + (return))) + (return-from read-d-2 (nreverse rslt)))))) +#| +() +(read-d "Vector-Fields\\D6.txt") +|# + +(DEFUN D-M-1 (coln d) + ;; (col-i row-i entry-i) + (declare (type list d) (type fixnum coln)) + (the simple-vector + (let ((rslt (make-array coln :element-type 'list :initial-element nil))) + (declare (type simple-vector rslt)) + (dolist (item d) + (declare (type list item)) + (destructuring-bind (coli rowi vali) item + (declare (type fixnum coli rowi) (ignore vali)) + (push (list rowi 1) (svref rslt coli)))) + (return-from d-m-1 rslt)))) + +(DEFUN READ-D (file) + (declare (type string file)) + (the list + (with-open-file (file file :direction :input) + (declare (type stream file)) + (let ((rslt nil) + (subrslt nil) + (next nil) + (coli 0) + (rowmax 0)) + (declare (type list rslt subrslt next) (type fixnum coli)) + (loop + (setf next (read file nil nil)) + (unless next + (push (nreverse subrslt) rslt) + (return-from read-d (list (1+ coli) (1+ rowmax) (nreverse rslt)))) + (destructuring-bind (colj rowi vali) next + (declare (type fixnum colj rowi) (ignore vali)) + (setf rowmax (max rowmax rowi)) + (cond ((eql coli colj) + (push (list rowi 1) subrslt)) + (t + (push (nreverse subrslt) rslt) + (incf coli) + (setf subrslt (list (list rowi 1))))))))))) + +#| +() +(setf d (read-d "Vector-Fields\\D1.txt")) +(time (m-vf d)) +(length *) +(setf d (read-d "Vector-Fields\\D2.txt")) +(time (m-vf d)) +(length *) +(setf d (read-d "Vector-Fields\\D3.txt")) +(time (m-vf d)) +(length *) +(setf d (read-d "Vector-Fields\\D4.txt")) +(time (m-vf d)) +(length *) +(setf d (read-d "Vector-Fields\\D5.txt")) +(time (m-vf d)) +(length *) +(setf d (read-d "Vector-Fields\\D6.txt")) +(time (m-vf d)) +(length *) +|#