From 0b126d1ce50e3ae395ad6ed93c7c3f7040c050bc Mon Sep 17 00:00:00 2001 From: Jim Date: Sat, 4 Apr 2015 19:24:47 -0400 Subject: [PATCH 1/1] tweak reader2.ml, add Juli8.tgz --- code/Juli8-v1.2.tgz | Bin 0 -> 31209 bytes code/juli8.ml | 1523 --------------------------------------------------- code/monad.ml | 1186 --------------------------------------- code/reader2.ml | 6 +- 4 files changed, 3 insertions(+), 2712 deletions(-) create mode 100644 code/Juli8-v1.2.tgz delete mode 100644 code/juli8.ml delete mode 100644 code/monad.ml diff --git a/code/Juli8-v1.2.tgz b/code/Juli8-v1.2.tgz new file mode 100644 index 0000000000000000000000000000000000000000..c3c2f0119e4a254323c8e938a17ae2c76c2d8049 GIT binary patch literal 31209 zcmV)0K+eA(iwFRJaUfLy1MI!qb{j{sDA+S=&6+iQIrB90n$7lZ79uk&<%VLsq|)5ImORav-Dlq`3P-4^PS zm&mwfL}X;v-)7_Z&%2igt@hsU-q+v${{EjHJP`EzIsfjr@AI$x69?@F2k?6T{(}Rt zf6%`Fp#3}X;Jra){mt?s%m9?v@nmT^C^j4}c`wJIe}5x?e>3#&U&Q@Ul-xcatWW<3 z_aEGE1O4yse}3?Z{vYDcqW?vhkD~GT*QEcS_8%ND{r`0D6a7ELpGE()A5Pu_^*5yd zy$3-5dk-G$f1>|~__OGrg`ob6_rL%f>HmA5BmMt$@00%jAb%G9zkl-ht7lK%Lmz;T z&+p%_r~ke7=NA3Z{=0YY-u>T+{r3P%1{X!$(N8>02 zSpFL4@NBWQg}f_v#eMO3n#E($-amM-^=o7GxARw-|A|_y$@mugSStVRgU=uA-_!E{ zImixB5N3c+^8X?Jf;-~n1qkA0l;xlU#4t-I;=qz6ai_7hHAx4vaU_UY#IazNv9%T4 z*%Cs&dr=I`8v%cD(jU(Tk@zmkF2g*&jBolxvP#D9;)_P^1?xL9mM$#GPOK4>lY7v2SpLou8sqKl>b@EQm9{Hy034F|rR ziv_+Pir^ft8;{J}aXb~lzrhoLgByoCD0yx*J~x$BA*wfY%E&GjVy?=>a}f+-EP)(M zuYo`2u3^U6gQl}O29@bykPut1GS&&Xe7N1`fm*Kc^28GXf9O<;7 zpP%uF+=@f-nV8S#@b6-=fQndC{QJMtGx(v0SD=6|P)Sd-bQ)!#wyDY8FwfI|92P** z7Limuh0&%naYk7C?6U@<j<6jU&2@5RPN` zZ;W&30bK6Ocj;hIes!RR8J}~t7~we*`%Jgp0}+j3s->q7)l>O!pMAXBG`S4aN!ZV?5}F*}2%pGTXimfS9V2ER5k_Pvbl5w7#>dd4-yM)|1rNExvsV z_x`4#wA1jhSeTX% z4wYj8!k4Hk`Vq$@)k+J6vpKYx$fp8fNsxCWDDo)+BQLosg2GjydF~t<*F_fM4*eHU zbB0+R9-HebRH}y3>DBg@0zpBi+A%NWFt)T<4x(Y40GkFVNW(B5U&Y0R*w!z$x3v0( z`3SV%1pqmYGLl&vML7y$K_WgE)JTM)EsLYfGdDzfH1;c)7Ax9$9D*MBOcdcLg3){? zVwe-dA`-c{2Aw)VEiA%uo`M+;dh`sY#7UG}>JiDN>KNieZ3#DHQ)B7cLZ7L%ixkU6 z0M!~*5HF%|0FVt}YWVRYh6#OIg7Z)S-<{0>wlTDp7Og2k;DNGxB^z)6oWczg+bu%y zFtFDWEFw~xf%22Y5nLQ>kw^?udNxRt$nDy#0U8kQY5F*{Uu_u+=Q*po4ysFn5|~ir z=_InPl#~kT*F}^UX5#Oq>9`>adW*+-*EGoQR6V;)f`eIBW|qiiqIu%@<$g4Km z^9{x~3~0AB3V2fOejFv|#YGu$Ao~WuXacVvMQ=KR9_13gtnd{A;^7BpOeMB}Ds8(C z{o7wslM9ra8OCGK1Ab9*=%nj`PvJTwGzFtrpuE4J3;mqrbgGOBydd4frC8g13qq&M zD?vR*dyb+fT$bDq(mQYYdKjvSQC1__wW?vW%PUD?Mo}(zN2my)nrcPPH1kB))^a=) z=tJQ=MO8u7g$1gJbaN@^pq1b-6w{3DFz)l?6;o zF5OYsYJj#VXlgqYB(WQcnYe@&Cd2@<<|Wgcxw>hfQO%)CqtbUf&e zqhX=0$-8eifQv(b6CHXmns(4wdNYeNiUAW^atsjn_&yI|a4aY-5q$gnB?b#F;{n*! zU_{}6T`*ChhiHy9+YJpD4e;a?=QS)D4To_*j*|XD1T&qh zUnmNyjvnwYJYden3OGh;>$+jE16>h6k_AmzGL5RX>bv(gz7&7yteDOUL|{M7!1kY} zFiTOq9UrIJ0GmT+sJNJMl>Hoq8SGJwArOSgbR13KDkPRvgZUcJm?N>VK8a3NL<43a zK?ZFOV?-!8qK4vDuw_~R@uq@tkcOkUu>ePUjGw+9r@q9P=p2_1;EV3sRkGsW1x z(DqLXPC>}x;i79l=gQV2MKJ6_kmto%08fTS0?ry^z#tk* z?r}RDF9qe+QQ+=LX!i(MDZgBJj{%m?B-C_w$nM;Y;P-+BLf4V(i7>&NxF6*eKv-o= z!>ovr9iS*k@tJIc-kza=o=N>5P*ARM){yX4VBtE%fB^WAZ#94~X%XonMELZyPO44R zG0Hfa!}})jb<<|*ILRY?G>Nivn7c?fg#`jxToEE?z_=t&z^bxE`>dQrAFiWY#Mg?vu&Aet4x;xJRQcWjymh+K%dNmpK0 zc+F)qBjJodGnvhB7NY*ed6v$mRSZUN2!R@xdx)Ppgf_(muIim<;Y4@&B8r&V0Nyup zP;be&@!>US2$n6rbu{t zWv&N)i+Db$8B`V~AS1|!bk*gcjI=z+erTGvJIH-~oR-4ue1@&6#oi)3KL=q#1EZ!R z7D{T1CnD~`MIFijuP{Sd;OA(H7Re;%;5E!FFsg;XNogO;k>P+`#sZMHj24iM5&KMG zZpy_rzu3l#((cg4oLIdEVhpR`)7Q`00F^oN=N z50548Rioc!Fux7df^Lqy3|8A1r86$r^kSn+np^0zj5#d>*e;y_Cr}KR{015!*aTmu z6R;8@UVCZMN=A!qd0w%z)?53F{usm7^W2JLJ^lLY|0WV}7Qn|*Ml@Q>7|l-hV8X}A zzJD=GMkhO`dvwtSxt3SNIL>rJvw$*d-bhJ&qk*A#Bn<$&i>&|{Qpb8`RTh42jT;WQNdJC36xX0 z>Qio|6r4moLVDB*ITE{;AhAQpzW0?FIdEsCi~}W>*jZi#6q-h!Rpw5mAkCL`5Tl4J z?*~h)041DGG4|*y<0}qu16r-(bp=tMb;KiboR>CTp&Yq>Zlsz5!A$S^aPT8EZ=F}P zkmPoXrAs}cIZ_UcSK`Kx0ItqXpDuY!J@1%$Wsa?lCv%GftHr)<<`Job&Q9cSUIv{# z*aJuZM^L@aa9D#86n(>Jy&527XLo#kS-{+>3>CUYf|nZ%baxvJu2c!e7>+`5_M#ZH zXq5pJe-B*yGg`Hy(V^e?1GQXVvb!h%nu5fY{hs{lWRW ztcRR=9*b8yU#nV0yXaa<%=$HWDYvF0tkmMQg@kK{;=0_>b+zt+1&;i;JOpb3GeO-- zpS?=YYCMA_IrnvpYC1r~7l)Lu!V2aU5s(VG?J`eaAxMw~kG zmAyV?o;Dn^+HGz)t|hz|y1YY6QtP*FvyNM}*0yyf1gGEm+8t}P1*5?PW(+uCNYTw$ z!Zx3xsy=JVs0%Kw6;g}mg3_79Q*28|jebbR@hD<&WY9+k$uTPD=y!gtomy+&c{l$S zhgWrPHyR3i@3g446seCeJmsNGS)@4bd`m-Jqf-<@T&}dGj~I;QP7ZBa5fZAifpkEPOLUmn?Gh_Z*^#;)SeGCt5To z>y|p(pa<9Zww51tYp&NLO-sE3=~|pO8>RcCYJt=ObAi~-QhyB zFADEwVbcnPub6Fnt96MrV)|+=qo&CUZ@=+j!pFd6K7HfRaV=(i^NzfDGmi81x(37D zfUUf^+=zFSCjBnWW84@g5|O0^t~#S%e-&nfLvhAW#DP|^a-|@kH3?9usLSGll`F?U zaizymHnNR%JSWadGjSjZ@^xc*oU;Ea5#+mGV6u1U3g+6U;P^J#<^}y z$`q?)o#6un4;Ogd;O=!bT4ti_GH_KFfi5BB+6uatQ|+gZ`~BJE8wa_R!?G$tzTAPnr|X50IsVtv=l4N(O%FA zOqeuC2D)R}P)#j+t4!1te&ToISq81Doy@>wXGv+{CI=|{r4>FqZc;XSIdcYgi1S*$ zD~j|IxP?+2q&&(WOvkXER2!8^INUTi5x5C?(9Mf<3SO&9?&9Q$1IlKhI8TK60GxdQ zCB>1fUj|Ax?gz~W7OM+P+QLfpbl5~LT#-m-J=dzuySLS$p0p_H1PI8dDX{6ue2&{> z7Yn^qg4=iLKWAaY)Tmv8b?Em+m;*E8Q5k&X#nshSOCFuoO0)C5^Nar8AnoUSV^sge z-bFDP@9C2>_Igl#FVFgWUxh`u`wcYQ!V-V5vq*F*hn-nc&gP-?nkbn~1U89!1vq}c z)uO$fGBE+?l+o@%v*c>%wftvdL@ER|O&$R?5@4~`>{%#{`!F@Y(0U{v)5 zY^Z^{mMkn63CS5bzA_Cn58?!^iB+r&&2&@Puazv#(HrjRv3 zgi?`2(E!u4DIc{LLDPMhOXBlcI?E4B2&0T3Mvuf6`$Nw}z()|Ae2rT-n&M?Pi%v-` zSF^k*M{6X`@hAibSOiTHY;=fQ6+&F_kaj~U+q-GbT(S6XnvNIgBu>)Su$|*t?%p80 zj0gHiw~Ku5OW9$X#r^y*QGz=)G5Pc&ZxwT3CQ2%kO#+dlq6quxAR?B&ibt_-03rT^ z#7*58nL<2LoaqC@kavL}8=`-aqQs3FoRQ;Tqs-`s#Nf8bt%R?OZFHfHh@DCeurnDb zpl{5h&zPT(ew;s#8L)!ZEz|QDJ0IlY?3ugHN;NlU z)e;OZim-I7~x4o0Qhdwh;s-l4PuY$XRbfXk^!z;1b8 zzG}O)D_`%(SXYN}n1RM()AMA0a5!%t&hMSFH6BnVQ{yn8bSC`0*OY;z#;F@xmfIsb zCel=ikjdCaSnd;jfJO8Anme5@uIJbDxf@RbYpR>2U^=Ww!9>$Pi^37Vgz=&4TkPiX zb%fddc|Sw;%cFC0gAX~Ic}MRrpcoH5liMdbKiPKP>E*ITYloL)`)id)Ukuy=&P_+P zh}#IT9&PF)Q#mPkCjq7#7*iQ9VX_E#6toWmROmzwA&YiFB@7ymlpT1cGq=U(Xauwm zb)uR$xd%6g_|pdCfG!U3e{hKj?y3n+`@obBvo8~mIRWUl^&$bm_3d`c>x{j#G2G%K z(PG;4^X+%&dxI*Pv?|1+fp*FswR7zRC>-$lyh98jfYTO?4(^WHcSrXc%vo%h;xqv4 zB}NC$QM)<1*DB$etDgWqZ9JdsBT`S=@ZY_|`-cxsOBgQW%xg_Q=k04<1GCSBw!x@m zpje`$Vx-QQ4Acslk|YUuJeGb$oT{IAv-EXYm8Ng)O+PtB7^+7q=sMaR(Z?Fu#~sDh zwqk6k(}4~**QjF;Z>zY@hHIe$0w(a)d12V9Snek674{2h4#q1bi$1v^PH$eVBiK~1_&Al zB%7kN^TO&J+9pAmL*EPtpB3VhD7A6JQ(c~jqS~O-9dtd~$zfH}OiC=fs#o6Sv7-8k z#hP-@hYKaw2xz(K_#b|1_=`=r8m@-u2B^sqp>Kl|RIQrBLLmW0U{Q%h#ZECo! z?yPS1;3)R~eH=M=Yo6(v6?JD^s$^j}2DCu&WI8b)3Pg8m8X~I^Hc1O|}M^GxA$>JqR<>TH6c2y;&U90#)pE1Y~ z@=1VHVPC;j?Qx##p6uaic$wZ<0ST?ks#9NlgVlvdTCu7u=87HW@G0__Q!se@{2X{1}Sk))KB{-}D zEG-3fV_XLAVLselL+Y-@5-itLG`KSO$BjuFBmbRIFA)!O&7$$qA^wJF-vH@yhgO;G zn~41DI(}D}t`TlVy?%Jz>0E2o3uva}kgrkWN)}P3CDDbtt)i<*z*lhA4CeTvxnRPn zPVy$fr}Y5*pIT-7&Ltw6e7lflUEVA=! zOp|JNj-wAW@B8(b%F z5q@B%v2YyMV7W4|DqE=2jol+08Hk`^cMfPhR7D-1kM^(*myLC0%Q3cXkFFdh8kWLD zyaRT)zUjKT=|qO=VYQK})f5<3@z_j3W0l3U)Q&7!Gkhep+OUgOMu~?M2VHNKn8&Ua zV8yu`X0o>O4(l4N#1oeEG55FLCZN}*+w~fh(}cJ#5wp$%x#lB8U2=LzcfFi)OX+r9 zOF7=0OagOVGxiEq%XF=AD)G#5BRZ-re`v(s>%2sIZwC}_G-xB%lBQ{uspPink}jyj z?0e)YOp?8R?_6aQ)7&h|I$iA=pH`KxTyM~r#Td~a|7g{akr~yL+&J!OsS;?xrry3a zHOgTdy?K0ECBQ<52%A+n4brECX9KTkt1jkQ9m{(CJEJQDphvm7f6E)-J?qi}>rbY~ zGBu&rQjnRz90?nSS-mjQ>ve*GLr(ZAwI0aWpkC|Xg6d-xDm=)qxEhz3>u+FqEw1J~ z_j+gS+9^*D)5cYEYAg*2aXC)dT~&MTskw?W@*seZnKBRm^Ir=Tbp{a6$w~PE9=SFZ;6B(i`+ja z3Gv;XhBJ@#7UbwUG&ew^F0oiOJw34Q6T+LcE9$^QJWrJX za}i3lY>E19(c$Q~ONYBl=zzIsyi%>*-$2|I4USo;QtAktO36E-+@SoTRt*gkZ&aPd zmy&Tf#l>1#*Z#-~cgsUv&W1s?!u$9PVV0!E6mDuvQeNHXBYfWT0DZ4+XJ|Xi#zvsE)g=5P>NXEf!ZEG5&8$8vIdYtZl1g3m`X-GIv~BQU(w+>kQw z&Tuq}Weg`zk@^thv|c+Dyroetm8*pFAd`()QNdNp`!n4rc3Vl)wMGFj)^ejf;VP+* zwIvh?U$$aeJJXd18Z&U5R45l==9C3!gQu4gHlr1fWZP|Nzf3Q4F4(Uyej5k3SIHbvbq7x zXyIh-2IcVHjN&WF&EacKbE()1w<(8SV_-G?>t(X};dr8Hs{+X%b;iwak4M(g3UzEE z56;_2F*tLR{)|YSQZ#0mr4p7B9b*LbQ=**prwTKruZ`O9SO$SvyLZz{6jkcJv&!*` z_awVir({jNAA%^PIi?bQZF5lvd*kCHQtcq*l^My0B^#emx)#wqSu$(N5ruRsvQ&+v z`G^(YGPw{I)csk+L1_G4C15Jz?uwZ;s&}E;{%Wf2SLw!QK&j0jyk4=+ju7h9Y;o9_ zruGgIwzNxhHEpj$UmKDVoz2`xFSKc2hEEf~Proue!ID8#$+&!vi#Hm5gIzA(A(fYL zEJRl!QMmT{V5Z^fUYMqrMVl2qHE4ABl?wZq)-E6H9#mI?uy4DU>XeTJKq6Pua$&UO(D3zkQ2I`ule)B-3w1JLN3@+AZr5Ur8o! zn>Es>K6C36KWxsDKY6yul6h-2qZ`$-7Q%P- zOF$~)^3Ka^2#h<#RphD8CChjD$Opk4`JwUrA{?Ywbg)E}6xm{T99>3Z{49k&pAV}$ zo2txAf4yX;S0gJ=?u6%SmnS{5{B?Dok;9go4ZIQ^^n^w>Fk)zb16H#K;Q=Wq4}J-= zJ9f%4mAK4esnvNNCF#`iC_!bmtgu}?UDoN^Iyl|#N)=c2=qPLrtGhI5zM<|nntTYW znE{ry#WR2(up2hVpQUvzJ9R?%TBhAv6Gz3I^GqDeCJgI!DRL!00kLUhbHm_O^Ic3l zCswlNw1Q=uW^y6E>G~n&$Vsz2=`hUi%P`|k8*5rV+L9marxU|lZainqi|`)hI2ejPvQ?~tsy!P2jO zDh6%YsiPq>CN>;uX_M$w?FjOY7hXGC9Az%H`KCWZtnPRia&Rc%}L4W89znQH_ozDqpD+SE4(o6jk&5~pPdc!z;7 z6KI+942g^2z+@@^;PySk<4*zk!!gS&4p{?4V@3Xtp1<|mVASMfFB2meIlNt7bv1o0 zw>(U__q)L748YfY;2YKLtjyZDSZW5Cf|aEs!dh;0)=KlT{zR|MC_O4`F-7S-UwOco zGpb*czJYHbw@TdgC|e<`^Mx^4XsA#6y@7BO6ECyi>C8eKYZy2hEf;RKpk>E-!UX%mIq4q)i?~*>F3dcas}*6Y%?{IvKGc^Ji;1D@DYt&Z<~b)8!4v zWyiS6BU`t#HAknFK>169Mh|>^;;&MmM9q_Tt%fE)&*lE{hJX z&eJj>sI{_h7}_<=*4l+iD+0Gl&k*qI0qDt+@c`;+)Efp=KyRc7Z|tGmZf4h-^znv7 zH_%^e#w*rLk2H<0nI`E}ST9|2MITGkCY9W;kvwUCXWbFXbw%-=N_|k@$VQvbWlF*hKJdU+Oj!xlQHmX2SMnJy}Z&{A_dWnH4qsAU}9xn}^j!zEB<= z?`*yFP`|XfU4Hyz?k<+f5_%~WULKhBLmNervJ2E$=2+N#z)SZgkF$W60TkKA??i&5 zg2hWkrdiaSru5Ap>e`$}W)3znfE~GSq3yeg*<5>a+H_%%AK0Pxp(Fc{e>|JWb53~O ziK=|qs!+z^wQCX@^FCNKudR;^=u`dQ>0I~g700??J7@7<^V!4e<>z2gUqZok(@iPB zI@kJ}4|DU?hig5?4V(non)*rswsIo3|H5+%2bC`qn2}$5Q+KfC^DLcB*GdVgRmXa7 zbO{CO+Y0vf@&H#-70%fyokkxoEY;76vA0;Jg&b~+me zR&~OSrNX7O%un%-pDa}!F2hLM%9DdqNkZXZumqpxjw+Mra+Wiuh#=ldKMD`^CzZ=_ z4eOwhEQN0Mr%dW(ca4M@^}!-fE=*hJ!q8EJ`XhjJx`>*Dt7$!iO8BW9UAN5ELJ6Uh zAd}?=15XZ6%90plyM>;B2-A%Eu z#twuf<8r$8p59P50A^>ub)!rV8*9t*FdZmL`8M(_&N+P))yMI##q0cL2kX2u0|7=~ zo8x$-QTtj-_3KXOb*@W2)WtN+fm>Z}edOdN$zr7<)Gw8~wjzey+PTGX_AOLomgv<7|T}<2I3F1J__<8njS+(c@cto_y^cd{&c@0oeC^V zJjT`$J&Rp0#4Q`d3Qc$MzTudERN~lsyb%Fs9c>h-;@TV|%@-5(Kwt=Xi9q|!L-__E z*ku4vbMjE{qMdk$THU3_8ztm)XGsx{#Um=hb!cQC0zFJ;D&!Sj)%?*hL#9nkVR+bw z2oW4G4iI>vwL-@(HAu(vst5S~t~h8|jT?&i@K3vkK9mDh$(DXd%rJN7en{>@(=a9j(H>imHc!BWY9~**a6NS4I$8^^qqX4L-3%^| zM`+k~+jcJEH?v4?MO~FHf#2iwTX*VYetjmtH0R{UD|N-XNmPD_@(>>+AB=ZtT zP2X2P`4ppa!6je*#7V-LCgQw%6aJ~h^Gi%Lw^j|xpJ#QOs3YPU?1bO4sL~Bjd0UVCcOFrEW?M?M601y3|1bv*3J$?0hYy=WONX4tFj?uu$<76kv8mT=HXS6JMfYVjsVdQT^ zZ`WoRH7#>(RCfrkVpuf2jmc{fq1>ny4&J<3cf@sJ>6)ep7g_XX7Neg^ExWp58fBAN z5h6FNlE64AqHG+6m(dO@J#c=PE#)+Y`ObtkLCCzxoA@czYJ*Z%Y1)yqZ3Frs`vjYS zih@5AOE>%(REOV9liXs)(+$4r)^r*Vz(Li$)SPOtbk_34`YZ)hf~g?`L3+Z12M!e$ zWg*5R@kxbI)Lnj|(gczmDXNK)tsxh<1XPaJZz2}X7%U!^@H(#phuJ%$YU;(BLPM=q z`{Y$ARYTeMh9-njRB;$#7)8PbfY2gpWXm1qQu)GxS0!6hD-r)#mA!(7s%iUk-9mqK!#O;JOa1kkQ}z)puVhugvM zg)bDod*Dct7Bcx*g8mPAN~HY-&_O&LF4ZSx^y6cMOYR@0swfj&X+cx0)rYmv2jU5g zQ}vUXguM1kc8QjPD;piiQV7Bqa?%cJt^s3AP$Smc@zq}~l7a+^qV_uY=9(vHn`L?1xX z4n~d*su_z|#h}qlB8+1F(nYZ<;9^9oCHUL^HY{dYINk>LS8Ruaa9YHd(YENNMUhT+ zXH$teL~auo_@*$o4nz+e@}ih__V%u>u3Cd^0$wACSPM|QSA^$#MNB7l?X{>M)fs+3 zcM@N-Oh)tRIE@SbW-Gd!*$k}QbO=s+AM_JE*&9Ua5=I+Mz;^-)Kvi@=Wqsykj#oM;yaKg)6$LsM{~1brJZ zzQ+0&=@m3tU?LB*7&bv@88FaF&GaIrX$CFTo%(%&9~+Ky1g1BJUa*aeFbCKZA)ya1 z&*?G1ofo_P5a`>BF2c(=&2)3Ym(0A_T@nJk3A|dNO%t6>NN&P8XaC7xWvVy?@Yd;=d1&vA&x1;&hh3jwj-1ps)Y^ zd;)Yr279PmdlA9p9s`Ty#0$ugIk4n8^gHVjFPi#$GmH=dWe0n`aoXFPggFdp@0+Jz zKKb^=lgbQA2=%5y)a_PbInfsR6|k{bEX4IS&No+P-BhT&m4J#Iflh54DraQTyuP*- z462G5sS#2&GoxytQ4CRBB~7u54OtaP^EYb_Yh2jrUHqqfhd=(&&4dUvpvlq00|e4H z#9R&$U63p5lTQ1rp{{rxui^Bl<`jtnzyL0F$@!?k_3Jys`2;6cXqpN4p=VgLa_8U>8n()1YA;)V#e$u>#mMCiEgduh6tlOyFu$|Ua zDxl|d=Q-(xI|w}@AN)3y&we@{hf}~#I%EZC$44#7FF1=4XunAAv~k|KPM84B03FI9 z3W?OFKKq@xB77~WvR`I1)gfZI%41L$`qo_5HiSV81|=F_D{i1T@Kw^Nj!i?ll=l@! z1jvClEa0LvYDVA}7RH56M)i)u;tY#*4_rTAx8w@af(423N3m-EkQIvM3KC&TQkYCQ z-L4lxb1p0EmV*_&JhXZ_GQAwF?u4kfyc6OxXt}viQCv(?wN=KozMDD`@(8YPB5nf+dYxy(mDE6L$`ywSKU4XXCRgrfDJ0}My?z$h7~V4`W= zrnEaH$7qC**IrieC8W$NdfqJbIZWVlr`DQJSHk3-BWm`dm6<_0OQ-|;pvm*l;SnJl1|LmvKD!%9cw+sS94)iMX*Y>t6OvwyPFhJI;(o_ z1pe?l)?~HPMc3YOWgic%*RY5;bgbCs4Y}gw?4~KzGvQ)yMf*HwPlqzVO<}!VDbkIl zAb8tiAl7QkS<_&bawAtmIrZ|>-S3cOB3s~06T3}crb(H~Iz~r7-D-y}sdTKOlzXfh zbl=G=KH%&pH{4VD61X4R8+KqheK18O=iPMJl?!RT3=HR}$d7SY4a|p)rpMcd+l~6~ zghGj(>Pi8~o@$F_Z~Ig(A8v2kl%d)`(PvVBQq4J(2&yfe=$0C?60~UtYA;|g>3J4T zN(ox!*!G27=CRLHk~r>)gtDVh!T&>^z|oO!7?l_*zG#&5h^JwkUEv~$KEOSMvo16O9xW`o91L6sL*wO_-v z04ZU|3Y=;PRN%LS*Z##U8OhCxDjnKv!E?Y_s3`2oB0sgCa&!c9vs7!>zFu}b-R!(W zKRcz4=wTO+ZQkUw?mCM~e<|FX3RdD*ck=_LD<>w%Y_`781}2>cMK2m|@)Ulhd#+NZ zoX`rPilS%#Q0r*rymfr3mL}(NGuS-0Q>bA+N>na2L!g;@Zk!Tl0a&APyNp`i%aF&{ zQ5Cx|;r8;jKiN)!Wb)Jk+OyeMiDs23gZeS(BL`5nAiR_}f$X=EVCSm_S97`Mq`{qI zwo)aeHI-_;CUwYWkWr^IVq3sU@v%BJi9UTw8bViggq=DtI6F2dke^%m0`nvA8W``@ zY#NI;a{hu2?VT0-n7K3I`VH9*l9tvk?}%@3h9+}+OHSUXYGCyEqD41bYL{uUP|xui z+nD#GDNWDT=j3G(OJ!|oD=nE(Iw%#8xALXTtd#HgPQD`a$rpI708P@qh7+#UW0*nU zH%;_A^*|P&j92*%uebE6O7F$tbBvl*5e)f`OcPFIJSZ2JNZg38_QRGX9fyv zWDOPWwiH`ls^@SiA6~~(^$;#~*VbdYQRv5|2ZejMwjRg!^VoXPwqLa63uErcm-<1u zz(J+NLAgk~QpD+o7dPx8^rTYcpjzgjQm9=mWID@asIdOtMWYeE12-c zezD`cQFRg{wQ#w$MQfscut>1(L;@L-;SwjY`r)*JNi?BCQ~nnbGfU(J{2(XdVQ2K7 zFYpnoT73~y;dwkE9MXCtUxoADf}ij&+2gV$b&XA^Ys4IH?}i)m4SBe+c7DShe)^W1 zkyrFBTpAF4CUQ&26IbXFFa5zKew9W3%&F3tg;0KVfe=F<1;9e;^mzN4yC8pJOPHgd z^w9Ke=`dFfPuHsZW=leg7xEiO1_ZpsBQH!pZ=7!4lzVyObV7G@5C%~c#f>R?4L`K+ zorXgDxFy~&FhZBS)0Hl18Z%csq0v3>mf@;u?+j8d1TRHjnfj z<+KrhW5yGcF&++8*U}`=i93>)GXgf}8B>QOcuu10n&JP#nCawm1pCEb}E8qmQhZs z92Hj)jI$$T7v@KoK~39nzc{1c(U-wWFU1|_n=}B&NT75BkB!Gbnk*7$mXxTxZuU1$ z4qC0xPtR-^?Xn%(c%bk>VYbdrPxkBkA`bK}sXo$4C}Nlax-lJy_h9zMxZp8}vZe%r zTpQj@L5mg^Fe*#CBQ}A9EiaHpoKv@y%}*pI0@M2Cmg8kbG6Q2vnf!XKrx>)DV_KlI zhFxqWD5b+nD!~E$ofaZhHl9ZQYd{TJOr8%DRPww<{^P+p?}5 z&-<<1aBI63vJYrsTb7~WsHvW^EERzJBC$XHg4|f^gkO1`D|^eQwQ4(WYO7Z|cL=tX zw#9l%MOZ3dvi2WtvK$#p(Sc(#pCvR()5b(4d}m3Hf5Q%lM|kr3v>Bcxr!e?=6Yt#R zxG>AYMRz*OFGL8cF`*crt0lu$0G%K0s!vK_HT2ow`D;?D0bgN>LsNQTIiU27pJJ9J z48gGlmJb?WNCxKE?o3S`8oFJz^0tsmW)$MEA=7{@4ly`VyBjt1MR5S=FTxxI74WOF zm!hO~6_4U+G>F4inw{_A-QL%@R+a7kH%zqZ<`=W!a2);NP8Ya#>+TR_R(y=5TSdxla#-bj zH4_?E3Mf)cgsV{h(839qTe%ey7nuFhN9=xOgeUgHgTV(*CqUYjSb%K>-5GNMz;-2r zpYiTNY0*n|%LSbqLx8S59$7cC_wuoR=U}yW0k9f5 ztah+sua%m@rQNY~8!@8@csHrr(d)(-^_+24iOick1W+4K=3rbT46RJL;FY@zFfuy= zGy_;kXelMeeBpC?(g~R8>|Qj*BFc}M-(@L|NMZzuvwWq=13C}WQ9I{zmFqI1c}tRut?r=o6I7x znlY}JiqT%ua@O5(h0GHCBY;xptjm4PYFUG)U>Srh^EKu)QUPZ#?0P4UIXh|5`tfV8 zb*R5|JM@)2v1<8-=xX@?CX93!@U(=PY@?TWMsXL^Yj46|PWhX27>>l{GVFnJqQTS7 zDj)Z_=Dxy7K&Tkr*A$}EUMyx_bhr&uywoKHDRqt7Vu0{+r);BW@2^xL&b!kr0(?8w%$0V~W#Jr5 zxU~z%$(m&`Ht3YIQ1S@<-%e%VRiD2yY7o>+mzg*y$5$R~;HJ}#ez_V5cfc4ZM4!K= zn%if23^P!%nFm*frP8bA1)w#Iol!St5OyE<42vK@oeGvfKA^z~t9%Yq<^UEdrUT%h zkao!wSs0J8f3rOUHQ_XL;tteK4X7kk)6gSU99VbQzyvL@Nr_dgZ1AXqC)mX6G{&$? z9!)zHrc;5AGG5~Z#@TUt@YhB6lXkrRHOxoRc-$1{X|Ff7u=FZHFP56L(Q%b#gWM+v z4(zi;f#L<&)BPZY;^6=$8lma(DzST>C8fSswwa`+t$YfzD>vuFgz9u7FVC@VJXTlw zjb6OO&9X4vxqp}liGt>qUR{XtW<3^H(!>={X^uqpV zvv%y$q;2~1Ns2BjxTlAgPZ=PS?MA?;xN0s+0&|WcWr^2>S+DPwQcq1Wn41lyQJQZ~ zXWdIbO^OgtlFe;)_Yk#Gqbqw&+=?DT>Z;j#b-hPUD6HVA7<}5Z3Kw8o+g6kwjSvej zWt80vPuy(26kdCz-tzTGrQ$ciXnjS>@*tZkcNvQw(tg+6Oig54l?u{BE+{Pg8Y3&{ zYpim`FX0*(WDr?wYuj9bT)J}0Uu2drkmXbYgr6-jo=jFk4ki;@GO`qtI%(3QGNIjB zGLT;mV7bQnz%7nqNy;^Ps3W35*H_ahC6AJ&RDnS>2B4Pq=hSj~^VYU?51E4hz?9~^ zgio14#IFnwkn#0M6F`n>`&F|26Xwj(3%t`c*t9Zbb5-a>yeeKLr*}C;Lt6@6OyO(TS>MjX%Y@vlkxV}?|#dF zG^X9lgI0Sl?T3@`o*LIJ_OZXe|M~s<0)PMX`2+ghZ}a{B{=vQb`}h7N4%!b6_V*v$ ze*gvc4<57+9{f)1-y#gPe={^N0hHJAWNA4lHXJT_PlMSP`u8{T2V73UGL<_)8vj5% zo@Viw_wpnA0k}Cw#>+U)Gvp0t1zWx#?fLBSci%n!;+rQ}z>f2P=VyE|%t-BsK!$gE z4H@O(h4P-ztMyP0vleNm-~f#MgqG*QrNRdOjgm5pmiRi&L^Ka^3`UGjFbL& zHZUkQ=!^$;u*|`8+eS3~+pnOTAG`IYD99Xx#4;Qrkfoiay9-ZBiW2L;cb zfBX0=&)_Z8ILyUaExNyKme}1@-UH0XHb4eNMZ+_|V;W((P@piX??ZiWjr{nCEBg!g zmQ|Jk7lN{=kT*V0QWYmPIYH)q9=%a7OKB)>p{{O-8_=ao?G4f{EmCwiXG9n97nLW7 zEG=9|_?I5_F)Lgtz;e33i_sN8bS`umgbpVw+9R65sDmZHW9vE>=BU16dB@!!FT z3rQJ8^9a;UJdAne101>wv>H&rajl}4&gEdjMUN_?Mu37Rr`0l){r*4xdrLemXf=dh z%Clm)!!TKJ`~TnnBcTJGR=R*!x|n_lOs=0o`&JyPKy{y_v{VFFs1GB*!s9Fh0L4{k z)IrM*hH;l2mqpKK=**URK$=@#(wE3nCAWG)1u24|NhmtUt5gcsdRf>0%MClg(lzs6 zyUb!B-_4ytW5q0}OG*8rt1O=-+DoR1ws)TJf>SqH_@UyPezlp>++mll8J#ncEbFaO z<>+Wtm2epjiR?b?*~qOD(L39efbf=7^G>;}19zhiJ#Delmt;WVrs*3C*a)p~2S zB`2vskI9ey(wyaD0QEwtB+p)^n3|LVIfqq?n|aJ?&(!nuQJvB3n)Q_`bKBBtwR~5r zh&(JeGXSW`&b(Te(@~{)b%p8FR^?UlmG$|01Ep?j2TN~nb->SfkBXgRThh@s63RBf z5~KR&X0@&IPtN`lC7kf|R-Ana&L_BAU}e-hM5k^WtYFt@red^nLlRrnnd_VX_KtX2 z(`~p_Y_!*DWCe|u;N^>_-+r|eD;^hQwG*-unQMC}A1N;1FSCC6{MmQE3Q=z83I0nG z>2J@Ue)}sBsorVcAo}#1L-xz>AAkG8!M1$+1N3FQr&}Wec*@^p>17PFI8Dz@^fnL0 zH;;dO(GdqNIcNXS3XoFs205j8btu}_%h`;a)DgYsr}7cz0ne~wej1F#tYPx@N{o(IRQHrL^?eq4B7})Z0eavI3i8hpnYQ-?V&eF*jaWV+LfC@OBV?TC` zwdCZJkN-uha8q)Gr-Xb#3+OQh#lL95ul1Bih0p2AE+0ihE*NcU(cX+Dq7dA9vQGy56 z;U*Aai%}6O;N+Kh;K>p&6^h_O0X38j&=_2jHRPy{?Ll>UPVsd&p&$J>P>JGfpSl<-VoMcQAF3hz%J*`yhI$oRp@Pl0pqT*QlAb@ZlF?wy%e zz0-FNL)6bZI=JbZ8yh8l@^xkPfKxuU55G>o=pemT8>9qD{A>6jE6+hA1|UbYw{K}d zvgYUWIVoe-#zY#chz$Et8GQf}sq3I&u^VoJ$B%)`RqiG+%k}jTZUb(*AzHka8wBvY z)o2ABI-H3PaLMo^a=bBBeAb|LPOKfN(7e2YKPtZi6|T+kd|>0e!h_|m5wdfh3$L+x z`dG}h5WBmwpWX~~BQ8FL^fd)qj>p3W9=RQicS=2E(8C;>Ha);gs|VS^*xLb}Me_)k zpYlk4a|OS;V7i3b#G=$wQ`L`h0&Vvp)ju>v#lUv%EKQE_zWv#D)2ca%!MHe7SDMZ*q`s#t75<(#@zNSvSK~jZ%Cq;H9fF zNkPr$q+A2Gps0+c*^VW7SdKeG!J?}b zSpDJe2CqN-y;WwPyz@Pc36I?ThdM>k=>{sBiPvos3uM)g3S~jTfPI#Rp;K?a* z6KLv_$TmqMTb0ZAZi!}_FI4+;@7{6AdX0?3n=PuYN=96fbMTST_;wNkKheCF=IGXZ zR5V{Z+42TC#{XorqZ!yGUU{9n{b7juZpyfv{V3PZU2vDBFf7M`Nx%H(#={CU{PUn- zSq^Vq=4X2iCAW@xx`j;y?`bxA|N4ekac>WiH`zwOQq%1h_>ZVnI4bz zb=_ilO|1^DVgU6X&voKHqWokv!8N&ezhE*wlB%&BjATmsXxC?>QBvtCbuB2 zW&<4qbd5`=)GcHLwQEv>R`zOj_S;Ji`m`YS(JqL!D|s0oR&G9MwnqD1(ly>)L_Z1C zzluOPnHwKcpl&;#VLB^Y30h zeQs}1ubfKa=IhvrIq6i-QFJ1Iq?Tpm8=Qmij1+fEc>TOGEsu;oR9@;i)(P92K0)d^0+)m`u%JRUR6iY22{BV}QSYJ*2da zRl-#@`aDEe=MXST>69uHCr!15NLP+&smn{{!~)ZLrjVgH30K?<=T^^4^2|Fm`pMLm zBH^2{tocZD_G%ukooy=fVGSqOPIkX8Pk*G`Xdg260a&tK;>nkRPL^nBMOT`J}9F;)WzgOhwpx9@ukBV`k0bq>jV>hTnSku zM2{I5xb-XrRgKrm-@`V1g)C*52Ad>Ca{0DmV@vzZE?Q!;mAvpnOSRzPh?ixCXd8|o zyLg$x@>$BZ*h@k*1?RPt8OLus8{*zX$GMZg1%s7Zv!)fWrmozClS}SI3AWXG)UEJ| zyH|2|+kA^jKlS+y-#mS>^en@A!`%5GRdDyNb0oI?i^mWn)5Lf%??TWAA_vZQ(Dk?0 zbpjcEX}xGvYg5@Mgb7T2q0#=9m@$3TL75x)Er^PZycW+kh%$mIe#^&+sO7#B+Qpim zpILoiWOgLd%P7MWppU|b=7X5banD*Mahr;385~ZPx4_U?emU# zw9GB7$mV8FsZv?D;*yR{(B|D8(mS#-tgJ;<&tf;=o%(I2nO6)K1gNS>W771 zSy^k>)5)o|@={~b>oXwM@-9z;hWw7Wt_Nz0c#cko$5S>y(5G3{j|TLC$l@YQj%X|#(SSmJXr;_FHWM3m^*qA! zeuEhL!vw!p1j7PgZG*Ai@>W|nps}+3?e07AOp&*tGu}C9Vxwb?kV%z%pA^X_MN*?k z+;|bWoibX4x9A}^*~ITh37G78lMMJIEM^&q8w`r7L)oWR*>MzJMx~-Ux1kh$dHMYl z?|1f~wQA(0KIo#$zeBLa6B|P4e6b#TQwa^e^Ns6}aPY6AE*W%YYukBoev-T_U%rVSzEWI9E;2_46VN z`6S3d@la2~y~`UVgOT2?Nw;%(mN|AW%O98YAErB2(iz{%o@E$ZKb63an3 z_QdLt+_|=aNNmv_c+&BiXy(VmZGXgXJO+j_<^^X zG2R+hY(jr!0?*5xuUL=1i4#i*TIIybLL1tiGJnr`!y7q@!ow}R7X{ueHA!uY4Y3F~ zQcr^th7}$QS&As505Im(1~z9=wmAz;amB<%bD`U|xw!1#{XK9_y6}5=@0Yhroh|>a zWUVjt(MrP)Hwx-}l7|l?4}W*O6tcP8HSMQ3{J2=SJZDY9H35-Y<9z*?x!%~fbZ)-2 zX;}rm5qD^+EDMbDF$a9YL225qY0Wc>+gs=SyMm-47`!$OXtv<6G#Sk$*XsKxkH32I zec88)lFPN-J}ApJx;Ey+98Fw&Uf9nlw605Q!(JE3FXCZgm4Tl%a|d`36%SF3;>O;g z2DaiKevl!eqX`TmdXbohSvUbBJ&UiSfdJ$EOzu!q0|jWoQ^T5PETs}Z-$&sf%7P~> ze5N?EhR0*#mY%c}>MYrnoMJGAWjn{R$}O1AE+eferF2pRR>L5RPhj6+vw^#@!SqzG z+;tgz!%771L0i-Pd>@`bC=IiW3w?MIPwVq{wxN zh&RTdlZVS=OuTQ?qB~4yCT1Zw`Vnse!SP$T=qcuYM?<;_(r))Q#-# z_r+-MZh7CH&HITtbw`*8P-f6FPpZX%TVzew6y}G%1kV>QAHS>w*1_h>)(@*wX-UUB zR$cmrc7)ahmniI~WQbTbtER|wW~w4pDS=48rO_{(M(Cp9l=YZmG~kLQW}v>YEvDfJ z3?3R4yX@mY$l8V*w^d`hy(qvG30~Ni8<(%K-Be>QS_a*g{l=_lkjuq8$GYAvm~eHx z>QzsEV@_?t&mArEK8!i;safi&qR(<=&js^lzSCf%F0VD}@*Tf|L(a4s%$urPV3spt z(91Zwin22i=i&^<%lBCEth5{1l(w6cPjVR1+A}mVy*$Q2o&R7ELI`8N*V@qP4~y#O zxveCLb5~h}Qd872J$-F%$8^Krg(K9+_35xf}?vb37-=WU*=tz0wa zb2(wdl26?E7noZA5s`xo0p#XOy2LGd|fvGvS?^-@LP|YB$a3rEQzk5ArLug0U^g* zW1@ixPOtG_oDQj!dELJVlk=$jeuX&;gQ*y^HKTc#9F(#d`=N%a=}3@;0;oTPrV~8* z3T)P4*pCj^G-bJu+9>2O_z&BV<shH3DefiXCA{-3lL#)@r=cc_3+)Yj+0WcfX>{qQJ znC76PxU4REmBpB#qsuZ7x^r*8Bi*GOgA)Y)+Tvoy49qxup=T{(&SOc(TW~9gI?AiS zo25>LJB{GtBZeZ7CZ&ay-@H#D)x@RUs$w?hq%u+$PUpl!Bke5Y7wK#~ppW39{iQyA zI|5>l$9O^#QdfjMAW|sh>k-lWDgr1lt?e&gx@MZxK_eGBoMf0M@kOa?0v(aQPWP%e z9fBFI4ncqYax>=r2we~*3W1h|6*gCG^bc=T3V;$2$L!ImuyguuHQQmO=-P5nK)QW3!%)Dg0R6&DWp zysBxK=Q3;gj&2t_ZdggEk$3;5SJok$cbe^J#&@YNn|z> zR;O~;N}0Mf0~_q>AKAI`XjjmlR}E5g^lZ_*BD-2z(YTxE$CjkPmAI-?u9Dliv19%P zg;yzItxEDN!}aXLgQ>Fe zgO<=`D^eo78z)8S383eGLk~vuW%sjuM*C9G%9di|TJQX<&!gj}%11TJf%Q2d;Q08V z>A|(lSx8oy=SsJES^6Wi#4SCz)G~3(-R9XzGc69w%ndjFQ*$NCg|+eRYRB35=8DR4 zSyB7)YI&c9=&Dhz`%Y3+FCdnwA|F=d!Uwb#71JGY^UdYLBLp{c1KyWtd`uSqCvo~D zPMeF9>u&HvpU3g!`|qDu9F9run$1y`rP(Gfh^av4EKK58AivOTCAp+er+!*Sv{k6F z+~z0HD<*$E?6&jPuACj^cxQ1AyEm znb__zyI5AK>9>+fv>+xg{Ti7WJJNKuGqL-s{R^Pjm=;tkU3O(ElhdOr@0=S+?^hYf zQW4yMZ9YQlS;Mw&RL{?kFEu}|V8&7y&^b<2aR+mjLoIGJc+x^OfvL}HLiG+u0AZ0iAOu%OkFDS)4cx`;!oDEJUuI%azOt zG1Dv>M8i0V=f3Q>TdKS;-RSGii>0RS`H9m3$^WTncQ0SEZ|8H7YK|*YZ?EX~P6nBU(c2+Q-Mb zBGX8H{{~eWu~YdoF7!ryv&B6=mtWCYxm&;c^!LyGM+YPCULLgCdlz9o0`}f(bx|RK za?5Y2kNy4q&+p$C`1_~NAJFf9oA2qb{otNBXg|PWf4bkkC-x6M-@o7fo!Gyn{+IrN z`x<5d%IkQtv>X&04wt;=p$Pr^TlxE6{*V9lcmMP6e)lZwi{~%If2w&JpZ)HCga6v_ z-va)_`~TOe`M=jS`S|6_@8u=d_`l)5|57UQKbhzMCvY3;^KsOA8O@6)Nk1Kcf`gZ{ zVz~R~!-ISG+XsL8uYbOOE5rTt=l*%*|CXhHmHfBw|LMW!CHa5w`TcvJ6bJj@N@ZYMw}FORSg_MO0ed`;PQ}R)m>CaG1v~`fHv|_b zr*Al>(@C16g(f=r1(@z^jO0{#mW{;`{PU38x=7P=uv3oS%%W`Z5L?Rec%E^dii@I{ z=AFI0t9TT*Bqz7h?0oO9REMjF{ZV+X>(jHVi?9H9%6>FR`{LxgEJ8E(?UyN-cGQkjZUfi?IW#85dHMXS=N(!*f3W~uPFi2b zRN-*7hm63~k%Mzei;cNd>-3(Wc} zW?3RW6Wh~S@uJASNyPTuyUhABOnvBWBL$Bp!`H|3h;CJJcz_Pd$u^6~c5_=YJ6th~ z!v%0F{0mG9|4NR8E8;o$B{sv~s{#Bw#tOtR>KFJ1>jBx}2kDEYq5;2-hTEqKmh*9% z=j1P)Xt!T%cizl^WrgoACJeNBIRhRWO2w&I_XP$IRp4dN|Iy|JY=v)cO~QGPP=(Oi>J_Xaw@2Cq&;$qP-@HtV-m*69{O*1 zA&y7_cJm0AI|}IcJSrY%=b-xD%+dk|ouruY2M8H7aj?jT$anA)&G9Hl9McQ(;7-B$ z1sMy+Zhw7{8^HEMd&IMZhJgv!NK66r9DhHc}8{K(r`&8LF&2X{x}LV z)WfV-L=Wf+u)%mR=$7LKs6J>w+PM-iwvYN{!vQvt@T=>v@^pa-)~ufsIMAjn_- z`X#CX42(^t0C;u8vcJ74v$_W-s$r+|S(Xv&;FOd1)2Y*PJej5$(CE!99OKri!70pW zQ1B$o#j{hFGnnO0?!MiH+3n6LV_Bni3Ti0IE+g+a?}$khf_j}Lz!uOUa8kaQ^wKew zPOAf9uu3D0iamN60t4<%v-Dh#k!Cab#X{D2Pm;?xOB4LGQA_gd9{hd>wY~+8C^vi( zpYF{PxDdPldGc*~`ecsl)p(Aq8Xh&Cq}cfkTg}xZk@GwbEr@ZLoX>zVz%B?ZH+Xj< z?iMbeV%&ia%%aU~dK453rHxI1%fbkGfKo+V!cZ_T-eLSVs!gA8Jruaa9VyRTC%*^! z*#tc0{t3BEpS-!A+F75jC6V|&g~CYMIOLOpfS@!?qT(VQV5$JC9N=5R3rJj?i9uL| z6dOWaGsgA!K?J`Uofzw~OPmZ-94RUQrlRVZ3@99IZp9$4F4CMrlT#QNl2=F4szTEt z5RPETuHI5#?4G1asz2imVgdS(EElJZ5eNsuhi$o-Nz!Zr(s*5#@F}R#!X1y>FY*Y* z$}s;vtn_$;`c0ByG@s(IHzwHzDlPa+o`^D|iJQ>kJFbmZ*P`9;(v2yZsdG@8g392o)Z~j5Xi~df#q9aW04KEjXym=|+$EpP8JZ%3 z>+5Zk44t97cgFkHK&vHmsy1>)2G5cKuxXlbT20!gd5+KG2Fc}hIFdm;QD)o zpAXNVGg>m5@`}+E&@IcuOyNrX?+GnKeDT>|pFexD_f6c(!fdhkR~dN%Gko{X-Z<{< z-Pr>O_pqHkg8U7Ex?&V}?6QY|D*nX7E^_*3L(l_%{39#hq1gGie8+kk&Eosm7~h`xoRz3NlQA>rb`L zCHC_N9!?Qwk}nnCVz9xDHPkQ>781Hplk;AXN%5s(U0@hu<*R5X!xIph+pv#i+_nyH z!T(Vb^6vQzY&<5B!mi|FHdj+bMZd);SIxR;AMZZ2H6F}b z2H&yOVeA@_J}am=@EM2njtCh5H2vgZ%N=vO&1)y zS_(E7At1+P5cu5+0POxKUQz0gR2Rto&!U)2#nGb1B9Sah!ek-`2j6pL=*@t(jBMiRQEl`o}r^}z?L~gRvzPL zI<{Z^^pzxsvO?rn+o2M#XDDx3r(nDIv%6Dy%0yq7^4fqL@MD9AO7?e{@cV^5j;c$53HHGK!B$4 z)xbw#IpFFj0O?<{$m(a5)1h=XaT+vgfzH-Ae(nTS;y_hX5RA+A$5hRZKU2hor^tY{ zSwl)&O9~p02Nkywfk`-h)-^N9@zIf&L-h?#0_1$LHKW2jI0}sG9^uVHGlP&K(?dX8 zxdl^CZ=nM24K*q`D?0-Np9bYk+4DW{5k}1MUtWY6>Rz-}g)GL#Iove6IAJ#GtbPh1 z43l)1@Vtuz-sJ=+WW(-8Vv03_?y%Vf1ei)spSN)4#Nx!h)aEM;aK^x}*hvl(;Ssq@ zSop7$w$r-!YQ~>diL8e5VgQpgR;nxfG6l4GYnW#jUyjjt?q0xSz|D%*5ISFbGMKDf zwQqs;-66$~rSArJ$lK^tJ{(8MIVQe|vpjlprYKQ>=hH-r;oJZiC^fc95kQGk;W|#+ zmK8M1VKVE;Wd(5r-8_`~8w^iU6V*4&r_ns>HJIAlc zQbHZV#t(vVrw`LdL%bES=!=K&FBmBLE!r9V1{Juv0OMKw%(?q(Ia1VQFRszhn(zmc>|@;bw&}TMj5to2e-AGsZP4c!UO$K;!9jNY2si``NMR;S&_Jl zN)sR6g)7paP^zK$NQGOGKdc-8*#6}k=p!5MgO}?KLp~}BDBO#=9q=T-QXqr~demXvtG4o9+ zW+h^1iaFUB^iBlQouKEuzzbezIVYouA{r(OyybN}{C8doeF+1XvO1a&fHjH@*|JKD425Hd+)2z z`9E*{yt{?p2`%CY0I^7C;wnstfYT@&rr88D6rMhp8AYf|C>{nXdRlP2io#j&U@+_B zrzgiLX>4476hYKFZ;^F~njYSTI6-3Hjh6Tk}VxT@4I8iod?%#n&;;(BR{TW_W19pfPxNq8B?V_cwvsWrv<;}WBI z+%KkMEHUw0;_1*r5WrYk$aF<+4w3$Wu?2oTNr(V);xRI zLY2ni;0niTHFT9RcLV9;bcR7z5dA%AYQzcCiclfRAp$TsP-F2^xupu;VZ=6{or595 z35&=&kCP-_01J*6-=xX;e?-~hg&ZC4sAyU;13aVIk?3!rY_zsss07BN+6+d32mg!z zz$odq+JA;-y71^}SLVhHx^l_7t0>ZHf35hT)&8#!w{~gOxSIdz&HsP;{JZfiZ(ZC{ z3h{qm*7p<&v8@QABm`ls0JF3Eq)TugW z0x<)Cz`PFQmDyrotdQ--dHL)ZC1Cd9mg+6FmMk!O=qsrNzVI zS)1>EF|7nvGfhP!s0}Sz1hbl(sGYXbLE-yDI?IFi$(OsZDQudd4;&oxA=KMaanM8X zeHa@vI+oNX1Uw2XO1Ra;rPJ$UjJqVn40gW?dbulpCXU`dq<&`NjJiF8J7CzKcbPKW z!P?YGnE4e017+0Z&$zBDuR9&`n8Yu5WGhQaK#RlZ`&wMwWZX5@BRcnJC3Fdp-IcBG~x zKk~I?NWOVL94R~XvLwIz%m$*$l>Gdbxv~P4#g+=Hci>BIqRN=6X~mk7xE_^f%6fRy zgR0t6msXD1Y^TD{HUwtOP;gaAyNe~f?_y$I%}bpBO}HWBk3&D-V?&bd=~8k%UB4fu z=N`R0Pp>|+AgFRYJ-%gzFGFPUyM*W+*qvIaayvcNYM9CCSHltn4-;2WR9EP-!m(D5 z%URnk=rmc&*v^>Ox}cZ`1hCw<){M##-8A6QwDn(Y0sUTzh0=H0_CZPn#V&PDBhR0{hUx zQiuq5!r5$cd`9!q zf-j%uFZk|ddLw@!(|3cx!C9-n9znN38U2?euxvf`?(O^!6A%HQ4FSXZA|Y3by#lz z%09lQoK*g(N0mSNK~_MyT2dgId({N5Rr*>uq><@4~TPnbqqyV;SCKZST|@54NN z;5}V957+4TAt>?L0X(Ufl3py|(&!~74s1I!+N|1rkD{&bP(1Sn)OvxZ8{~j%BO8rn z>akcQ3!0!1JnHaBQ^rMK9nbuU8xSSErCpMp0QKm;k?_~G90sCrLy(4huz;;?Hj zP`YmKB52fb>Y6ta!N^-V`t{C!KIS+RSLT6^FrwS1?Oc!lOpoi{54=Ix;W3!X5G1-i zmqF@Ep)u>Dv5Xy2^n{}GJzq(4ws*My+v)N96NtJ)8f|$$Q$ax?#r5_5j)g?k6PWDg{X6;rtK@7Dl#UE-Z}BnNn6rRX z#HxFbUv7k=x?^*aWJi@$b|LoC)l>B!`lG>y(s#b9;8MaBQ$Hg%(g!1vAQtfAeR+1{ zjmq(5P7^g8RQZIDCkh_Zr9>ke-{xAhfYzXtR-BaAt`rMZ)ag*V-&wWfQeughWGwdG z>Cjm~0)Mn_DFTmaT6q^nD(*XEDp@VWOMPhh&#}Db*>^ePR z?Itaf*I%7#ahVU=)q8`3ORXC}kRYlYuI@!(#W!)_Ntc{8DWg)3lbo9BJ}c~1Z=2S3 ztDd)6n#WVfyQl+2gmG{V0S_y!9h_4Q{{h8V+YY~#fn=psZJzb>AvO9{)~^(;tf|P@ zoLt$2U#W;@bZ;ICyXb!x`Gok!@ug4cEgrHEB4Q;XW$@QwIzXURIl`X6}@jS{T*@k@BVzY65rqGZ&puedGzvTG{dUrx< zm#?r=Dp+t^8voG*H;QjcIv%uy7I}cy5&bz*@SB4aESP2RAI-y;;R6BAuayiTp>&8> z(>4JGz6eN5<1e_DJWySAEdgtbUDL3;&c+-btXL`$4JFEVh%s@Kg3c|J_eA}VShLU2 zR~0Xj+zx{kRy;-Klzx?;0Gn>eaUt~2`L$$^bhPo8^*D~htyP+{Hd2)&^Q$+s3V zvgaO&cS_{gV7cDQLR)^W$=i1k#jVGkO7lq$x?^xn;f8!uV|Xp;VN$teL!-wpmhj3; zl*twfOoI#u8VK9r%a@pGbxOT~XdD6}KV!ElJGnTG;>|}|&0~=GGwQ+B<69^kKwLHS zXvrJC^16hLS$^bnMu#?~mS|AD_~e5K|6~Vr3K)nmM3hK)xM*90_6m zP86!I4ZF}dSP@E>(vafPHdcZmTx_}0@S#4Lt*>D7sf8XpbZG9wB(_}k!732^d6ZF} zTdQ$!mvcd+5K@mwK2Px!G1)c;j`qpP!T#Ib^ZkGB(GoM84pPfWOZljs)^^fL;*KE> zgFJ1-ogLL6*?ncpKpldFr9XR9+aU))Yi%cFD}V0^7HYw{4W}w00**=U)GO-5>^IX8 z{NBs)6WJp5umqx2THZ9ijl%&C0iIgPM#ZM>sF^K*6lxZ1t*yBxCZB*SkZ3*h|7W0Q z2R{L`3&Ps{E1Q6)ud|-!Qn)+UhWs%pe5@cL9N0t3gpYm`+}%#R6HIKBSYN$FZuu#O zh}Cwwuh#!|LDN5V%D;)#gN_a0#a*zojZ$tCNd^jqR$*W>!o1w2jCfOXhzT>`oWJng zx$O!>XhpNJcR(Y0oX*B0+VTnm6CE=6wuNEHN6Ia@2MOH!1OaX5`D^jfj8_Ccl$4K2 zyxnHD+~>Gbqz#B+N8a;7 z3+fg@A)-YD8AIDtYT-X4vS3NHsK;v~mPkarWnn<)OB~xy ziKgp2vEL{|_1fl%lz*Q>kdFa*I$QqHI^CjWL@=c5^hRLPxV?80!?3%$cMdn1k-zD?`(^#*{tC z1^Z~D@n}(NwPyb2rBbqwE`=?gxMXe=`(3#;l0wE6;`_(8zx=rkIt*jn9}pKtGh1Y1 z=bwzzq#!}Gfh>jf;^i+^oqc|?@fJIz>1^y=(jt)lbgRpei($nhW|U+93QSjGCRHcx zzvmaO3o1p>eO2egWK*a1fp)j{7tAWVt##sQJy1P067SucGvIc{O`x*N;nF(lwzHyV zB9};{eX&1yg6#DK7w(m+I4F(7nOFSq>jHhh+zXwT&u~{YD|9TBfz3rZ#RPAQVjW&l z4D$b#rfa^yg3ZhM)F2kShq=6PBFS>dBwqWaO>2d-RI{RF{k-U%-GlSJ(<5bbEFbLp z%zg+dVfBn!0JJpXfbToWa^+`j9M2bR#+Do5xT5O8gRcvD-g=nJeJVUnL^}yuU}^97 z1jVRElH<-|pCl-# z<)xy=RN0v0q?TorZZnUTu-kk{DS02>Ea2ql(ys>1C$`@6uz*v&f@!7xVR4&JaFcYQ z@wjYI-15}k#&(0~<#9zG@(x>BzSK&tdV?!-m*vyIsR@?V6>*6;qPpND_VfhzZW3(l zlkjwaRp;y~zxQOarO4H3klE?Wk+=F|mLqWiv)C`is*QjhZ`}i|F-qQS0Ef>a`_yrPUjti-6~l+o)J-{Y%{18b3Z&<8OhsQEB&C%vy!% z5?>35byzF=U#t8qTp@SYPG)hv1uOf1H>`qM161K{kqZ0LK=tYQI29uJt)Y~2vLJ=y z&QGuuMEyJ$5h@up0aRMj!zZ_M13bz9IduB@d*Fn3iA}BNV{<*f1x!DSrEqD_u`G@j zP-!vcdRh;^o`obIAZ=S~2}$^WKS&a_CP01X9FZTgGNYlOZt#RJ2yen%%6p%m%k55^7bGp^?You=QkngWw9J2DS<+gakL0Y z#gyx5JrZ4j0`yn%1 'a = "%identity" - let const c = (); fun _ -> c - (* TODO: include fun x y -> f (g x y)? include flip (%)? *) - let (%) f g = (); fun x -> f (g x) - let flip f = (); fun x y -> f y x - let fix (f : ('a -> 'b) -> ('a -> 'b)) : 'a -> 'b = let rec x y = f x y in x - - (* Haskell's `(op rightval)` = `flip (op) rightval` *) - (* Haskell's `f $ xxx $ yyy` == `f @@ xxx @@ yyy` which is properly right-associative. - If you `let ($$) = (@@)`, then `f $$ xxx $$ yyy` will be `f (xxx) (yyy)`. *) - - (* `non p` == `not % p` *) - let non f = (); fun x -> not (f x) - let non2 f = (); fun x y -> not (f x y) - - let pair x y = (x, y) - let swap (x, y) = (y, x) - let curry f = (); fun x y -> f (x, y) - let uncurry f = (); fun (x, y) -> f x y - let mapfst f (x, y) = (f x, y) - let mapsnd f (x, y) = (x, f y) - - let even x = x land 1 = 0 - let odd x = x land 1 = 1 - let sign x = if x < 0 then -1 else if x > 0 then 1 else 0 - exception Overflow - let pred x = if x < 0 then invalid_arg "pred" else if x > 0 then x - 1 else raise Overflow - let pred' x = if x < 0 then invalid_arg "pred'" else if x > 0 then x - 1 else 0 - let sub x y = if x < 0 || y < 0 then invalid_arg "sub" else if x >= y then x - y else raise Overflow - let sub' x y = if x < 0 || y < 0 then invalid_arg "sub'" else if x >= y then x - y else 0 - let mid x y = x land y + ((x lxor y) asr 1) - let pow (x : int) (n : int) : int = - let rec aux x n = - if n = 1 then x - else - let y = aux x (n asr 1) in - y * y * (if n land 1 = 0 then 1 else x) in - if n < 0 then invalid_arg "pow" - else if n = 0 then 1 - else aux x n - - let undefined () = failwith "undefined" - - let finally handler f x = - let res = (try f x with e -> handler(); raise e) in - handler(); res - - (* Haskell's `last $ take n $ iterate s z`, might also call `ntimes` *) - let rec iterate (n : int) s z = - if n <= 0 then z - else iterate (n - 1) s (s z) - - (* Haskell's `head $ dropWhile p $ iterate s z`; or `until (not.p) s z` *) - let rec iter_while p s z = - if p z then iter_while p s (s z) else z - - (* let forever f x = while true do f x done *) - let rec forever f x = ignore(f x); forever f x - - module Option : sig - val some : 'a -> 'a option - val test : ('a -> bool) -> 'a -> 'a option - val is_some : 'a option -> bool - val is_none : 'a option -> bool - val unsome : exn -> 'a option -> 'a (* Haskell's `fromJust` *) - val optcatch : ('a -> 'b) -> 'a -> 'b option - val string_of_option : ('a -> string) -> 'a option -> string - val list_of_option : 'a option -> 'a list (* Haskell's `maybeToList` *) - (* List.opthead is Haskell's `listToMaybe` *) - val default : 'a -> 'a option -> 'a (* Haskell's `fromMaybe` *) - val mapdefault : 'b -> ('a -> 'b) -> 'a option -> 'b (* Haskell's `maybe` *) - (* List.optmap is Haskell's `mapMaybe` *) - val length : 'a option -> int - val mem : ?eq:('a -> 'a -> bool) -> 'a -> 'a option -> bool - val map : ('a -> 'b) -> 'a option -> 'b option - val map2 : ('a -> 'b -> 'c) -> 'a option -> 'b option -> 'c option - val filter : ('a -> bool) -> 'a option -> 'a option - end = struct - let some x = Some x - let test p x = if p x then Some x else None - let is_some = function Some _ -> true | _ -> false - let is_none = function None -> true | _ -> false - let unsome exn = function Some a -> a | None -> raise exn - let optcatch f a = try Some (f a) with _ -> None - let string_of_option f = function Some a -> "Some " ^ f a | None -> "None" - let list_of_option = function Some a -> [a] | None -> [] - let default def = function Some a -> a | None -> def - let mapdefault def f = function Some a -> f a | None -> def - let length = function Some _ -> 1 | None -> 0 - let mem ?(eq=(=)) sought = function Some y -> eq y sought | None -> false - let map f = function Some a -> Some (f a) | None -> None - let map2 f u v = match u,v with Some x,Some y -> Some (f x y) | _ -> None - let filter p = function Some a as orig when p a -> orig | _ -> None - end - - let some = Option.some - let is_some = Option.is_some - let is_none = Option.is_none - let unsome = Option.unsome - let string_of_option = Option.string_of_option - let list_of_option = Option.list_of_option - - module List : sig - (* - Some functions in this module accept labels: ~short, ~onto:_, ~rev, ~cmp:_, ~eq:_, ~missing:_, ~step:_, ~many, ~len:_. - ~short (map2, zip, iter2, fold_left2, fold_right2) means you don't require the lists to be the same length. (NOT provided for for_all2, exists2) - ~onto:[] is for efficiency (rev, map, mapi, map2, zip, unmap2, unzip, optmap, optmapi, catmap, catmapi, filter, unfold, mapz). - ~rev sometimes (map, optmap, catmap, map2, zip, unmap2, unzip, filter, unfold, mapz) means you don't require the output to correspond to input order, and thus can get more efficient implementation. - For sort and is_sorted, ~rev reverses the direction of ~cmp (first match will still come first/be retained if not ~many). - ~rev other times (max/minimum, max/minby, take_while, drop_while, split_while, find[x], optfind, index, remove, delete, pick[x], assoc/assq, [opt]modify_assoc/assq, remove_assoc/assq) means find last match rather than first. - Find/remove from end: find[x]/optfind/index ~rev, remove/delete ~rev, pick[x] ~rev; also assoc/assq, [opt]modify_assoc/assq, remove_assoc/assq. - Find/remove all: filter[x]/indices, remove/delete ~many, partition[x]. (`remove ~many` is `filter (non p)`); also remove_assoc/assq ~many and diff ~many. - These have a default ~cmp: max/minimum, max/minby, lexcmp, sort, is_sorted, insert, merge (the latter two assume ordered lists). Other times (mem, index, delete, [is_]unique, is_subset, diff, union, intersect) ~cmp:_ asserts the list is ordered, and ignores any ~eq specification. - Functions seeking a specific member/key may specify the ~eq:(=) function (mem, index, delete, indices, assoc, mem_assoc, [opt]modify_assoc, remove_assoc). - Other functions using ~eq: group, [is_]unique, is_eqset, is_subset/list, diff, union, intersect, histogram. - See also memq, indexq, deleteq, indicesq, assq, mem_assq, [opt]modify_assq, remove_assq. - Additionally, modify_assoc/assq accepts an optional ~missing:(fun k -> v) alongside its (fun k v -> v); else it raises Not_found. pairwise accepts optional ~missing:'a to supply a snd for the last element. - Additionally, range and range_until accept ~step, and range's second argument can be tagged ~len. - Additionally, insert and sort accept an optional ~many to insert/keep items even if they cmp 0 to existing members. is_sorted ~many interprets "sorted" to permit duplicates; and is_subset ~many permits multiplicity of subset to > super. See also remove/delete ~many and remove_assoc/assq ~many and diff ~many. - sublists and permutations accept optional ~len, and can also be invoked as ~len:_ ~many to mean with replacement. - - Functions in this module may raise: - * Invalid_argument for indices < 0, or length < 0 for make, or ~step:0 for range/_until - * Invalid argument when specifying both ~cmp and ~rev to index, delete; or both ~many and ~rev to remove, delete. - * Invalid_argument when is_subset without ~cmp or ~many; or when sublists/permutations ~many without ~len - * Not_found - * Short_list, e.g. head []; map2 f [] [...] without ~short; indices >= length - Primed versions of tail, init, take, drop, split: silently accommodate short lists. (Compare pred', sub'.) - *) - - (* TODO: cycle n xs *) - (* IFFY names: unmap2, mapz, min/maxby, chunk[']/chunk_int/chunk_range, is_eqset, indexq/indicesq/deleteq *) - - val short : unit - val many : unit - exception Short_list - val is_null : 'a list -> bool - val length : 'a list -> int - val count : ('a -> bool) -> 'a list -> int - val cons : 'a -> 'a list -> 'a list - val snoc : 'a list -> 'a -> 'a list - val singleton : 'a -> 'a list - val make : int -> 'a -> 'a list (* Haskell's `replicate` *) - val head : 'a list -> 'a - val opthead : 'a list -> 'a option - val tail : 'a list -> 'a list - val tail' : 'a list -> 'a list - val uncons : 'a list -> 'a * 'a list - val last : 'a list -> 'a - val init : 'a list -> 'a list - val init' : 'a list -> 'a list - val append : 'a list -> 'a list -> 'a list - val concat : 'a list list -> 'a list - val rev : ?onto:'a list -> 'a list -> 'a list (* Haskell's `reverse` *) - val mem : 'a -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> 'a list -> bool (* Haskell's `elem` *) - val map : ('a -> 'b) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list - val map2 : ('a -> 'b -> 'c) -> ?rev:'d -> ?onto:'c list -> ?short:'e -> 'a list -> 'b list -> 'c list (* Haskell's `zipWith` *) - val unmap2 : ('c -> 'a * 'b) -> ?rev:'d -> ?onto:'a list * 'b list -> 'c list -> 'a list * 'b list - val zip : ?rev:'d -> ?onto:('a * 'b) list -> ?short:'e -> 'a list -> 'b list -> ('a * 'b) list (* aka `Std.List.combine` or `map2 pair` *) - val unzip : ?rev:'d -> ?onto:'b list * 'c list -> ('b * 'c) list -> 'b list * 'c list (* aka `Std.List.split` or `unmap2 ident` *) - val mapi : (int -> 'a -> 'b) -> ?onto:'b list -> 'a list -> 'b list - val optmap : ('a -> 'b option) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list - val optmapi : (int -> 'a -> 'b option) -> ?onto:'b list -> 'a list -> 'b list - (* `catmap f ~rev [x1,x2,x3]` ==> [x3c..x3a; x2c..x2a; x1c..x1a] *) - val catmap : ('a -> 'b list) -> ?rev:'c -> ?onto:'b list -> 'a list -> 'b list (* Haskell's `concatMap` *) - val catmapi : (int -> 'a -> 'b list) -> ?onto:'b list -> 'a list -> 'b list - val iter : ('a -> unit) -> 'a list -> unit - val iteri : (int -> 'a -> unit) -> 'a list -> unit - val iter2 : ('a -> 'b -> unit) -> ?short:'c -> 'a list -> 'b list -> unit - val fold_left : ('z -> 'a -> 'z) -> 'z -> 'a list -> 'z - val fold_left1 : ('a -> 'a -> 'a) -> 'a list -> 'a - val fold_left2 : ('z -> 'a -> 'b -> 'z) -> 'z -> ?short:'d -> 'a list -> 'b list -> 'z - val fold_right : ('a -> 'z -> 'z) -> 'a list -> 'z -> 'z - val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a - val fold_right2 : ('a -> 'b -> 'z -> 'z) -> ?short:'d -> 'a list -> 'b list -> 'z -> 'z - val for_all : ('a -> bool) -> 'a list -> bool (* Haskell's `all` *) - val exists : ('a -> bool) -> 'a list -> bool (* Haskell's `any` *) - val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - val maximum : ?rev:'b -> ?cmp:('a -> 'a -> int) -> 'a list -> 'a - val minimum : ?rev:'b -> ?cmp:('a -> 'a -> int) -> 'a list -> 'a - (* These compare mapped values, and return index,original,mapped value. *) - val maxby : ('a -> 'b) -> ?cmp:('b -> 'b -> int) -> ?rev:'c -> 'a list -> int * 'a * 'b - val minby : ('a -> 'b) -> ?cmp:('b -> 'b -> int) -> ?rev:'c -> 'a list -> int * 'a * 'b - val sum : int list -> int - val product : int list -> int - val take : int -> 'a list -> 'a list - val take' : int -> 'a list -> 'a list - val drop : int -> 'a list -> 'a list (* `tail` is `drop 1` *) - val drop' : int -> 'a list -> 'a list - val split : int -> 'a list -> 'a list * 'a list - val split' : int -> 'a list -> 'a list * 'a list (* Haskell's `splitAt` *) - val nth : 'a list -> int -> 'a (* Haskell's `xs !! n` *) - val modify : int -> ('a -> 'a) -> 'a list -> 'a list - val optmodify : int -> ('a -> 'a option) -> 'a list -> 'a list - val catmodify : int -> ('a -> 'a list) -> 'a list -> 'a list - val take_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list - val drop_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list - (* `split_while p xs` is `(take_while p xs, drop_while p xs)`; but `split_while p ~rev xs` is `(drop_while p ~rev xs, take_while p ~rev xs)` *) - val split_while : ('a -> bool) -> ?rev:'b -> 'a list -> 'a list * 'a list (* Haskell's `span` *) - val find : ('a -> bool) -> ?rev:'b -> 'a list -> 'a - val optfind : ('a -> 'b option) -> ?rev:'c -> 'a list -> 'b - val findx : ('a -> bool) -> ?rev:'b -> 'a list -> int * 'a (* fst of this is Haskell's `findIndex`, except that returns Maybe Int *) - (* Unlike findx, index accepts ~cmp. *) - val index : 'a -> ?rev:'b -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> 'a list -> int (* Haskell's `elemIndex`, except that returns Maybe Int *) - val remove : ('a -> bool) -> ?rev:'b -> ?many:'c -> 'a list -> 'a list - val delete : 'a -> ?rev:'b -> ?eq:('a -> 'a -> bool) -> ?cmp:('a -> 'a -> int) -> ?many:'c -> 'a list -> 'a list - (* `pick p xs` is `(find p xs, remove p xs)` *) - val pick : ('a -> bool) -> ?rev:'b -> 'a list -> 'a * 'a list - val pickx : ('a -> bool) -> ?rev:'b -> 'a list -> int * 'a * 'a list - val filter : ('a -> bool) -> ?rev:'b -> ?onto:'a list -> 'a list -> 'a list - val filterx : ('a -> bool) -> 'a list -> (int * 'a) list (* fst of this is Haskell's `findIndices` *) - val indices : 'a -> ?eq:('a -> 'a -> bool) -> 'a list -> int list (* Haskell's `elemIndices` *) - (* `partition p xs` is `(filter p xs, filter (non p) xs)` *) - val partition : ('a -> bool) -> 'a list -> 'a list * 'a list - val partitionx : ('a -> bool) -> 'a list -> (int * 'a) list * (int * 'a) list - val assoc : 'a -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> 'b (* Haskell's `lookup` *) - val mem_assoc : 'a -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> bool - val modify_assoc : 'a -> ('a -> 'b -> 'b) -> ?missing:('a -> 'b) -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> ('a * 'b) list - val optmodify_assoc : 'a -> ('a -> 'b option -> 'b option) -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ('a * 'b) list -> ('a * 'b) list - val remove_assoc : 'a -> ?rev:'c -> ?eq:('a -> 'a -> bool) -> ?many:'d -> ('a * 'b) list -> ('a * 'b) list - val memq : 'a -> 'a list -> bool - val indexq : 'a -> 'a list -> int - val deleteq : 'a -> 'a list -> 'a list - val indicesq : 'a -> 'a list -> int list - val assq : 'a -> ?rev:'c -> ('a * 'b) list -> 'b - val mem_assq : 'a -> ('a * 'b) list -> bool - val modify_assq : 'a -> ('a -> 'b -> 'b) -> ?missing:('a -> 'b) -> ?rev:'c -> ('a * 'b) list -> ('a * 'b) list - val optmodify_assq : 'a -> ('a -> 'b option -> 'b option) -> ?rev:'c -> ('a * 'b) list -> ('a * 'b) list - val remove_assq : 'a -> ?rev:'c -> ?many:'d -> ('a * 'b) list -> ('a * 'b) list - - (* Positive n rotates forward; `rotate 1 xs` is `append (last xs) (init xs)` or `unsnoc` *) - val rotate : int -> 'a list -> 'a list - val unfold : ('z -> ('a * 'z) option) -> ?rev:'c -> ?onto:'a list -> 'z -> 'a list - (* ~rev only affects the order of the mapz'd output, not the direction of the folding *) - val mapz : ('z -> 'a -> 'z * 'b) -> 'z -> ?rev:'d -> ?onto:'b list -> 'a list -> 'z * 'b list (* Haskell's `mapAccumL` *) - val group : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list list (* Haskell's `groupBy` *) - (* `cross f xs ys` is `[f x y | x from xs, y from ys]` or `catmap (fun x -> map (f x) ys) xs` *) - val cross : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - (* `insert` expects a sorted list; use `catmodify` to insert elements before/after a specified index *) - val insert : 'a -> ?cmp:('a -> 'a -> int) -> ?many:'b -> 'a list -> 'a list - (* Plural version of `nth` *) - val select : 'a list -> int list -> 'a list - (* `range start ~len` *) - val range : ?step:int -> int -> len:int -> int list - (* `range_until start excluded_stop`; specify ~step:1 to produce [] when stop < start *) - val range_until : ?step:int -> int -> int -> int list - val unique : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list (* Haskell's `nub` *) - val is_unique : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> bool - (* `transpose [xxx, yyy]` ==> [xy, xy, xy] *) - val transpose : 'a list list -> 'a list list - (* Based on http://www.haskell.org/ghc/docs/latest/html/libraries/base/src/Data-List.html#permutations - Permutations with replacement, or enum base xs of 0..pow (length xs) k-1, is Haskell's `replicateM k xs` or `sequence $ replicate k xs`; same as `cross klist (make k xs)` *) - val permutations : ?len:int -> ?many:'b -> 'a list -> 'a list list - (* `sublists` without ~len or ~many is powerlist/all combinations, preserving order of members, who needn't have been contiguous; is Haskell's `subsequences` or `filterM (const [False, True]) xs`. - sublists ~len:k gives combinations of length k; straightforward implementation, found at http://www.polyomino.f2s.com/david/haskell/hs/CombinatoricsGeneration.hs.txt, also http://rosettacode.org/wiki/Combinations#Haskell - sublists ~len:k ~many gives the ((length xs+k-1) choose k) many combinations with replacement; based on http://rosettacode.org/wiki/Combinations_with_repetitions#Haskell *) - val sublists : ?len:int -> ?many:'b -> 'a list -> 'a list list - (* Members of first arg must appear in order in second, though they needn't be contiguous; for sorted lists, is a less-efficient version of `is_subset` without ~many *) - val is_sublist : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool - (* `let sup = [1] in is_subset ~many [1;1] sup` is true; omit ~many to require sup to have >= the multiplicity of each member of subset *) - val is_subset : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> ?many:'b -> 'a list -> 'a list -> bool - (* Multiset equality, order ignored *) - val is_eqset : ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> bool - val lexcmp : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int - (* `diff ~many xs ys` deletes all occurrences of each member of ys *) - val diff : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> ?many:'b -> 'a list -> 'a list -> 'a list - (* Each element has its max multiplicity; with second list always as a suffix of the result *) - val union : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list - (* Each element has its min multiplicity; in order of second list *) - val intersect : ?cmp:('a -> 'a -> int) -> ?eq:('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list - (* To merge without ~many, use `union ~cmp:compare`. *) - val merge : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list - (* Stable mergesort, O(n log n) avg and worst, will delete later occurrences of any duplicates, unless invoked with ~many *) - val sort : ?cmp:('a -> 'a -> int) -> ?many:'b -> ?rev:'c -> 'a list -> 'a list - val is_sorted : ?cmp:('a -> 'a -> int) -> ?many:'b -> ?rev:'c -> 'a list -> bool - val string_of_list : ?brackets:bool -> ?sep:string -> ('a -> string) -> 'a list -> string - val histogram : ?eq:('a -> 'a -> bool) -> 'a list -> ('a * int) list - (* [x1;x2;x3] ==> [(x1,x2);(x2,x3);(x3,missing)] *) - val pairwise : ?missing:'a -> 'a list -> ('a * 'a) list - (* [xxxx,y,zz] ==> xyzxzxx *) - val round_robin : 'a list list -> 'a list - (* Break list into int-sized discrete segments; chunk' permits last chunk to be short *) - val chunk : int -> 'a list -> 'a list list - val chunk' : int -> 'a list -> 'a list list - (* How many ways can int be represented as sum of members of xs (permitting them to be re-used)? - `chunk_int 6 [1;2;3]` ==> [ [3;3]; [3;2;1]; [3;1;1;1]; ...] - These are sometimes called "partitions of N". Based on http://www.polyomino.f2s.com/david/haskell/hs/CombinatoricsGeneration.hs.txt. This is an NP problem. *) - val chunk_int : int -> int list -> int list list - (* Partitions of the range 0..(k1+k2+k3) into lists of size k1,k2,k3. - `chunk_range [2;1;3]` ==> [ [[0;1];[2];[3;4;5]]; ...] - Based on http://rosettacode.org/wiki/Ordered_Partitions#Haskell *) - val chunk_range : int list -> int list list list - - end = struct - - let short = () - let many = () - exception Short_list - - let is_null = function [] -> true | _ -> false - - let length xs = - let rec aux i = function [] -> i | _::xs -> aux (i+1) xs in - aux 0 xs - - let count p xs = - let rec aux p n = function [] -> n | x::xs when p x -> aux p (n+1) xs | _::xs -> aux p n xs in - aux p 0 xs - - let cons x xs = x :: xs - - let singleton x = [x] - - let make n x = - let rec aux x xs n = if n = 0 then xs else aux x (x::xs) (n-1) in - if n < 0 then invalid_arg "make" else aux x [] n - - let rec rev1 onto = function [] -> onto | x::xs -> rev1 (x::onto) xs - - let rec rev2 onto = function [] -> onto | ys::yss -> rev2 (rev1 onto ys) yss - - let rec rev ?(onto=[]) = function [] -> onto | x::xs -> let onto = x::onto in rev ~onto xs - - let snoc xs x = rev1 [x] (rev1 [] xs) - - let head = function x::_ -> x | [] -> raise Short_list - - let opthead = function x::_ -> Some x | [] -> None - - let tail = function _::xs -> xs | [] -> raise Short_list - - let tail' = function _::xs -> xs | [] -> [] - - let uncons = function x::xs -> (x,xs) | [] -> raise Short_list - - let rec last = function [x] -> x | x::xs -> last xs | _ -> raise Short_list - - let init xs = match rev1 [] xs with [] -> raise Short_list | _::xs -> rev1 [] xs - - let init' xs = match rev1 [] xs with [] -> [] | _::xs -> rev1 [] xs - - let append xs = function [] -> xs | onto -> rev1 onto (rev1 [] xs) - - let concat xss = rev2 [] (rev1 [] xss) - - let mem sought ?(eq=(=)) ?cmp xs = - let rec aux_all eq sought = function [] -> false | x::xs -> eq x sought || aux_all eq sought xs in - let rec aux_sorted cmp sought = function - | x::xs -> let res = cmp x sought in if res > 0 then false else res = 0 || aux_sorted cmp sought xs - | [] -> false in - match cmp with - | None -> aux_all eq sought xs - | Some cmp -> aux_sorted cmp sought xs - - let rec memq sought = function [] -> false | x::xs -> x == sought || memq sought xs - - let map f ?rev ?(onto=[]) xs = - let rec aux f onto = function - | [] -> onto - | x::xs -> aux f (f x::onto) xs in - match rev with - | None -> rev1 onto (aux f [] xs) - | Some _ -> aux f onto xs - - let map2 f ?rev ?(onto=[]) ?short xs ys = - let rec aux f short onto xs ys = match xs, ys with - | x::xs, y::ys -> aux f short (f x y::onto) xs ys - | [],[] -> onto - | _ -> if short then onto else raise Short_list in - match rev with - | None -> rev1 onto (aux f (Option.is_some short) [] xs ys) - | Some _ -> aux f (Option.is_some short) onto xs ys - - let zip ?rev ?(onto=[]) ?short xs ys = - let rec aux short onto xs ys = match xs, ys with - | x::xs, y::ys -> aux short ((x,y)::onto) xs ys - | [],[] -> onto - | _ -> if short then onto else raise Short_list in - match rev with - | None -> rev1 onto (aux (Option.is_some short) [] xs ys) - | Some _ -> aux (Option.is_some short) onto xs ys - - let unmap2 f ?rev ?(onto=[],[]) zs = - let rec aux f xs ys = function - | [] -> xs, ys - | z::zs -> let x,y = f z in aux f (x::xs) (y::ys) zs in - match rev,onto with - | None,(xonto,yonto) -> let xs,ys = aux f [] [] zs in rev1 xonto xs, rev1 yonto ys - | Some _,(xonto,yonto) -> aux f xonto yonto zs - - let unzip ?rev ?(onto=[],[]) zs = - let rec aux xs ys = function - | [] -> xs, ys - | (x,y)::zs -> aux (x::xs) (y::ys) zs in - match rev,onto with - | None,(xonto,yonto) -> let xs,ys = aux [] [] zs in rev1 xonto xs, rev1 yonto ys - | Some _,(xonto,yonto) -> aux xonto yonto zs - - let mapi f ?(onto=[]) xs = - let rec aux f i onto = function - | [] -> onto - | x::xs -> aux f (i+1) (f i x::onto) xs in - rev1 onto (aux f 0 [] xs) - - let optmap f ?rev ?(onto=[]) xs = - let rec aux f onto = function - | [] -> onto - | x::xs -> aux f (match f x with None -> onto | Some x' -> x'::onto) xs in - match rev with - | None -> rev1 onto (aux f [] xs) - | Some _ -> aux f onto xs - - let optmapi f ?(onto=[]) xs = - let rec aux f i onto = function - | [] -> onto - | x::xs -> aux f (i+1) (match f i x with None -> onto | Some x' -> x'::onto) xs in - rev1 onto (aux f 0 [] xs) - - let catmap f ?rev ?(onto=[]) xs = - let rec aux f onto = function - | [] -> onto - | x::xs -> aux f (rev1 [] (f x)::onto) xs in - let rec aux_rev f onto = function - | [] -> onto - | x::xs -> aux_rev f (rev1 onto (f x)) xs in - match rev with - | None -> rev2 onto (aux f [] xs) - | Some _ -> aux_rev f onto xs - - let catmapi f ?(onto=[]) xs = - let rec aux f i onto = function - | [] -> onto - | x::xs -> aux f (i+1) (rev1 [] (f i x)::onto) xs in - rev2 onto (aux f 0 [] xs) - - let rec iter f = function [] -> () | x::xs -> f x; iter f xs - - let iteri f xs = - let rec aux f i = function [] -> () | x::xs -> f i x; aux f (i+1) xs in - aux f 0 xs - - let iter2 f ?short xs ys = - let rec aux f short xs ys = match xs, ys with - | x::xs, y::ys -> f x y; aux f short xs ys - | [],[] -> () - | _ -> if short then () else raise Short_list in - aux f (Option.is_some short) xs ys - - let rec fold_left f z = function - | [] -> z - | x::xs -> fold_left f (f z x) xs - - let fold_left1 f = function - | [] -> raise Short_list - | x::xs -> fold_left f x xs - - let fold_left2 f z ?short xs ys = - let rec aux f short z xs ys = match xs, ys with - | [],[] -> z - | x::xs,y::ys -> aux f short (f z x y) xs ys - | _ -> if short then z else raise Short_list in - aux f (Option.is_some short) z xs ys - - let rec fold_right f xs z = - let rec aux f z = function - | [] -> z - | x::xs -> aux f (f x z) xs in - aux f z (rev1 [] xs) - - let fold_right1 f xs = - let rec aux f z = function - | [] -> z - | x::xs -> aux f (f x z) xs in - match rev1 [] xs with - | [] -> raise Short_list - | x::xs -> aux f x xs - - let fold_right2 f ?short xs ys z = - let rec aux f short z xs ys = match xs, ys with - | [],[] -> z - | x::xs,y::ys -> aux f short (f x y z) xs ys - | _ -> if short then z else raise Short_list in - aux f (Option.is_some short) z (rev1 [] xs) (rev1 [] ys) - - let rec for_all p = function [] -> true | x::xs -> p x && for_all p xs - let rec exists p = function [] -> false | x::xs -> p x || exists p xs - - let rec for_all2 p xs ys = match xs,ys with [],[] -> true | x::xs,y::ys -> p x y && for_all2 p xs ys | _ -> raise Short_list - let rec exists2 p xs ys = match xs,ys with [],[] -> false | x::xs,y::ys -> p x y || exists2 p xs ys | _ -> raise Short_list - - let maximum ?rev ?(cmp=compare) xs = - let rec aux select cmp sofar = function - | [] -> sofar - | x::xs -> let res = cmp x sofar in aux select cmp (if res < 0 then sofar else if res = 0 then select sofar x else x) xs in - match rev,xs with - | None,(x::xs) -> aux (fun sofar x -> sofar) cmp x xs - | Some _,(x::xs) -> aux (fun sofar x -> x) cmp x xs - | _ -> raise Short_list - - let minimum ?rev ?(cmp=compare) xs = - let rec aux select cmp sofar = function - | [] -> sofar - | x::xs -> let res = cmp x sofar in aux select cmp (if res > 0 then sofar else if res = 0 then select sofar x else x) xs in - match rev,xs with - | None,(x::xs) -> aux (fun sofar x -> sofar) cmp x xs - | Some _,(x::xs) -> aux (fun sofar x -> x) cmp x xs - | _ -> raise Short_list - - (* - let maximumx ?rev ?(cmp=compare) xs = - let rec aux select cmp i sofar = function - | [] -> sofar - | x::xs -> let res = cmp x (snd sofar) in aux select cmp (i+1) (if res < 0 then sofar else if res = 0 then select sofar i x else (i,x)) xs in - match rev,xs with - | None,(x::xs) -> aux (fun sofar i x -> sofar) cmp 1 (0,x) xs - | Some _,(x::xs) -> aux (fun sofar i x -> (i,x)) cmp 1 (0,x) xs - | _ -> raise Short_list - - let minimumx ?rev ?(cmp=compare) xs = - let rec aux select cmp i sofar = function - | [] -> sofar - | x::xs -> let res = cmp x (snd sofar) in aux select cmp (i+1) (if res > 0 then sofar else if res = 0 then select sofar i x else (i,x)) xs in - match rev,xs with - | None,(x::xs) -> aux (fun sofar i x -> sofar) cmp 1 (0,x) xs - | Some _,(x::xs) -> aux (fun sofar i x -> (i,x)) cmp 1 (0,x) xs - | _ -> raise Short_list - *) - - let maxby f ?(cmp=compare) ?rev xs = - let rec aux f cmp thresh (_,_,fw as prev) i = function - | [] -> prev - | x::xs -> aux f cmp thresh (let fx = f x in if cmp fx fw > thresh then (i,x,fx) else prev) (i+1) xs in - match rev,xs with - | _,[] -> raise Short_list - | None,x::xs -> aux f cmp 0 (0,x,f x) 1 xs - | Some _,x::xs -> aux f cmp (-1) (0,x,f x) 1 xs - - let minby f ?(cmp=compare) ?rev xs = - let rec aux f cmp thresh (_,_,fw as prev) i = function - | [] -> prev - | x::xs -> aux f cmp thresh (let fx = f x in if cmp fx fw < thresh then (i,x,fx) else prev) (i+1) xs in - match rev,xs with - | _,[] -> raise Short_list - | None,x::xs -> aux f cmp 0 (0,x,f x) 1 xs - | Some _,x::xs -> aux f cmp (+1) (0,x,f x) 1 xs - - let sum xs = fold_left ( + ) 0 xs - let product xs = fold_left ( * ) 1 xs - - let take n xs = - let rec aux n ys = function - | _ when n = 0 -> rev1 [] ys - | [] -> raise Short_list - | x::xs -> aux (n-1) (x::ys) xs in - if n < 0 then invalid_arg "take" else aux n [] xs - - let take' n xs = - let rec aux n ys = function - | _ when n = 0 -> rev1 [] ys - | [] -> rev1 [] ys - | x::xs -> aux (n-1) (x::ys) xs in - if n < 0 then invalid_arg "take'" else aux n [] xs - - let drop n xs = - let rec aux n = function - | xs when n = 0 -> xs - | [] -> raise Short_list - | _::xs -> aux (n-1) xs in - if n < 0 then invalid_arg "drop" else aux n xs - - let drop' n xs = - let rec aux n = function - | xs when n = 0 -> xs - | [] -> [] - | _::xs -> aux (n-1) xs in - if n < 0 then invalid_arg "drop'" else aux n xs - - let split n xs = - let rec aux n ys = function - | xs when n = 0 -> rev1 [] ys, xs - | [] -> raise Short_list - | x::xs -> aux (n-1) (x::ys) xs in - if n < 0 then invalid_arg "split" else aux n [] xs - - let split' n xs = - let rec aux n ys = function - | xs when n = 0 -> rev1 [] ys, xs - | [] -> rev1 [] ys, [] - | x::xs -> aux (n-1) (x::ys) xs in - if n < 0 then invalid_arg "split'" else aux n [] xs - - let nth xs n = - let rec aux n = function - | x::xs -> if n = 0 then x else aux (n-1) xs - | [] -> raise Short_list in - if n < 0 then invalid_arg "nth" else aux n xs - - let modify n f xs = - let rec aux n f i ys = function - | [] -> raise Short_list - | x::xs -> if n = i then rev1 ((f x)::xs) ys else aux n f (i+1) (x::ys) xs in - if n < 0 then invalid_arg "modify" else aux n f 0 [] xs - - let optmodify n f xs = - let rec aux n f i ys = function - | [] -> raise Short_list - | x::xs -> if n = i then rev1 (match f x with Some x -> x::xs | None -> xs) ys else aux n f (i+1) (x::ys) xs in - if n < 0 then invalid_arg "optmodify" else aux n f 0 [] xs - - let catmodify n f xs = - let rec aux n f i ys = function - | [] -> raise Short_list - | x::xs -> if n = i then rev1 xs (rev1 ys (f x)) else aux n f (i+1) (x::ys) xs in - if n < 0 then invalid_arg "optmodify" else aux n f 0 [] xs - - let take_while p ?rev xs = - let rec aux_left p ys = function - | [] -> xs - | x::xs -> if p x then aux_left p (x::ys) xs else rev1 [] ys in - let rec aux_right p ys = function - | [] -> rev1 [] ys - | x::xs -> if p x then aux_right p (x::ys) xs else aux_right p [] xs in - match rev with - | None -> aux_left p [] xs - | Some _ -> aux_right p [] xs - - let drop_while p ?rev xs = - let rec aux_left p = function - | [] -> [] - | x::xs as orig -> if p x then aux_left p xs else orig in - let rec aux_right p matching yss ys = function - | [] -> if matching then rev2 [] yss else xs - | x::xs -> if p x = matching then aux_right p matching yss (x::ys) xs - else aux_right p (not matching) (ys::yss) [x] xs in - match rev with - | None -> aux_left p xs - | Some _ -> aux_right p false [] [] xs - - let split_while p ?rev xs = - let rec aux_left p ys = function - | [] -> xs, [] - | x::xs as orig -> if p x then aux_left p (x::ys) xs else rev1 [] ys, orig in - let rec aux_right p matching yss ys = function - | [] -> if matching then rev2 [] yss, rev1 [] ys else xs, [] - | x::xs -> if p x = matching then aux_right p matching yss (x::ys) xs - else aux_right p (not matching) (ys::yss) [x] xs in - match rev with - | None -> aux_left p [] xs - | Some _ -> aux_right p false [] [] xs - - let find p ?rev xs = - let rec aux_left p = function [] -> raise Not_found | x::xs -> if p x then x else aux_left p xs in - let rec aux_right p prev = function - | [] -> (match prev with None -> raise Not_found | Some x -> x) - | x::xs -> aux_right p (if p x then Some x else prev) xs in - match rev with - | None -> aux_left p xs - | Some _ -> aux_right p None xs - - let optfind p ?rev xs = - let rec aux_left p = function [] -> raise Not_found | x::xs -> (match p x with Some y -> y | None -> aux_left p xs) in - let rec aux_right p prev = function - | [] -> (match prev with None -> raise Not_found | Some x -> x) - | x::xs -> aux_right p (match p x with Some y -> Some y | None -> prev) xs in - match rev with - | None -> aux_left p xs - | Some _ -> aux_right p None xs - - let findx p ?rev xs = - let rec aux_left p i = function [] -> raise Not_found | x::xs -> if p x then (i,x) else aux_left p (i+1) xs in - let rec aux_right p i prev = function - | [] -> (match prev with None -> raise Not_found | Some (i,x as res) -> res) - | x::xs -> aux_right p (i+1) (if p x then Some (i,x) else prev) xs in - match rev with - | None -> aux_left p 0 xs - | Some _ -> aux_right p 0 None xs - - let index sought ?rev ?(eq=(=)) ?cmp xs = - let rec aux_left eq sought i = function [] -> raise Not_found | x::xs -> if eq x sought then i else aux_left eq sought (i+1) xs in - let rec aux_right eq sought i prev = function [] -> if prev < 0 then raise Not_found else prev | x::xs -> aux_right eq sought (i+1) (if eq x sought then i else prev) xs in - let rec aux_sorted cmp sought i = function - | x::xs -> let res = cmp x sought in if res > 0 then raise Not_found else if res = 0 then i else aux_sorted cmp sought (i+1) xs - | [] -> raise Not_found in - match cmp,rev with - | None,None -> aux_left eq sought 0 xs - | None,Some _ -> aux_right eq sought 0 (-1) xs - | Some cmp,None -> aux_sorted cmp sought 0 xs - | Some _,Some _ -> invalid_arg "index ~rev conflicts with ~cmp" - - let indexq sought xs = - let rec aux sought i = function [] -> raise Not_found | x::xs -> if x == sought then i else aux sought (i+1) xs in - aux sought 0 xs - - let remove p ?rev ?many xs = - let rec aux_left p ys = function [] -> xs | x::xs -> if p x then rev1 xs ys else aux_left p (x::ys) xs in - let rec aux_many p ys = function [] -> rev1 [] ys | x::xs -> aux_many p (if p x then ys else x::ys) xs in - let rec aux_right p yss ys = function - | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false) - | x::xs -> if p x then aux_right p ((x::ys)::yss) [] xs else aux_right p yss (x::ys) xs in - match rev,many with - | None,None -> aux_left p [] xs - | Some _,None -> aux_right p [] [] xs - | None,Some _ -> aux_many p [] xs - | Some _,Some _ -> invalid_arg "remove ~rev conflicts with ~many" - - let delete sought ?rev ?(eq=(=)) ?cmp ?many xs = - let rec aux_left eq sought ys = function [] -> xs | x::xs -> if eq x sought then rev1 xs ys else aux_left eq sought (x::ys) xs in - let rec aux_many eq sought ys = function [] -> rev1 [] ys | x::xs -> aux_many eq sought (if eq x sought then ys else x::ys) xs in - let rec aux_right eq sought yss ys = function - | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false) - | x::xs -> if eq x sought then aux_right eq sought ((x::ys)::yss) [] xs else aux_right eq sought yss (x::ys) xs in - let rec aux_sorted cmp sought ys = function - | [] -> xs - (* don't shadow the entry-level `xs` *) - | z::zs -> let res = cmp z sought in if res > 0 then xs else if res = 0 then rev1 zs ys else aux_sorted cmp sought (z::ys) zs in - let rec aux_msorted cmp sought ys = function - | [] -> rev1 [] ys - | x::xs as orig -> let res = cmp x sought in if res > 0 then rev1 orig ys else aux_msorted cmp sought (if res = 0 then ys else x::ys) xs in - match cmp,rev,many with - | None,None,None -> aux_left eq sought [] xs - | None,Some _,None -> aux_right eq sought [] [] xs - | Some cmp,None,None -> aux_sorted cmp sought [] xs - | None,None,Some _ -> aux_many eq sought [] xs - | Some cmp,None,Some _ -> aux_msorted cmp sought [] xs - | Some _,Some _,None -> invalid_arg "delete ~rev conflicts with ~cmp" - | None,Some _,Some _ -> invalid_arg "delete ~rev conflicts with ~many" - | Some _,Some _,Some _ -> invalid_arg "delete ~rev conflicts with ~many and ~cmp" - - let deleteq sought xs = - let rec aux sought ys = function [] -> xs | x::xs -> if x == sought then rev1 xs ys else aux sought (x::ys) xs in - aux sought [] xs - - let pick p ?rev xs = - let rec aux_left p ys = function [] -> raise Not_found | x::xs -> if p x then x, rev1 xs ys else aux_left p (x::ys) xs in - let rec aux_right p prev yss ys = function - | [] -> (match prev, yss with None,_ -> raise Not_found | Some x,(_::xs)::yss -> x, rev2 (rev1 [] ys) (xs::yss) | _ -> assert false) - | x::xs -> if p x then aux_right p (Some x) ((x::ys)::yss) [] xs else aux_right p prev yss (x::ys) xs in - match rev with - | None -> aux_left p [] xs - | Some _ -> aux_right p None [] [] xs - - let pickx p ?rev xs = - let rec aux_left p i ys = function [] -> raise Not_found | x::xs -> if p x then i, x, rev1 xs ys else aux_left p (i+1) (x::ys) xs in - let rec aux_right p i prev yss ys = function - | [] -> (match prev, yss with None,_ -> raise Not_found | Some (i,x),(_::xs)::yss -> i, x, rev2 (rev1 [] ys) (xs::yss) | _ -> assert false) - | x::xs -> if p x then aux_right p (i+1) (Some (i,x)) ((x::ys)::yss) [] xs else aux_right p (i+1) prev yss (x::ys) xs in - match rev with - | None -> aux_left p 0 [] xs - | Some _ -> aux_right p 0 None [] [] xs - - let filter p ?rev ?(onto=[]) xs = - let rec aux p ys = function [] -> ys | x::xs -> aux p (if p x then x::ys else ys) xs in - match rev with - | None -> rev1 onto (aux p [] xs) - | Some _ -> aux p onto xs - - (* - val filteri : (int -> 'a -> bool) -> ?onto:'a list -> 'a list -> 'a list - let filteri p ?(onto=[]) xs = - let rec aux p i ys = function [] -> ys | x::xs -> aux p (i+1) (if p i x then x::ys else ys) xs in - rev1 onto (aux p 0 [] xs) - *) - - let filterx p xs = - let rec aux p i ys = function [] -> ys | x::xs -> aux p (i+1) (if p x then (i,x)::ys else ys) xs in - rev1 [] (aux p 0 [] xs) - - let indices sought ?(eq=(=)) xs = - let rec aux eq sought i ys = function [] -> ys | x::xs -> aux eq sought (i+1) (if eq x sought then i::ys else ys) xs in - rev1 [] (aux eq sought 0 [] xs) - - let indicesq sought xs = - let rec aux sought i ys = function [] -> ys | x::xs -> aux sought (i+1) (if x == sought then i::ys else ys) xs in - rev1 [] (aux sought 0 [] xs) - - (* remove ~many p, delete ~many x *) - - let partition p xs = - let rec aux p ys ns = function - | [] -> if ys = [] then [], xs else if ns = [] then xs, [] else rev1 [] ys, rev1 [] ns - | x::xs -> if p x then aux p (x::ys) ns xs else aux p ys (x::ns) xs in - aux p [] [] xs - - let partitionx p xs = - let rec aux p i ys ns = function - | [] -> rev1 [] ys, rev1 [] ns - | x::xs -> if p x then aux p (i+1) ((i,x)::ys) ns xs else aux p (i+1) ys ((i,x)::ns) xs in - aux p 0 [] [] xs - - let assoc sought ?rev ?(eq=(=)) xs = - let rec aux_left sought eq = function - | [] -> raise Not_found - | (k,x)::xs -> if eq k sought then x else aux_left sought eq xs in - let rec aux_right sought eq prev = function - | [] -> (match prev with None -> raise Not_found | Some x -> x) - | (k,x)::xs -> aux_right sought eq (if eq k sought then Some x else prev) xs in - match rev with - | None -> aux_left sought eq xs - | Some _ -> aux_right sought eq None xs - - let rec assq sought ?rev xs = - let rec aux_left sought = function - | [] -> raise Not_found - | (k,x)::xs -> if k == sought then x else assq sought xs in - let rec aux_right sought prev = function - | [] -> (match prev with None -> raise Not_found | Some x -> x) - | (k,x)::xs -> aux_right sought (if k == sought then Some x else prev) xs in - match rev with - | None -> aux_left sought xs - | Some _ -> aux_right sought None xs - - let modify_assoc sought f ?missing ?rev ?(eq=(=)) xs = - let rec aux_left sought f eq ys = function - | [] -> None - | (k,x as kx)::xs -> if eq k sought then Some (rev1 ((k,f k x)::xs) ys) else aux_left sought f eq (kx::ys) xs in - let rec aux_right sought f eq yss ys = function - | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 ((k,f k x)::rev1 [] ys) (xs::yss)) | _ -> assert false) - | (k,x as kx)::xs -> if eq k sought then aux_right sought f eq ((kx::ys)::yss) [] xs else aux_right sought f eq yss (kx::ys) xs in - match rev,missing with - | None,None -> (match aux_left sought f eq [] xs with None -> raise Not_found | Some xs -> xs) - | None,Some m -> (match aux_left sought f eq [] xs with None -> (sought,m sought)::xs | Some xs -> xs) - | Some _,None -> (match aux_right sought f eq [] [] xs with None -> raise Not_found | Some xs -> xs) - | Some _,Some m -> (match aux_right sought f eq [] [] xs with None -> (sought,m sought)::xs | Some xs -> xs) - - let optmodify_assoc sought f ?rev ?(eq=(=)) xs = - let rec aux_left sought f eq ys = function - | [] -> None - | (k,x as kx)::xs -> if eq k sought then Some (rev1 (match f k (Some x) with None -> xs | Some x -> (k,x)::xs) ys) else aux_left sought f eq (kx::ys) xs in - let rec aux_right sought f eq yss ys = function - | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 (match f k (Some x) with None -> rev1 [] ys | Some x -> (k,x)::rev1 [] ys) (xs::yss)) | _ -> assert false) - | (k,x as kx)::xs -> if eq k sought then aux_right sought f eq ((kx::ys)::yss) [] xs else aux_right sought f eq yss (kx::ys) xs in - match rev with - | None -> (match aux_left sought f eq [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs) - | Some _ -> (match aux_right sought f eq [] [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs) - - let modify_assq sought f ?missing ?rev xs = - let rec aux_left sought f ys = function - | [] -> None - | (k,x as kx)::xs -> if k == sought then Some (rev1 ((k,f k x)::xs) ys) else aux_left sought f (kx::ys) xs in - let rec aux_right sought f yss ys = function - | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 ((k,f k x)::rev1 [] ys) (xs::yss)) | _ -> assert false) - | (k,x as kx)::xs -> if k == sought then aux_right sought f ((kx::ys)::yss) [] xs else aux_right sought f yss (kx::ys) xs in - match rev,missing with - | None,None -> (match aux_left sought f [] xs with None -> raise Not_found | Some xs -> xs) - | None,Some m -> (match aux_left sought f [] xs with None -> (sought,m sought)::xs | Some xs -> xs) - | Some _,None -> (match aux_right sought f [] [] xs with None -> raise Not_found | Some xs -> xs) - | Some _,Some m -> (match aux_right sought f [] [] xs with None -> (sought,m sought)::xs | Some xs -> xs) - - let optmodify_assq sought f ?rev xs = - let rec aux_left sought f ys = function - | [] -> None - | (k,x as kx)::xs -> if k == sought then Some (rev1 (match f k (Some x) with None -> xs | Some x -> (k,x)::xs) ys) else aux_left sought f (kx::ys) xs in - let rec aux_right sought f yss ys = function - | [] -> (match yss with [] -> None | ((k,x)::xs)::yss -> Some (rev2 (match f k (Some x) with None -> rev1 [] ys | Some x -> (k,x)::rev1 [] ys) (xs::yss)) | _ -> assert false) - | (k,x as kx)::xs -> if k == sought then aux_right sought f ((kx::ys)::yss) [] xs else aux_right sought f yss (kx::ys) xs in - match rev with - | None -> (match aux_left sought f [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs) - | Some _ -> (match aux_right sought f [] [] xs with None -> (match f sought None with None -> xs | Some x -> (sought,x)::xs) | Some xs -> xs) - - let rec mem_assoc sought ?(eq=(=)) = function - | [] -> false - | (k,_)::xs -> eq k sought || mem_assoc ~eq sought xs - - let rec mem_assq sought = function - | [] -> false - | (k,_)::xs -> k == sought || mem_assq sought xs - - let remove_assoc sought ?rev ?(eq=(=)) ?many xs = - let rec aux_left sought eq ys = function - | [] -> xs - | (k,_ as kx)::xs -> if eq k sought then rev1 xs ys else aux_left sought eq (kx::ys) xs in - let rec aux_many sought eq ys = function - | [] -> rev1 [] ys - | (k,_ as kx)::xs -> aux_many sought eq (if eq k sought then ys else kx::ys) xs in - let rec aux_right sought eq yss ys = function - | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false) - | (k,_ as kx)::xs -> if eq k sought then aux_right sought eq ((kx::ys)::yss) [] xs else aux_right sought eq yss (kx::ys) xs in - match rev,many with - | None,None -> aux_left sought eq [] xs - | Some _,None -> aux_right sought eq [] [] xs - | None,Some _ -> aux_many sought eq [] xs - | Some _,Some _ -> invalid_arg "remove_assoc ~rev conflicts with ~many" - - let remove_assq sought ?rev ?many xs = - let rec aux_left sought ys = function - | [] -> xs - | (k,_ as kx)::xs -> if k == sought then rev1 xs ys else aux_left sought (kx::ys) xs in - let rec aux_many sought ys = function - | [] -> rev1 [] ys - | (k,_ as kx)::xs -> aux_many sought (if k == sought then ys else kx::ys) xs in - let rec aux_right sought yss ys = function - | [] -> (match yss with [] -> xs | (_::xs)::yss -> rev2 (rev1 [] ys) (xs::yss) | _ -> assert false) - | (k,_ as kx)::xs -> if k == sought then aux_right sought ((kx::ys)::yss) [] xs else aux_right sought yss (kx::ys) xs in - match rev,many with - | None,None -> aux_left sought [] xs - | Some _,None -> aux_right sought [] [] xs - | None,Some _ -> aux_many sought [] xs - | Some _,Some _ -> invalid_arg "remove_assq ~rev conflicts with ~many" - - let rotate n xs = - let rec aux ys = function - | [x] -> x::rev1 [] ys - | x::xs -> aux (x::ys) xs - | _ -> assert false in - if n = 0 || xs = [] then xs - else if n = 1 then aux [] xs - else - let xn = length xs in - let n = (xn - n) mod xn in - let pre,post = if n > 0 then split n xs else if n < 0 then split (xn+n) xs else [],xs in - append post pre - - let unfold f ?rev ?(onto=[]) z = - let rec aux f ys z = match f z with None -> ys | Some (y,z) -> aux f (y::ys) z in - match rev with - | None -> rev1 onto (aux f [] z) - | Some _ -> aux f onto z - - let mapz f z ?rev ?(onto=[]) xs = - let rec aux f z ys = function [] -> z,ys | x::xs -> let z,y = f z x in aux f z (y::ys) xs in - match rev with - | None -> let z,ys = aux f z [] xs in z, rev1 onto ys - | Some _ -> aux f z onto xs - - (* - let group ?(eq=(=)) xs = - let rec aux eq = function - | [] -> [] - | x::xs -> let xs,ys = split_while (eq x) xs in (x::xs)::aux eq ys in - aux eq xs - *) - - let group ?(eq=(=)) xs = - let f eq x = function [] -> [[x]] | (y::_ as ys)::yss -> if eq y x then (x::ys)::yss else [x]::ys::yss | _ -> assert false in - let rec aux f eq yss = function [] -> yss | x::xs -> aux f eq (f eq x yss) xs in - match aux f eq [] xs with [] -> [] | xs -> map ~rev rev xs - - let cross f xs ys = - let rec aux f ys = function [] -> ys | x::xs -> aux f (f x::ys) xs in - rev2 [] (aux (fun x -> aux (f x) [] ys) [] xs) - - let insert ins ?(cmp=compare) ?many xs = - let rec aux_one cmp ins ys = function - | [] -> rev1 [ins] ys - (* don't shadow the entry-level `xs` *) - | z::zs as orig -> let res = cmp z ins in if res < 0 then aux_one cmp ins (z::ys) zs else if res = 0 then xs else rev1 (ins::orig) ys in - let rec aux_many cmp ins ys = function - | [] -> rev1 [ins] ys - | x::xs as orig -> let res = cmp x ins in if res < 0 then aux_many cmp ins (x::ys) xs else rev1 (ins::orig) ys in - match many with - | None -> aux_one cmp ins [] xs - | Some _ -> aux_many cmp ins [] xs - - let select xs is = - let rec aux j js i ys = function - | [] -> raise Short_list - (* don't shadow the entry-level `xs` *) - | z::zs as orig -> if j = i then (match js with j::js -> if j >= i then aux j js (if j = i then i else i+1) (z::ys) (if j = i then orig else zs) else aux j js 0 (z::ys) xs | [] -> rev1 [z] ys) else aux j js (i+1) ys zs in - match is with - | [] -> [] - | i::is -> aux i is 0 [] xs - - let range ?(step=1) start ~len = - let rec aux stop step ys i = if stop i then ys else aux stop step (i::ys) (i+step) in - if step = 0 then invalid_arg "range" else aux (if step > 0 then (fun i -> i < start) else (fun i -> i > start)) (-step) [] (start + len*step - step) - - let range_until ?step start stop = - let rec aux stop step ys i = if stop i then ys else aux stop step (i::ys) (i+step) in - match step with - | None -> if stop <= start - then aux (fun i -> i > start) (1) [] (let len = (start - stop) in start - len + 1) - else aux (fun i -> i < start) (-1) [] (let len = (stop - start) in start + len - 1) - | Some x when x < 0 -> if stop >= start then [] else aux (fun i -> i > start) (-x) [] (let len = (stop + x + 1 - start) / x in start + len*x - x) - | Some x when x > 0 -> if stop <= start then [] else aux (fun i -> i < start) (-x) [] (let len = (stop + x - 1 - start) / x in start + len*x - x) - | _ -> invalid_arg "range_until" - - let unique ?cmp ?(eq=(=)) xs = - let rec aux_mem eq x = function [] -> false | y::ys -> eq y x || aux_mem eq x ys in - let rec aux_all eq ys = function - | [] -> rev1 [] ys - | x::xs -> aux_all eq (if aux_mem eq x ys then ys else x::ys) xs in - let rec aux_sorted cmp ys y = function - | [] -> rev1 [y] ys - | x::xs -> if cmp y x = 0 then aux_sorted cmp ys y xs else aux_sorted cmp (y::ys) x xs in - match xs,cmp with - | [],_ | [_],_ -> xs - | x::xs, None -> aux_all eq [x] xs - | x::xs, Some cmp -> aux_sorted cmp [] x xs - - let is_unique ?cmp ?(eq=(=)) xs = - let rec aux_mem eq sought = function [] -> false | x::xs -> eq x sought || aux_mem eq sought xs in - let rec aux_all eq ys = function - | [] -> true - | x::xs -> not (aux_mem eq x ys) && aux_all eq (x::ys) xs in - let rec aux_sorted cmp y = function - | [] -> true - | x::xs -> cmp y x < 0 && aux_sorted cmp x xs in - match xs,cmp with - | [],_ | [_],_ -> true - | x::xs, None -> aux_all eq [x] xs - | x::xs, Some cmp -> aux_sorted cmp x xs - - let rec transpose = function - | [] -> [] - | []::xss -> transpose xss - | (x::xs)::xss -> (x :: map head xss) :: transpose (xs :: map tail xss) - - let sublists ?len ?many xs = - let rec aux_all = function [] -> [] | (x::xs) -> [x]::fold_left (fun yss ys -> (x::ys)::ys::yss) [] (aux_all xs) in - let rec aux_fixed k = function - | _ when k = 0 -> [[]] - | [] -> [] (* happens if k > length xs *) - | x::xs -> map (cons x) (aux_fixed (k-1) xs) ~onto:(aux_fixed k xs) in - let rec aux_replacing k = function - | _ when k = 0 -> [[]] - | [] -> [] (* will only happen if xs was [] to start with *) - | x::xs as orig -> map (cons x) (aux_replacing (k-1) orig) ~onto:(aux_replacing k xs) in - match len,many with - | None,None -> []::aux_all xs - | Some k,None -> if k < 0 then invalid_arg "sublists ~len" else aux_fixed k xs - | Some k,Some _ -> if k < 0 then invalid_arg "sublists ~len" else aux_replacing k xs - | None,Some _ -> invalid_arg "sublists ~many requires ~len" - - let rec permutations ?len ?many xs = - let rec interleave' x xs f r = function - | [] -> xs, r - | y::ys -> let us,zs = interleave' x xs (fun ys -> f(y::ys)) r ys in y::us, f (x::y::us)::zs in - let interleave x xs r ys = let _,zs = interleave' x xs ident r ys in zs in - let rec aux ys = function - | [] -> [] - | x::xs -> fold_left (interleave x xs) (aux (x::ys) xs) (permutations ys) in - let prod yss xs = catmap (fun x -> map (cons x) yss) xs in - match len,many with - | None,None -> xs::aux [] xs - | Some k,None -> if k < 0 then invalid_arg "permutations ~len" else catmap permutations (sublists ~len:k xs) - | Some k,Some _ -> if k < 0 then invalid_arg "permuations ~len" else if k = 0 then [] else fold_left prod [[]] (make k xs) - | None, Some _ -> invalid_arg "permutations ~many requires ~len" - - let is_sublist ?(eq=(=)) xs ys = - let rec aux eq ys xs = match ys,xs with - | _,[] -> true - | [],_::_ -> false - | y::ys',x::xs' -> if eq y x then aux eq ys' xs' else aux eq ys' xs in - aux eq ys xs - - let is_subset ?cmp ?(eq=(=)) ?many xs ys = - let rec aux_sorted uniq cmp ys xs = match ys,xs with - | _,[] -> true - | [],_::_ -> false - | y::ys',x::xs' -> let res = cmp y x in if res > 0 then false else if res < 0 then aux_sorted uniq cmp ys' xs else aux_sorted uniq cmp (if uniq then ys' else ys) xs' in - match cmp,many with - | None,Some _ -> for_all (fun x -> mem ~eq x ys) xs - | Some cmp,None -> aux_sorted true cmp ys xs - | Some cmp,Some _ -> aux_sorted false cmp ys xs - | None,None -> invalid_arg "is_subset requires ~cmp and/or ~many" - - let is_eqset ?(eq=(=)) xs ys = - let rec aux eq x zs = function [] -> raise Not_found | y::ys -> if eq y x then x, rev1 ys zs else aux eq x (y::zs) ys in - try (match fold_left (fun ys x -> let _,ys = aux eq x [] ys in ys) ys xs with [] -> true | _ -> false) - with Not_found -> false - - let rec lexcmp ?(cmp=compare) xs ys = match xs, ys with - | [],[] -> 0 - | _,[] -> 1 - | [],_ -> -1 - | x::xs,y::ys -> let res = cmp x y in if res < 0 then -1 else if res > 0 then 1 else lexcmp ~cmp xs ys - - let diff ?cmp ?(eq=(=)) ?many xs ys = fold_left (fun xs y -> delete ?cmp ~eq ?many y xs) xs ys - - (* - let union ?cmp ?(eq=(=)) xs ys = append xs (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs) - *) - - let union ?cmp ?(eq=(=)) ys xs = append (fold_left (fun ys x -> delete ?cmp ~eq x ys) ys xs) xs - - let intersect ?cmp ?(eq=(=)) xs ys = - let rec aux_all eq ws zs xs ys = match xs,ys with - | _,[] -> rev1 [] zs - | [],y::ys' -> aux_all eq [] zs (* don't need to reverse ws *) ws ys' - | x::xs',y::ys' -> if eq x y then aux_all eq [] (y::zs) (rev1 xs' ws) ys' else aux_all eq (x::ws) zs xs' ys in - let rec aux_sorted cmp zs xs ys = match xs,ys with - | [],_ | _,[] -> rev1 [] zs - | x::xs',y::ys' -> let res = cmp x y in if res < 0 then aux_sorted cmp zs xs' ys else if res > 0 then aux_sorted cmp zs xs ys' else aux_sorted cmp (y::zs) xs' ys' in - match cmp with - | None -> aux_all eq [] [] xs ys - | Some cmp -> aux_sorted cmp [] xs ys - - let merge ?(cmp=compare) xs ys = - let rec aux cmp zs xs ys = match xs, ys with - | [],ys -> rev1 ys zs - | xs,[] -> rev1 xs zs - | x'::xs',y'::ys' -> if cmp x' y' <= 0 then aux cmp (x'::zs) xs' ys else aux cmp (y'::zs) xs ys' in - aux cmp [] xs ys - - (* - "Natural" or "adaptive" bottom-up merge sort, inspired by http://www.drmaciver.com/tag/timsort/. - - Optimized to exploit existing runs of ascending/descending elements, to consume at most O(log n) levels of its working stack, - and to be mostly tail-recursive, while minimizing how often sorted and merged runs need to be reversed. - - Sort is stable, and has O(n log n) avg and worst-case behavior. - (Compare to naive mergesort on random data, also to C-implemented qsort, which isn't stable?) - - Will delete (later occurrences of) any duplicates, unless invoked with ~many. - - Copyright (c) 2012, 2015 by Dubiousjim . - See license at https://github.com/dubiousjim/unspoiled/blob/master/LICENSE - *) - - let sort ?(cmp=compare) ?many ?rev xs = - let rec merge uniq cmp wasc yy zz ws wn = - assert (wasc <> 0); match yy,zz with - | us,[] | [],us -> rev1 ws us, wn, -wasc - | y::ys,z::zs -> let res = cmp y z in - if uniq && res = 0 then (assert (wn<>1); merge uniq cmp wasc ys zz ws (if wn = 0 then 0 else wn - 1)) - else if (wasc < 0) = (res < 0) then merge uniq cmp wasc ys zz (y::ws) wn else merge uniq cmp wasc yy zs (z::ws) wn in - let rec merge1 uniq cmp ys yn yasc zss = match zss with - | [] -> None - | (z::zs' as zs,zn,zasc)::zss as orig -> (match ys with - | [] -> assert false - | y::ys' -> - (* yn = 0 forces collapse of stack *) - if yn > 0 && yn*2 <= zn then None - else let wn = if yn > 0 then yn + zn else 0 in - if yasc = 0 then (assert (yn <= 1); merge2 uniq cmp zss (merge uniq cmp zasc ys zs [] wn)) - else let res = cmp y z in - let () = assert (yn <> 1) in - if uniq && res = 0 then (if yn = 1 then merge2 uniq cmp zss (zs,zn,zasc) else merge1 uniq cmp ys' (if yn = 0 then 0 else yn - 1) yasc orig) - else if yasc < 0 && zasc > 0 && res >= 0 then merge2 uniq cmp zss (rev1 zs ys, wn, 1) - else if yasc > 0 && zasc < 0 && res < 0 then merge2 uniq cmp zss (rev1 ys zs, wn, 1) - else let wasc,ys,zs = if (yasc < 0) = (zasc < 0) then zasc, ys, zs else if zn < yn then yasc, ys, rev1 [] zs else zasc, rev1 [] ys, zs in - merge2 uniq cmp zss (merge uniq cmp wasc ys zs [] wn)) - | _ -> assert false - and merge2 uniq cmp zss (ws,wn,wasc) = - let more = merge1 uniq cmp ws wn wasc zss in - match more with None -> Some ((ws,wn,wasc)::zss) | _ -> more in - (* yasc = -1 when a segment of the original list was strictly descending, +1 when it was non-descending, 0 when the segment is only 1 member long *) - let rec step uniq cmp xs y ys yn yasc zss = - match xs with - | (x::xs) -> - let res = cmp x y in - if uniq && res = 0 then step uniq cmp xs y ys yn yasc zss - else if yn = 1 then step uniq cmp xs x (y::ys) 2 (if res < 0 then -1 else 1) zss - else (assert (yasc <> 0); if (yasc < 0) = (res < 0) then step uniq cmp xs x (y::ys) (yn+1) yasc zss - else step uniq cmp xs x [] 1 0 (match merge1 uniq cmp (y::ys) yn yasc zss with None -> (y::ys,yn,yasc)::zss | Some zss -> zss)) - | [] -> (* finished stepping through original list, use yn = 0 to force merge1 until completion *) - (match merge1 uniq cmp (y::ys) 0 yasc zss with - | Some [(ys,0,yasc)] -> if yasc > 0 then rev1 [] ys else ys - | None -> if yasc > 0 then rev1 [y] ys else y::ys - | _ -> assert false) in - match many,rev,xs with - | _,_,[] | _,_,[_] -> xs - | None,None,x::xs -> step true cmp xs x [] 1 0 [] - | Some _,None,x::xs -> step false cmp xs x [] 1 0 [] - | None,Some _,x::xs -> step true (fun x y -> -cmp x y) xs x [] 1 0 [] - | Some _,Some _,x::xs -> step false (fun x y -> -cmp x y) xs x [] 1 0 [] - - let is_sorted ?(cmp=compare) ?many ?rev xs = - let rec aux cmp thresh y = function - | [] -> true - | x::xs -> cmp y x < thresh && aux cmp thresh x xs in - match rev,xs with - | _,[] | _,[_] -> true - | None,x::xs -> aux cmp (match many with None -> 0 | Some _ -> 1) x xs - | Some _,x::xs -> aux (fun x y -> -cmp x y) (match many with None -> 0 | Some _ -> 1) x xs - - - let string_of_list ?(brackets=true) ?(sep=";") f xs = - let rec aux sep' = function [] -> if brackets then "]" else "" | x::xs -> sep' ^ f x ^ aux sep xs in - (if brackets then "[" else "") ^ aux "" xs - - let histogram ?(eq=(=)) xs = fold_left (fun h x -> modify_assoc x (fun _ n -> n+1) ~missing:(fun _ -> 1) ~eq h) [] xs - - let pairwise ?missing xs = - let rec aux missing x = function - | [] -> (match missing with None -> [] | Some y -> [(x,y)]) - | y::ys -> (x,y)::aux missing y ys in - match xs with - | [] -> [] - | x::xs -> aux missing x xs - - let rec round_robin xss = - let rec aux ws ys = function - | [] -> (match ys with [] -> rev1 [] ws | _ -> aux ws [] (rev1 [] ys)) - | []::xss -> aux ws ys xss - | (x::xs)::xss -> aux (x::ws) (xs::ys) xss in - match xss with - | [] -> raise Short_list - | []::xss -> round_robin xss - | xss -> aux [] [] xss - - let rec chunk n xs = match split n xs with - | ys,[] -> [ys] - | ys,zs -> ys::chunk n zs - - let rec chunk' n xs = match split' n xs with - | ys,[] -> [ys] - | ys,zs -> ys::chunk' n zs - - let chunk_int n xs = - let rec aux n = function - | _ when n = 0 -> [[]] - | [] -> [] - | x::xs as orig -> if x > n then aux n xs else map ~onto:(aux n xs) (cons x) (aux (n-x) orig) in - let xs = sort ~many xs in - match sort xs with x::_ as xs when x > 0 && n > 0 -> aux n (rev1 [] xs) | _ -> invalid_arg "chunk_int" - - let chunk_range sizes = - let rec combs2 k = function - | xs when k = 0 -> [([],xs)] - | [] -> [] - | x::xs -> map (fun (cs,zs) -> x::cs,zs) (combs2 (k-1) xs) ~onto:(map (fun (cs,zs) -> cs,x::zs) (combs2 k xs)) in - let rec p xs = function - | [] -> [[]] - | k::ks -> catmap (fun (cs,zs) -> map (cons cs) (p zs ks)) (combs2 k xs) in - if exists (fun x -> x<0) sizes then invalid_arg "chunk_range" else p (range_until 0 (sum sizes)) sizes - - end (* List *) - - let short = List.short - let many = List.many - exception Short_list = List.Short_list - - let is_null = List.is_null - let length = List.length - let cons = List.cons - let snoc = List.snoc - let singleton = List.singleton - let head = List.head - let opthead = List.opthead - let tail = List.tail - let tail' = List.tail' - let uncons = List.uncons - let append = List.append - let concat = List.concat - let rev = List.rev - let zip = List.zip - let unzip = List.unzip - let iter = List.iter - let iteri = List.iteri - let iter2 = List.iter2 - let fold_left = List.fold_left - let fold_left1 = List.fold_left1 - let fold_left2 = List.fold_left2 - let fold_right = List.fold_right - let fold_right1 = List.fold_right1 - let fold_right2 = List.fold_right2 - let for_all = List.for_all - let exists = List.exists - let for_all2 = List.for_all2 - let exists2 = List.exists2 - let sum = List.sum - let product = List.product - let take = List.take - let take' = List.take' - let drop = List.drop - let drop' = List.drop' - let split = List.split - let split' = List.split' - let nth = List.nth - -(* - count - make - last - init - init' - mem - map - map2 - unmap2 - mapi - optmap - optmapi - catmap - catmapi - maximum - minimum - maxby - minby - modify - optmodify - catmodify - take_while - drop_while - split_while - find - optfind - findx - index - remove - delete - pick - pickx - filter - filterx - indices - partition - partitionx - assoc - mem_assoc - modify_assoc - optmodify_assoc - remove_assoc - memq - indexq - deleteq - indicesq - assq - mem_assq - modify_assq - optmodify_assq - remove_assq - rotate - unfold - mapz - group - cross - insert - select - range - range_until - unique - is_unique - transpose - permutations - sublists - is_sublist - is_subset - is_eqset - lexcmp - diff - union - intersect - merge - sort - is_sorted - string_of_list - histogram - pairwise - round_robin - chunk - chunk' - chunk_int - chunk_range -*) - - let factorial n = let rec aux m = function 0 -> m | 1 -> m | n -> aux (n*m) (n-1) in aux 1 n - - (* good to around n = 28; naive version overflows after n = 20 *) - let choose n k = let j = max k (n-k) in if j = n then 1 else List.fold_left (/) (List.product (List.range_until n j)) (List.range_until (n-j) 1) - - module Random : sig - val init : ?seed:int -> unit -> unit - val bool : unit -> bool - (* start <= result < stop *) - val between : int -> int -> int - val nth : 'a list -> 'a - val pick : 'a list -> 'a * 'a list - (* k dice rolls are `permutation ~len:k ~many [1..6]` *) - val permutation : ?len:int -> ?many:'b -> 'a list -> 'a list - (* choose k elements from xs, in stable order, ~many with replacment *) - val sublist : len:int -> ?many:'b -> 'a list -> 'a list - end = struct - - let init ?seed () = - match seed with - | None -> Std.Random.self_init() - | Some n -> Std.Random.init n - - let bool = Std.Random.bool - - let between start stop = Std.Random.int (stop-start) + start - - let nth xs = match List.length xs with - | 0 -> invalid_arg "Random.nth" - | n -> List.nth xs (between 0 n) - - let pick xs = - let rec aux n ws = function - | x::xs -> if n = 0 then x, List.rev ~onto:xs ws else aux (n-1) (x::ws) xs - | [] -> assert false in - match List.length xs with - | 0 -> invalid_arg "Random.pick" - | n -> aux (between 0 n) [] xs - - let permutation ?len ?many xs = - (* a[j],a[n] = x,a[j] *) - let array_push a j n x = if j = n then a.(n) <- x else let y = a.(j) in (a.(j) <- x; a.(n) <- y) in - (* return,a[j] = a[j],a[n] *) - let array_pop a j n = let y = a.(n-1) in if j = n - 1 then y else (let x = a.(j) in a.(j) <- y; x) in - let rec aux_all a n = function - (* Based on https://en.wikipedia.org/wiki/Fisher-Yates_shuffle#The_.22inside-out.22_algorithm - Initialize empty array to shuffled copy of xs *) - | [] -> Array.to_list a - | x::xs -> let j = between 0 (n+1) in (array_push a j n x; aux_all a (n+1) xs) in - let rec aux_fixed k n a ws = function - | 0 -> ws - | i -> let j = between 0 n in let w = array_pop a j n in aux_fixed k (n-1) a (w::ws) (i-1) in - match len,many,xs with - | None,_,[] -> [] - | Some k,_,[] -> if k = 0 then [] else invalid_arg "Random.permutation" - | None,None,x::_ -> aux_all (Array.make (List.length xs) x) 0 xs - | Some k,None,_ -> if k < 0 then invalid_arg "Random.permutation" else aux_fixed k (List.length xs) (Array.of_list xs) [] k - | Some k,Some _,_ -> if k < 0 then invalid_arg "Random.permutation" else iterate k (fun ys -> nth xs::ys) [] - | None,Some _,_ -> invalid_arg "Random.permutation ~many requires ~len" - - let sublist ~len:k ?many xs = - let rec aux_fixed ws n k = function - | _ when k = 0 -> List.rev ws - | (x::xs) -> - (* Explanation of the threshhold: There are n choose k many combinations, yes=(n-1) choose (k-1) headed by element x and no=(n-1) choose k not. - So x has yes/(yes+no) chance of occupying initial slot, else it occupies none of the slots. yes/(yes+no) reduces to k/n. *) - if between 0 n < k then aux_fixed (x::ws) (n-1) (k-1) xs else aux_fixed ws (n-1) k xs - | _ -> assert false in - let rec aux_replacing k top ws = function - | _ when k = 0 -> List.rev ws - | [] -> [] (* will only happen when xs was [] to start with *) - | x::xs as orig -> - (* Explanation of the threshhold: There are n+k-1 choose k many combinations with replacement, yes=(n+k-2) choose (k-1) headed by element x and no=(n+k-2) choose k not. - So x has yes/(yes+no) chance of occupying the initial slot, and also possibly some later slots. This reduces to k/(k+n-1). *) - if between 0 (k+top) < k then aux_replacing (k-1) top (x::ws) orig else aux_replacing k (top-1) ws xs in - let n = List.length xs in - if k < 0 || k > n then invalid_arg "Random.sublist" - else match many with - | None -> aux_fixed [] n k xs - | Some _ -> aux_replacing k (n-1) [] xs - - end (* Random *) - - (* #load "Str.cma";; *) - module String : sig - type t = string - val compare : 'a -> 'a -> int - val length : string -> int - val take : int -> ?rev:'a -> string -> string - val drop : int -> string -> string - val sub : string -> int -> len:int -> string - val is_prefix : string -> string -> bool - val is_suffix : string -> string -> bool - val is_infix : string -> string -> bool - val find : string -> ?rev:'a -> ?from:int -> string -> int - val nth : string -> int -> char - val make : int -> char -> string - val mem : char -> ?rev:'a -> ?from:int -> string -> bool - val index : ?rev:'a -> ?from:int -> char -> string -> int - val upper : string -> string - val lower : string -> string - val int_of_char : char -> int - val char_of_int : int -> char - (* trim only removes up to 1 leading/trailing occurrence of pat *) - val trim : string -> string - type pat = string - val split : string -> ?n:int -> ?trim:'a -> pat -> string list - val join : sep:string -> string list -> string - val lines : ?trim:'a -> string -> string list (* as in Haskell, gobbles up to 1 \n per line *) - val words : string -> string list - val unlines : string list -> string (* as in Haskell, does add a trailing \n *) - val unwords : string list -> string (* as in Haskell, no trailing space *) - end = struct - type t = string - let compare = compare - let length = Std.String.length - let take n ?rev s = match rev with - | None -> Str.string_before s n - | Some _ -> Str.last_chars s n - let drop n s = Str.string_after s n - let sub s start ~len = Std.String.sub s start len - let is_prefix (sought : string) s = let n = length sought in length s >= n && take n s = sought - let is_suffix (sought : string) s = let n = length sought in length s >= n && take n ~rev:() s = sought - let is_infix (sought : string) s = length sought <= length s && try Str.(search_forward (regexp_string sought) s 0) >= 0 with Not_found -> false - let find (sought : string) ?rev ?from s = match rev,from with - | None,None -> Str.(search_forward (regexp_string sought) s 0) - | None,Some n -> Str.(search_forward (regexp_string sought) s n) - | Some _,Some n -> Str.(search_backward (regexp_string sought) s n) - | Some _,None -> let n = length s - length sought in if n < 0 then raise Not_found else Str.(search_backward (regexp_string sought) s n) - let nth s n = Std.String.get s n - let make n c = Std.String.make n c - let mem (sought : char) ?rev ?from s = match rev,from with - | None,None -> Std.String.contains s sought - | None,Some n -> Std.String.contains_from s n sought - | Some _,Some n -> Std.String.rcontains_from s n sought - | Some _,None -> invalid_arg "String.mem ~rev requires ~from" - let index ?rev ?from (sought : char) s = match rev,from with - | None,None -> Std.String.index s sought - | Some _,None -> Std.String.rindex s sought - | None,Some n -> Std.String.index_from s n sought - | Some _,Some n -> Std.String.rindex_from s n sought - let upper s = Std.String.uppercase s - let lower s = Std.String.lowercase s - let int_of_char (c : char) = Std.Char.code c - let char_of_int (n : int) = Std.Char.chr n - let trim s = Std.String.trim s - type pat = string - let split s ?n ?trim pat = match n,trim with - | None,Some _ -> Str.(split (regexp pat) s) - | Some n,Some _ -> Str.(bounded_split (regexp pat) s n) - | None,None -> Str.(split_delim (regexp pat) s) - | Some n,None -> Str.(bounded_split_delim (regexp pat) s n) - let join ~sep ss = Std.String.concat sep ss - let lines ?trim s = split ("\n"^s) ~trim "\n" - let words s = split s ~trim "[ \t\n]+" - let unlines ss = join "\n" ss ^ "\n" - let unwords ss = join " " ss - end (* String *) - -end (* Juli8 *) - -open Juli8 - -#use "monad.ml" diff --git a/code/monad.ml b/code/monad.ml deleted file mode 100644 index f17d953b..00000000 --- a/code/monad.ml +++ /dev/null @@ -1,1186 +0,0 @@ -(* This version from 1 April 2015 *) - -module Monad = struct - - module type MAPPABLE = sig - type 'a t - val map : ('a -> 'b) -> 'a t -> 'b t - (* mapconst is definable as map % const. For example mapconst 4 [1,2,3] == [4,4,4]. Haskell calls mapconst <$ in Data.Functor and Control.Applicative. They also use $> for flip mapconst, and Control.Monad.void for mapconst (). *) - end - - module type APPLICATIVE = sig - include MAPPABLE - val mid : 'a -> 'a t - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - val mapply : ('a -> 'b) t -> 'a t -> 'b t - val (>>) : 'a t -> 'b t -> 'b t - val (<<) : 'a t -> 'b t -> 'a t - end - - module type MONAD = sig - include APPLICATIVE - type 'a result - val run : 'a t -> 'a result - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t) - val (<=<) : ('b -> 'c t) -> ('a -> 'b t) -> ('a -> 'c t) - val join : 'a t t -> 'a t - val ignore : 'a t -> unit t - val seq : 'a t list -> 'a list t - val seq_ignore : unit t list -> unit t - val do_when : bool -> unit t -> unit t - val do_unless : bool -> unit t -> unit t - end - - module type MONADT = sig - type 'a ut - include MONAD - val hoist : 'a ut -> 'a t - end - - module type ZERO = sig - type 'a t - (* mzero is a value of type α that is exemplified by Nothing for the box type Maybe α and by [] for the box type List α. It has the behavior that anything ¢ mzero == mzero == mzero ¢ anything == mzero >>= anything. In Haskell, this notion is called Control.Applicative.empty or Control.Monad.mzero. *) - val mzero : 'a t - val guard : bool -> unit t - end - - module type MONADZERO = sig - include MONAD - include ZERO with type 'a t := 'a t - end - - module type MONADZEROT = sig - include MONADT - include ZERO with type 'a t := 'a t - end - - module type MAPPABLE2 = sig - type ('a,'d) t - val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t - end - - module type APPLICATIVE2 = sig - include MAPPABLE2 - val mid : 'a -> ('a,'d) t - val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t - val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t - val (>>) : ('a,'d) t -> ('b,'d) t -> ('b,'d) t - val (<<) : ('a,'d) t -> ('b,'d) t -> ('a,'d) t - end - - module type MONAD2 = sig - include APPLICATIVE2 - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t - val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t) - val (<=<) : ('b -> ('c,'d) t) -> ('a -> ('b,'d) t) -> ('a -> ('c,'d) t) - val join : (('a,'d) t,'d) t -> ('a,'d) t - val ignore : ('a,'d) t -> (unit,'d) t - val seq : ('a,'d) t list -> ('a list,'d) t - val seq_ignore : (unit,'d) t list -> (unit,'d) t - val do_when : bool -> (unit,'d) t -> (unit,'d) t - val do_unless : bool -> (unit,'d) t -> (unit,'d) t - end - - module type MONAD2T = sig - include MONAD2 - type ('a,'d) ut - val hoist : ('a,'d) ut -> ('a,'d) t - end - - module type MONADZERO2 = sig - include MONAD2 - val mzero : ('a,'d) t - val guard : bool -> (unit,'d) t - end - - module type MONADZERO2T = sig - include MONADZERO2 - type ('a,'d) ut - val hoist : ('a,'d) ut -> ('a,'d) t - end - - module Make = struct - - module type MAP2 = sig - type 'a t - val mid : 'a -> 'a t - val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t - val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t] - val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t] - end - - module type MAPPLY = sig - type 'a t - val mid : 'a -> 'a t - val mapply : ('a -> 'b) t -> 'a t -> 'b t - val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t] - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t] - end - - module type BIND = sig - type 'a t - type 'a result - val run : 'a t -> 'a result - val mid : 'a -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t] - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t] - val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t] - end - - module type COMP = sig - type 'a t - type 'a result - val run : 'a t -> 'a result - val mid : 'a -> 'a t - val (>=>) : ('a -> 'b t) -> ('b -> 'c t) -> ('a -> 'c t) - val map : [`Generate | `Custom of ('a -> 'b) -> 'a t -> 'b t] - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t] - val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t] - end - - module type JOIN = sig - type 'a t - type 'a result - val run : 'a t -> 'a result - val mid : 'a -> 'a t - val join : 'a t t -> 'a t - val map : ('a -> 'b) -> 'a t -> 'b t - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t] - val mapply : [`Generate | `Custom of ('a -> 'b) t -> 'a t -> 'b t] - end - - module type TRANS = sig - module U : MONAD - type 'a t - type 'a result - val run : 'a t -> 'a result - (* Provide hoist, >>=; LAWS: 1. hoist U.(mid x) == mid x; 2. hoist U.(uu >>= k) == hoist uu >>= fun u -> hoist (k u) *) - val hoist : 'a U.t -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - end - - module type TRANSUZ = sig - module U : MONADZERO - type 'a t - type 'a result - val run : 'a t -> 'a result - val hoist : 'a U.t -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - end - - module type TRANSZ = sig - module U : MONAD - type 'a t - type 'a result - val run : 'a t -> 'a result - val hoist : 'a U.t -> 'a t - val (>>=) : 'a t -> ('a -> 'b t) -> 'b t - val mzero : 'a t - end - - module ApplicativeFromBind(B : BIND) : APPLICATIVE with type 'a t = 'a B.t = struct - type 'a t = 'a B.t - let mid = B.mid - let (>>=) = B.(>>=) - let map = match B.map with - | `Custom map -> map - | `Generate -> fun f xx -> xx >>= fun x -> mid (f x) - let map2 = match B.map2 with - | `Custom map2 -> map2 - | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y) - let mapply = match B.map2 with - | `Custom map2 -> fun eta -> map2 ident eta - | `Generate -> fun ff xx -> ff >>= fun f -> map f xx - let (>>) xx yy = xx >>= fun _ -> yy - let (<<) xx yy = mapply (map const xx) yy - end - - module ApplicativeFromMap2(B : MAP2) : APPLICATIVE with type 'a t = 'a B.t = struct - type 'a t = 'a B.t - let mid = B.mid - let map2 = B.map2 - let mapply = match B.mapply with - | `Custom mapply -> mapply - | `Generate -> fun eta -> map2 ident eta - let map = match B.map with - | `Custom map -> map - | `Generate -> fun f xx -> mapply (mid f) xx - let (>>) xx yy = mapply (map (const ident) xx) yy - let (<<) xx yy = mapply (map const xx) yy - end - - module ApplicativeFromApply(B : MAPPLY) : APPLICATIVE with type 'a t = 'a B.t = struct - type 'a t = 'a B.t - let mid = B.mid - let mapply = B.mapply - let map = match B.map with - | `Custom map -> map - | `Generate -> fun f xx -> mapply (mid f) xx - let map2 = match B.map2 with - | `Custom map2 -> map2 - | `Generate -> fun f xx yy -> mapply (map f xx) yy - let (>>) xx yy = mapply (map (const ident) xx) yy - let (<<) xx yy = mapply (map const xx) yy - end - - module MonadFromBind(B : BIND) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct - let (>>=) = B.(>>=) - include ApplicativeFromBind(B) - type 'a result = 'a B.result - let run = B.run - let (>=>) j k = fun a -> j a >>= k - let (<=<) k j = fun a -> j a >>= k - let join xxx = xxx >>= ident - let ignore xx = map (fun _ -> ()) xx - (* seq xxs = let f xx zzf = (xx >>=) . flip ((zzf.).(:)) in foldr f (return $) xxs [] *) - (* - foldr' f z xs = foldl (\g x z -> g (f x z)) id xs z -- foldr but evaluating from left? - foldl'' f z xs = foldr (\x g z -> g (f z x)) id xs z -- foldl but evaluating from right? these don't work - -- with foldr, evaluates left->right; with foldl the reverse - seq xxs = - let f c xx ret xs = xx >>= ret . c xs in -- careful! isn't fmap (c xs) xx because ret isn't (always) return - reverse <$> foldr (f $ flip (:)) return xxs [] - -- or simply: foldr (f snoc) return xxs [] - *) - let seq = - let rec aux xs = function - | [] -> mid (List.rev xs) - | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in - fun xxs -> aux [] xxs - let rec seq_ignore = function - | [] -> mid () - | xx::xxs -> xx >>= fun () -> seq_ignore xxs - let do_when res xx = if res then xx else mid () - let do_unless res xx = if res then mid () else xx - end - - module MonadFromComp(B : COMP) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct - let (>=>) = B.(>=>) - let (<=<) k j = j >=> k - let (>>=) xx k = (ident >=> k) xx - include ApplicativeFromBind(struct include B let (>>=) = (>>=) end) - type 'a result = 'a B.result - let run = B.run - let join xxx = xxx >>= ident - let ignore xx = map (fun _ -> ()) xx - let seq = - let rec aux xs = function - | [] -> mid (List.rev xs) - | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in - fun xxs -> aux [] xxs - let rec seq_ignore = function - | [] -> mid () - | xx::xxs -> xx >>= fun () -> seq_ignore xxs - let do_when res xx = if res then xx else mid () - let do_unless res xx = if res then mid () else xx - end - - module MonadFromJoin(B : JOIN) : MONAD with type 'a t = 'a B.t and type 'a result = 'a B.result = struct - let join = B.join - let (>>=) xx k = join (B.map k xx) - include ApplicativeFromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end) - type 'a result = 'a B.result - let run = B.run - let (>=>) j k = fun a -> j a >>= k - let (<=<) k j = fun a -> j a >>= k - let ignore xx = map (fun _ -> ()) xx - let seq = - let rec aux xs = function - | [] -> mid (List.rev xs) - | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in - fun xxs -> aux [] xxs - let rec seq_ignore = function - | [] -> mid () - | xx::xxs -> xx >>= fun () -> seq_ignore xxs - let do_when res xx = if res then xx else mid () - let do_unless res xx = if res then mid () else xx - end - - module MonadFromT(B : TRANS) : MONADT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct - include MonadFromBind(struct - include B - let mid x = hoist U.(mid x) - let map = `Generate let map2 = `Generate let mapply = `Generate - end) - let hoist = B.hoist - end - - module MonadFromTUZ(B : TRANSUZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct - let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *) - include MonadFromBind(struct - include B - let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero - let mid x = hoist U.(mid x) - let map = `Generate let map2 = `Generate let mapply = `Generate - end) - let hoist = B.hoist - let guard res = if res then mid () else mzero - end - - module MonadFromTZ(B : TRANSZ) : MONADZEROT with type 'a t = 'a B.t and type 'a result = 'a B.result and type 'a ut := 'a B.U.t = struct - include MonadFromBind(struct - include B - let (>>=) xx k = xx >>= fun x -> try k x with Match_failure _ -> mzero - let mid x = hoist U.(mid x) - let map = `Generate let map2 = `Generate let mapply = `Generate - end) - let hoist = B.hoist - let mzero = B.mzero - let guard res = if res then mid () else mzero - end - - module type BIND2 = sig - type ('a,'d) t - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val mid : 'a -> ('a,'d) t - val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t - val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t] - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t] - val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t] - end - - module type COMP2 = sig - type ('a,'d) t - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val mid : 'a -> ('a,'d) t - val (>=>) : ('a -> ('b,'d) t) -> ('b -> ('c,'d) t) -> ('a -> ('c,'d) t) - val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t] - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t] - val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t] - end - - module type JOIN2 = sig - type ('a,'d) t - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val mid : 'a -> ('a,'d) t - val join : (('a,'d) t,'d) t -> ('a,'d) t - val map : ('a -> 'b) -> ('a,'d) t -> ('b,'d) t - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t] - val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t] - end - - module type TRANS2 = sig - module U : MONAD2 - type ('a,'d) t - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t - val hoist : ('a,'d) U.t -> ('a,'d) t - end - - module type TRANSUZ2 = sig - module U : MONADZERO2 - type ('a,'d) t - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t - val hoist : ('a,'d) U.t -> ('a,'d) t - end - - module type TRANSZ2 = sig - module U : MONAD2 - type ('a,'d) t - type ('a,'d) result - val run : ('a,'d) t -> ('a,'d) result - val (>>=) : ('a,'d) t -> ('a -> ('b,'d) t) -> ('b,'d) t - val hoist : ('a,'d) U.t -> ('a,'d) t - val mzero : ('a,'d) t - end - - module type MAP22 = sig - type ('a,'d) t - val mid : 'a -> ('a,'d) t - val map2 : ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t - val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t] - val mapply : [`Generate | `Custom of ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t] - end - - module type MAPPLY2 = sig - type ('a,'d) t - val mid : 'a -> ('a,'d) t - val mapply : ('a -> 'b,'d) t -> ('a,'d) t -> ('b,'d) t - val map : [`Generate | `Custom of ('a -> 'b) -> ('a,'d) t -> ('b,'d) t] - val map2 : [`Generate | `Custom of ('a -> 'b -> 'c) -> ('a,'d) t -> ('b,'d) t -> ('c,'d) t] - end - - module Applicative2FromBind(B : BIND2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct - type ('a,'d) t = ('a,'d) B.t - let mid = B.mid - let (>>=) = B.(>>=) - let map = match B.map with - | `Custom map -> map - | `Generate -> fun f xx -> xx >>= fun x -> mid (f x) - let map2 = match B.map2 with - | `Custom map2 -> map2 - | `Generate -> fun f xx yy -> xx >>= fun x -> yy >>= fun y -> mid (f x y) - let mapply = match B.map2 with - | `Custom map2 -> fun eta -> map2 ident eta - | `Generate -> fun ff xx -> ff >>= fun f -> map f xx - let (>>) xx yy = xx >>= fun _ -> yy - let (<<) xx yy = mapply (map const xx) yy - end - - module Applicative2FromMap2(B : MAP22) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct - type ('a,'d) t = ('a,'d) B.t - let mid = B.mid - let map2 = B.map2 - let mapply = match B.mapply with - | `Custom mapply -> mapply - | `Generate -> fun eta -> map2 ident eta - let map = match B.map with - | `Custom map -> map - | `Generate -> fun f xx -> mapply (mid f) xx - let (>>) xx yy = mapply (map (const ident) xx) yy - let (<<) xx yy = mapply (map const xx) yy - end - - module Applicative2FromApply(B : MAPPLY2) : APPLICATIVE2 with type ('a,'d) t = ('a,'d) B.t = struct - type ('a,'d) t = ('a,'d) B.t - let mid = B.mid - let mapply = B.mapply - let map = match B.map with - | `Custom map -> map - | `Generate -> fun f xx -> mapply (mid f) xx - let map2 = match B.map2 with - | `Custom map2 -> map2 - | `Generate -> fun f xx yy -> mapply (map f xx) yy - let (>>) xx yy = mapply (map (const ident) xx) yy - let (<<) xx yy = mapply (map const xx) yy - end - - module Monad2FromBind(B : BIND2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct - let (>>=) = B.(>>=) - include Applicative2FromBind(B) - type ('a,'d) result = ('a,'d) B.result - let run = B.run - let (>=>) j k = fun a -> j a >>= k - let (<=<) k j = fun a -> j a >>= k - let join xxx = xxx >>= ident - let ignore xx = map (fun _ -> ()) xx - let seq = - let rec aux xs = function - | [] -> mid (List.rev xs) - | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in - fun xxs -> aux [] xxs - let rec seq_ignore = function - | [] -> mid () - | xx::xxs -> xx >>= fun () -> seq_ignore xxs - let do_when res xx = if res then xx else mid () - let do_unless res xx = if res then mid () else xx - end - - module Monad2FromComp(B : COMP2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct - let (>=>) = B.(>=>) - let (<=<) k j = j >=> k - let (>>=) xx k = (ident >=> k) xx - include Applicative2FromBind(struct include B let (>>=) = (>>=) end) - type ('a,'d) result = ('a,'d) B.result - let run = B.run - let join xxx = xxx >>= ident - let ignore xx = map (fun _ -> ()) xx - let seq = - let rec aux xs = function - | [] -> mid (List.rev xs) - | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in - fun xxs -> aux [] xxs - let rec seq_ignore = function - | [] -> mid () - | xx::xxs -> xx >>= fun () -> seq_ignore xxs - let do_when res xx = if res then xx else mid () - let do_unless res xx = if res then mid () else xx - end - - module Monad2FromJoin(B : JOIN2) : MONAD2 with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) result = ('a,'d) B.result = struct - let join = B.join - let (>>=) xx k = join (B.map k xx) - include Applicative2FromBind(struct include B let (>>=) = (>>=) let map = `Custom B.map end) - type ('a,'d) result = ('a,'d) B.result - let run = B.run - let (>=>) j k = fun a -> j a >>= k - let (<=<) k j = fun a -> j a >>= k - let ignore xx = map (fun _ -> ()) xx - let seq = - let rec aux xs = function - | [] -> mid (List.rev xs) - | xx::xxs -> xx >>= fun x -> aux (x::xs) xxs in - fun xxs -> aux [] xxs - let rec seq_ignore = function - | [] -> mid () - | xx::xxs -> xx >>= fun () -> seq_ignore xxs - let do_when res xx = if res then xx else mid () - let do_unless res xx = if res then mid () else xx - end - - module Monad2FromT(B : TRANS2) : MONAD2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct - include Monad2FromBind(struct - include B - let mid x = hoist U.(mid x) - let map = `Generate let map2 = `Generate let mapply = `Generate - end) - let hoist = B.hoist - end - - module Monad2FromTUZ(B : TRANSUZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct - include Monad2FromBind(struct - include B - let mid x = hoist U.(mid x) - let map = `Generate let map2 = `Generate let mapply = `Generate - end) - let hoist = B.hoist - let mzero = Obj.magic (B.hoist (B.U.mzero)) (* Obj.magic hack to generate enough polymorphism without having to thunk mzero *) - let guard res = if res then mid () else mzero - end - - module Monad2FromTZ(B : TRANSZ2) : MONADZERO2T with type ('a,'d) t = ('a,'d) B.t and type ('a,'d) ut := ('a,'d) B.U.t and type ('a,'d) result = ('a,'d) B.result = struct - include Monad2FromBind(struct - include B - let mid x = hoist U.(mid x) - let map = `Generate let map2 = `Generate let mapply = `Generate - end) - let hoist = B.hoist - let mzero = B.mzero - let guard res = if res then mid () else mzero - end - - end (* Make *) - - - module type OPTION = sig - include MONADZERO with type 'a result = 'a option - val test : ('a option -> bool) -> 'a t -> 'a t - end - - module type OPTIONT = sig - type 'a uresult - include MONADT with type 'a result = 'a option uresult - val test : ('a option ut -> bool) -> 'a t -> 'a t - end - - module Option = struct - include Juli8.Option - module type EXTRA = sig - type 'a t - val test : ('a option (* U.t *) -> bool) -> 'a t -> 'a t - end - module type EXTRA2 = sig - type ('a,'d) t - val test : ('a option -> bool) -> ('a,'d) t -> ('a,'d) t - end - module M : OPTION = struct - include Make.MonadFromBind(struct - type 'a t = 'a option - type 'a result = 'a t let run xx = xx - let map = `Custom map let map2 = `Custom map2 let mapply = `Generate - let mid = some - (* val (>>=) : 'a option -> ('a -> 'b option) -> 'b option *) - let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None - end) - let mzero = None - let guard res : unit t = if res then Some () else None - let test p xx = if p xx then xx else None - end (* Option.M *) - module M2 : sig - include MONADZERO2 with type ('a,'d) result = 'a option - include EXTRA2 with type ('a,'d) t := ('a,'d) t - end = struct - include Make.Monad2FromBind(struct - type ('a,'d) t = 'a option - type ('a,'d) result = ('a,'d) t let run xx = xx - let map = `Custom map let map2 = `Custom map2 let mapply = `Generate - let mid = some - let (>>=) xx k = match xx with Some x -> (try k x with Match_failure _ -> None) | None -> None - end) - let mzero = None - let guard res : (unit,'d) t = if res then Some () else None - let test p xx = if p xx then xx else None - end (* Option.M2 *) - module T(U : MONAD) : OPTIONT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromTZ(struct - module U = U - type 'a t = 'a option U.t - type 'a result = 'a option U.result let run xx = U.run xx - let hoist uu = U.(uu >>= fun u -> mid (Some u)) - let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None) - let mzero = Obj.magic U.(mid None) - end) - let test p xx = if p xx then xx else U.mid None - end (* Option.T *) - module T2(U : MONAD2) : sig - include MONADZERO2T with type ('a,'d) result = ('a option, 'd) U.result and type ('a,'d) ut := ('a,'d) U.t - include EXTRA2 with type ('a,'d) t := ('a,'d) t - val test : (('a option,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t - end = struct - include Make.Monad2FromTZ(struct - module U = U - type ('a,'d) t = ('a option,'d) U.t - type ('a,'d) result = ('a option,'d) U.result let run xx = U.run xx - let hoist uu = U.(uu >>= fun u -> mid (Some u)) - let (>>=) xx k = U.(xx >>= function Some x -> k x | None -> mid None) - let mzero = Obj.magic U.(mid None) - end) - let test p xx = if p xx then xx else U.mid None - end (* Option.T2 *) - end (* Option *) - - - module type LIST = sig - include MONADZERO with type 'a result = 'a list - val (++) : 'a t -> 'a t -> 'a t (* monadically append *) - val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *) - val test : ('a list -> bool) -> 'a t -> 'a t - end - - module type LISTT = sig - type 'a uresult - include MONADZEROT with type 'a result = 'a list uresult - val (++) : 'a t -> 'a t -> 'a t (* monadically append *) - val pick : 'a t -> ('a * 'a t) t (* monadically pick each element *) - val test : ('a list ut -> bool) -> 'a t -> 'a t - (* - Monadically seq k over box. - OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running) - ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...] - TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly - *) - val distribute : ('a -> 'b ut) -> 'a list -> 'b t - end - - module List = struct - include Juli8.List - module type EXTRA2 = sig - type ('a,'d) t - val (++) : ('a,'d) t -> ('a,'d) t -> ('a,'d) t - val pick : ('a,'d) t -> ('a * ('a,'d) t,'d) t - val test : ('a list -> bool) -> ('a,'d) t -> ('a,'d) t - end - module M : LIST = struct - include Make.MonadFromBind(struct - type 'a t = 'a list - type 'a result = 'a t let run xx = xx - let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate - let mid = singleton - let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx - end) - let mzero = [] - let guard res : unit t = if res then [()] else [] - (* (++) has tighter precedence than (>>=) *) - let (++) = append - let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys)) - let test p xx = if p xx then xx else [] - end (* List.M *) - module M2 : sig - include MONADZERO2 with type ('a,'d) result = 'a list - include EXTRA2 with type ('a,'d) t := ('a,'d) t - end = struct - include Make.Monad2FromBind(struct - type ('a,'d) t = 'a list - type ('a,'d) result = ('a,'d) t let run xx = xx - let map = `Custom (fun f xs -> map f xs) let map2 = `Custom (fun f xs -> map2 f xs) let mapply = `Generate - let mid = singleton - let (>>=) xx k = catmap (fun x -> try k x with Match_failure _ -> []) xx - end) - let mzero = [] - let guard res : (unit,'d) t = if res then [()] else [] - let (++) = append - let rec pick = function [] -> mzero | x::xs -> mid (x,xs) ++ (pick xs >>= fun (y,ys) -> mid (y, x::ys)) - let test p xx = if p xx then xx else [] - end (* List.M2 *) - module T(U : MONAD) : LISTT with type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - let distribute k xs = U.seq (List.map k xs) - include Make.MonadFromTZ(struct - module U = U - type 'a t = 'a list U.t - type 'a result = 'a list U.result let run xx = U.run xx - let hoist uu = U.(uu >>= fun u -> mid [u]) - let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss)) - let mzero = Obj.magic U.(mid []) - end) - let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys)) - let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys))))) - let test p xx = if p xx then xx else U.mid [] - end (* List.T *) - module T2(U : MONAD2) : sig - include MONADZERO2T with type ('a,'d) result = ('a list,'d) U.result and type ('a,'d) ut := ('a,'d) U.t - include EXTRA2 with type ('a,'d) t := ('a,'d) t - val test : (('a list,'d) U.t -> bool) -> ('a,'d) t -> ('a,'d) t - val distribute : ('a -> ('b,'d) U.t) -> 'a list -> ('b,'d) t - end = struct - let distribute k xs = U.seq (List.map k xs) - include Make.Monad2FromTZ(struct - module U = U - type ('a,'d) t = ('a list,'d) U.t - type ('a,'d) result = ('a list,'d) U.result let run xx = U.run xx - let hoist uu = U.(uu >>= fun u -> mid [u]) - let (>>=) xx k = U.(xx >>= fun xs -> distribute k xs >>= fun xss -> mid (concat xss)) - let mzero = Obj.magic U.(mid []) - end) - let (++) xx yy = U.(xx >>= fun xs -> yy >>= fun ys -> mid (append xs ys)) - let rec pick xx = U.(>>=) xx (function [] -> mzero | x::xs -> mid (x, U.(mid xs)) ++ (pick U.(mid xs) >>= fun (y,yy) -> mid (y, U.(yy >>= fun ys -> mid (x::ys))))) - let test p xx = if p xx then xx else U.mid [] - end (* List.T2 *) - end (* List *) - - - (* LTree, unit centers, has natural ++ *) - (* ITree, unit leaves, has natural mzero *) - - module type TREE = sig - type 'a tree - include MONAD with type 'a result = 'a tree - val (++) : 'a t -> 'a t -> 'a t (* monadically append *) - end - - module type TREET = sig - type 'a tree - type 'a uresult - include MONADT with type 'a result = 'a tree uresult - val (++) : 'a t -> 'a t -> 'a t (* monadically append *) - (* - Monadically seq k over box. - OptionM.seq (List.map (\a -> OptionM.mid $ a+1) int_list) == (after running) - ListOption.distribute (\a -> OptionM.mid $ a+1) int_list == Some [x+1,x+1,...] - TreeOption.distribute (\a -> OptionM.mid $ a+1) int_tree: works similarly - *) - val distribute : ('a -> 'b ut) -> 'a tree -> 'b t - end - - module LTree = struct - type 'a tree = Leaf of 'a | Branch of 'a tree * 'a tree - let branch x y = Branch(x,y) - let leaf x = Leaf x - let traverse ((++) : 'b -> 'b -> 'b) (k : 'a -> 'b) (xt : 'a tree) : 'b = - let rec aux = function - | Leaf x -> k x - | Branch(l, r) -> (* recursive application of k may delete a branch? *) aux l ++ aux r in - aux xt - let map (f : 'a -> 'b) (xt : 'a tree) = - let rec aux = function - | Leaf x -> Leaf (f x) - | Branch(l, r) -> Branch(aux l, aux r) in - aux xt - module M : TREE with type 'a tree := 'a tree = struct - include Make.MonadFromBind(struct - type 'a t = 'a tree - type 'a result = 'a t let run xx = xx - let map = `Custom map let map2 = `Generate let mapply = `Generate - let mid = leaf - let (>>=) xx k = traverse branch k xx - end) - let (++) xx yy = Branch(xx, yy) - end (* Tree.M *) - module T(U : MONAD) : TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - let hoist uu = U.(uu >>= fun u -> mid (Leaf u)) - let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt - include Make.MonadFromT(struct - module U = U - type 'a t = 'a tree U.t - type 'a result = 'a tree U.result let run xx = U.run xx - let hoist = hoist - let join xtt = traverse branch ident xtt - let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt))) - end) - let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt))) - end (* Tree.T *) - module Z(U : MONADZERO) : sig - include TREET with type 'a tree := 'a tree and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a t - end = struct - let hoist uu = U.(uu >>= fun u -> mid (Leaf u)) - let distribute k xt = traverse (U.map2 branch) (fun x -> hoist (k x)) xt - include Make.MonadFromTUZ(struct - module U = U - type 'a t = 'a tree U.t - type 'a result = 'a tree U.result let run xx = U.run xx - let hoist = hoist - let join xtt = traverse branch ident xtt - let (>>=) xx k = U.(>>=) xx (fun xt -> U.(>>=) (distribute k xt) (fun xtt -> U.mid (join xtt))) - end) - let (++) xx yy = U.(xx >>= fun xt -> yy >>= fun yt -> mid (Branch(xt,yt))) - end (* Tree.Z *) - end (* Tree *) - - - module Identity = struct - module M : sig - include MONAD with type 'a result = 'a - end = struct - include Make.MonadFromComp(struct - type 'a t = 'a - type 'a result = 'a t let run xx = xx - let map = `Custom (fun f x -> f x) let map2 = `Custom (fun f x y -> f x y) let mapply = `Custom (fun f x -> f x) - let mid = ident - let (>=>) j k = fun x -> k (j x) - end) - end - end - - - module type READER = sig - type env - include MONAD with type 'a result = env -> 'a - val ask : env t - val asks : (env -> 'a) -> 'a t - val shift : (env -> env) -> 'a t -> 'a t - end - - module type READERT = sig - type env - type 'a uresult - include MONADT with type 'a result = env -> 'a uresult - val ask : env t - val asks : (env -> 'a) -> 'a t - val shift : (env -> env) -> 'a t -> 'a t - end - - (* must be parameterized on `struct type env = ... end` *) - module Reader(E : sig type env end) = struct - type env = E.env - module M : READER with type env := env = struct - include Make.MonadFromBind(struct - type 'a t = env -> 'a - type 'a result = 'a t let run xx = fun e -> xx e - let map = `Generate let map2 = `Generate let mapply = `Generate - let mid x = fun e -> x - let (>>=) xx k = fun e -> let x = xx e in let xx' = k x in xx' e - end) - let ask = fun e -> e - let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *) - let shift modifier xx = fun e -> xx (modifier e) - end (* Reader.M *) - module T(U : MONAD) : READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromT(struct - module U = U - type 'a t = env -> 'a U.t - type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e) - let hoist uu = fun e -> uu - let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e) - end) - let ask = U.mid - let asks selector = ask >>= (fun e -> mid (selector e)) (* may fail with Not_found *) - let shift modifier xx = fun e -> xx (modifier e) - end (* Reader.T *) - module Z(U : MONADZERO) : sig - include READERT with type env := env and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a t - end = struct - include Make.MonadFromTUZ(struct - module U = U - type 'a t = env -> 'a U.t - type 'a result = env -> 'a U.result let run xx = fun e -> U.run (xx e) - let hoist uu = fun e -> uu - let (>>=) xx k = fun e -> U.(xx e >>= fun x -> k x e) - end) - let ask = U.mid - let asks selector = ask >>= (fun e -> try mid (selector e) with Not_found -> mzero) - let shift modifier xx = fun e -> xx (modifier e) - end (* Reader.Z *) - end (* Reader *) - - - module type STATE = sig - type store - include MONAD with type 'a result = store -> 'a * store - val get : store t - val gets : (store -> 'a) -> 'a t - val put : store -> unit t - val modify : (store -> store) -> unit t - end - - module type STATET = sig - type store - type 'a uresult - include MONADT with type 'a result = store -> ('a * store) uresult - val get : store t - val gets : (store -> 'a) -> 'a t - val put : store -> unit t - val modify : (store -> store) -> unit t - end - - (* must be parameterized on `struct type store = ... end` *) - module State(S : sig type store end) = struct - type store = S.store - module M : STATE with type store := store = struct - include Make.MonadFromBind(struct - type 'a t = store -> 'a * store - type 'a result = 'a t let run xx = fun s -> xx s - let map = `Generate let map2 = `Generate let mapply = `Generate - let mid x = fun s -> x, s - let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s' - end) - let get = fun s -> s,s - (* `gets viewer` is `map viewer get` *) - let gets viewer = fun s -> viewer s, s (* may fail with Not_found *) - let put s = fun _ -> (), s - let modify modifier = fun s -> (), modifier s - end (* State.M *) - module T(U : MONAD) : STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromT(struct - module U = U - type 'a t = store -> ('a * store) U.t - type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s) - let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s)) - let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s') - end) - let get = fun s -> U.mid (s,s) - let gets viewer = fun s -> U.mid (viewer s, s) (* may fail with Not_found *) - let put s = fun _ -> U.mid ((), s) - let modify modifier = fun s -> U.mid ((), modifier s) - end (* State.T *) - module Z(U : MONADZERO) : sig - include STATET with type store := store and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a t - end = struct - include Make.MonadFromTUZ(struct - module U = U - type 'a t = store -> ('a * store) U.t - type 'a result = store -> ('a * store) U.result let run xx = fun s -> U.run (xx s) - let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s)) - let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s') - end) - let get = fun s -> U.mid (s,s) - let gets viewer = fun s -> try U.mid (viewer s, s) with Not_found -> mzero s - let put s = fun _ -> U.mid ((), s) - let modify modifier = fun s -> U.mid ((), modifier s) - end (* State.Z *) - end (* State *) - - - module type REF = sig - type ref - type value - include MONAD with type 'a result = 'a - val newref : value -> ref t - val deref : ref -> value t - val change : ref -> value -> unit t - end - - module type REFT = sig - type ref - type value - type 'a uresult - include MONADT with type 'a result = 'a uresult - val newref : value -> ref t - val deref : ref -> value t - val change : ref -> value -> unit t - end - - (* State with a different interface; must be parameterized on `struct type value = ... end` *) - module Ref(V : sig type value end) = struct - type ref = int - type value = V.value - module D = Map.Make(struct type t = ref let compare = compare end) - type dict = { next : ref; tree : value D.t } - let empty = { next = 0; tree = D.empty } - let alloc v d = d.next, { next = succ d.next; tree = D.add d.next v d.tree} - let read (k : ref) d = D.find k d.tree - let write (k : ref) v d = { next = d.next; tree = D.add k v d.tree } - module M : REF with type value := value and type ref := ref = struct - include Make.MonadFromBind(struct - type 'a t = dict -> 'a * dict - type 'a result = 'a let run xx = fst (xx empty) - let map = `Generate let map2 = `Generate let mapply = `Generate - let mid x = fun s -> x, s - let (>>=) xx k = fun s -> let (x,s') = xx s in let xx' = k x in xx' s' - end) - let newref v = fun s -> alloc v s - let deref k = fun s -> read k s, s (* shouldn't fail because k will have an abstract type? and we never GC *) - let change k v = fun s -> (), write k v s (* shouldn't allocate because k will have an abstract type *) - end (* Ref.M *) - module T(U : MONAD) : REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromT(struct - module U = U - type 'a t = dict -> ('a * dict) U.t - type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu - let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s)) - let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s') - end) - let newref v = fun s -> U.mid (alloc v s) - let deref k = fun s -> U.mid (read k s, s) - let change k v = fun s -> U.mid ((), write k v s) - end (* Ref.T *) - module Z(U : MONADZERO) : sig - include REFT with type value := value and type ref := ref and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a t - end = struct - include Make.MonadFromTUZ(struct - module U = U - type 'a t = dict -> ('a * dict) U.t - type 'a result = 'a U.result let run xx = let uu = U.(xx empty >>= fun (x,s) -> mid x) in U.run uu - let hoist uu = fun s -> U.(uu >>= fun u -> mid (u, s)) - let (>>=) xx k = fun s -> U.(xx s >>= fun (x,s') -> k x s') - end) - let newref v = fun s -> U.mid (alloc v s) - let deref k = fun s -> U.mid (read k s, s) - let change k v = fun s -> U.mid ((), write k v s) - end (* Ref.Z *) - end (* Ref *) - - - module type WRITER = sig - type log - include MONAD with type 'a result = 'a * log - val listen : 'a t -> ('a * log) t - val listens : (log -> 'b) -> 'a t -> ('a * 'b) t - val tell : log -> unit t - (* val pass : ('a * (log -> log)) t -> 'a t *) - val censor : (log -> log) -> 'a t -> 'a t - end - - module type WRITERT = sig - type log - type 'a uresult - include MONADT with type 'a result = ('a * log) uresult - val listen : 'a t -> ('a * log) t - val listens : (log -> 'b) -> 'a t -> ('a * 'b) t - val tell : log -> unit t - (* val pass : ('a * (log -> log)) t -> 'a t *) - val censor : (log -> log) -> 'a t -> 'a t - end - - (* must be parameterized on `struct type log = ... end` *) - module Writer(W : sig type log val empty : log val append : log -> log -> log end) = struct - type log = W.log - module M : WRITER with type log := log = struct - include Make.MonadFromBind(struct - type 'a t = 'a * log - type 'a result = 'a t let run xx = xx - let map = `Generate let map2 = `Generate let mapply = `Generate - let mid x = x, W.empty - let (>>=) (x,w) k = let (y,w') = k x in (y, W.append w w') - end) - let listen (x,w) = (x,w), w - let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) (* filter listen through selector *) - let tell entries = (), entries (* add to log *) - let pass ((x,c),w) = (x, c w) (* usually use censor *) - let censor c xx = pass (xx >>= fun x -> mid (x,c)) (* ==> (x, c w) *) - end (* Writer.M *) - module T(U : MONAD) : WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromT(struct - module U = U - type 'a t = ('a * log) U.t - type 'a result = ('a * log) U.result let run xx = U.run xx - let hoist uu = U.(uu >>= fun u -> mid (u, W.empty)) - let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w')) - end) - let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w)) - let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) - let tell entries = U.mid ((), entries) - let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w)) - let censor c xx = pass (xx >>= fun x -> mid (x,c)) - end (* Writer.T *) - module Z(U : MONADZERO) : sig - include WRITERT with type log := log and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a t - end = struct - include Make.MonadFromTUZ(struct - module U = U - type 'a t = ('a * log) U.t - type 'a result = ('a * log) U.result let run xx = U.run xx - let hoist uu = U.(uu >>= fun u -> mid (u, W.empty)) - let (>>=) xx k = U.(xx >>= fun (x,w) -> k x >>= fun (y,w') -> mid (y, W.append w w')) - end) - let listen xx = U.(xx >>= fun (x,w) -> mid ((x,w),w)) - let listens selector xx = listen xx >>= fun (x,w) -> mid (x,selector w) - let tell entries = U.mid ((), entries) - let pass xx = U.(xx >>= fun ((x,c),w) -> mid (x, c w)) - let censor c xx = pass (xx >>= fun x -> mid (x,c)) - end (* Writer.Z *) - end (* Writer *) - - - module type ERROR = sig - type msg - type 'a error - include MONAD with type 'a result = 'a error - val throw : msg -> 'a t - val catch : 'a t -> (msg -> 'a t) -> 'a t - end - - module type ERRORT = sig - type msg - type 'a error - type 'a uresult - include MONADT with type 'a result = 'a uresult (* note the difference from ERROR *) - val throw : msg -> 'a t - val catch : 'a t -> (msg -> 'a t) -> 'a t - end - - (* must be parameterized on `struct type msg = ... end` *) - module Error(E : sig type msg exception Exc of msg (* Exc used only by T *) end) = struct - type msg = E.msg - type 'a error = Error of msg | OK of 'a - module M : ERROR with type msg := msg and type 'a error := 'a error = struct - include Make.MonadFromBind(struct - type 'a t = 'a error - type 'a result = 'a t - (* note that M.run doesn't raise *) - let run xx = xx - let map = `Generate let map2 = `Generate let mapply = `Generate - let mid x = OK x - let (>>=) xx k = match xx with OK x -> k x | Error e -> Error e - end) - let throw e = Error e - let catch xx handler = match xx with OK _ -> xx | Error e -> handler e - end (* Error.M *) - module T(U : MONAD) : ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t = struct - include Make.MonadFromT(struct - module U = U - type 'a t = 'a error U.t - type 'a result = 'a U.result - (* note that T.run does raise *) - let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> raise (E.Exc e)) in U.run uu - let hoist uu = U.(uu >>= fun u -> mid (OK u)) - let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e)) - end) - let throw e = U.mid (Error e) - let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e) - end (* Error.T *) - module Z(U : MONADZERO) : sig - include ERRORT with type msg := msg and type 'a error := 'a error and type 'a uresult := 'a U.result and type 'a ut := 'a U.t - include ZERO with type 'a t := 'a t - end = struct - include Make.MonadFromTUZ(struct - module U = U - type 'a t = 'a error U.t - type 'a result = 'a U.result - (* we recover from error by using U's mzero; but this discards the error msg *) - let run xx = let uu = U.(xx >>= function OK x -> mid x | Error e -> mzero) in U.run uu - let hoist uu = U.(uu >>= fun u -> mid (OK u)) - let (>>=) xx k = U.(xx >>= function OK x -> k x | Error e -> mid (Error e)) - end) - let throw e = U.mid (Error e) - let catch xx handler = U.(xx >>= function OK _ as x -> mid x | Error e -> handler e) - end (* Error.Z *) - end (* Error *) - - - (* predefine some common instances *) - - module Writer1 = Writer(struct type log = string let empty = "" let append s1 s2 = if s2 = "" then s1 else if s1 = "" then s2 else s1 ^ "\n" ^ s2 end) - - module Writer2 = struct - include Writer(struct - type log = string list - let empty = [] - let append s1 s2 = List.append s2 s1 - end) - (* FIXME these aren't inside M *) - let tell_string s = M.tell [s] - let tell entries = M.tell (List.rev entries) - let run xx = let (x,w) = M.run xx in (x, List.rev w) - end - - module Failure = Error(struct type msg = string exception Exc = Failure end) - -end (* Monad *) - -module Option = Monad.Option -module List = Monad.List - diff --git a/code/reader2.ml b/code/reader2.ml index 10d61e3e..bf561aad 100644 --- a/code/reader2.ml +++ b/code/reader2.ml @@ -4,8 +4,8 @@ module rec E : sig end = E and R : Monad.READER with type env = E.env = struct type env = E.env - module Made = Monad.Reader(E) - include Made.M + module R_E = Monad.Reader(E) + include = R_E.M end @@ -33,5 +33,5 @@ let letf ff body = R.(ff >>= fun f -> shift (insert 'f' (E.Fun f)) body) (* monadic version of `let x = 2 in let f = \y -> y + x in f 3` *) let (expr4 : int R.t) = R.(letx (mid 2) (letf (mid lambda1) (getf >>= fun f -> f (mid 3)))) -let res = R.run expr4 env0 +let res = R.run expr4 env0 (* will be 5 *) -- 2.11.0