From daae6f3ad477f95ea440a28a572bb5feb9d3b1de Mon Sep 17 00:00:00 2001 From: willbasky Date: Fri, 10 May 2019 00:09:36 +0500 Subject: [PATCH] Add realtime animation --- README.md | 48 ++++++- app/Main.hs | 6 + examples/cycle.pdf | Bin 0 -> 3819 bytes examples/gradientRect.pdf | Bin 0 -> 69556 bytes src/Common.hs | 26 ++-- src/CycleAnimation.hs | 271 +++++++++++++++++--------------------- src/Examples.hs | 17 ++- src/Realtime/Animation.hs | 57 ++++++++ src/Realtime/Server.hs | 58 ++++++++ src/Realtime/Types.hs | 84 ++++++++++++ stack.yaml | 7 +- tidal-vis.cabal | 55 ++++++-- 12 files changed, 444 insertions(+), 185 deletions(-) create mode 100644 app/Main.hs create mode 100644 examples/cycle.pdf create mode 100644 examples/gradientRect.pdf create mode 100644 src/Realtime/Animation.hs create mode 100644 src/Realtime/Server.hs create mode 100644 src/Realtime/Types.hs diff --git a/README.md b/README.md index aeed154..bafa36e 100644 --- a/README.md +++ b/README.md @@ -1,14 +1,54 @@ # tidal-vis -Tidal is a domain specific language for live coding pattern. This package allows colour patterns to be rendered as PDF or SVG files. See _Examples.hs_ module for more help. +Tidal is a domain specific language for live coding pattern. This package allows several things: -## Example +1. OSC messages sent to SC to be dynamicly rendered in realtime with at separate window. +[Demo of realtime visualisation.](https://youtu.be/bZS6WufE8FY) +2. Colour patterns to be rendered as PDF or SVG files. See _Examples.hs_ module for more help. +3. Colour patterns to be rendered to be rendered dynamicly in separate window. See _CycleAnimation.hs_ for more. [Demo.](https://youtu.be/cCmCSSb4vHs) + +## (1) Realtime animation during livecoding + +1. Add following lines to _BootTidal.hs_ + + -- OSCTarget for pattern visualizing. + patternTarget = OSCTarget { oName = "Pattern handler", oAddress = "127.0.0.1", oPort = 5050, oPath = "/trigger/something", oShape = Nothing, oLatency = 0.02, oPreamble = [], oTimestamp = BundleStamp } + + -- OSCTarget for play music via SuperCollider. + musicTarget = superdirtTarget { oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120 } + + config = defaultConfig {cFrameTimespan = 1/20} + + -- Send pattern as osc both to SC and to tidal-vis + tidal <- startMulti [musicTarget, patternTarget] config + + -- Send pattern as osc to SC only + -- tidal <- startTidal musicTarget config + +2. Comment `tidal <- startTidal...` and uncomment `tidal <- startMulti...` + +3. Build _tidal-vis_ and run + + cd /tidal-vis + stack build + stack exec tidal-vis + +4. Eval your tidal code. +5. Profit. + +## (2) Render SVG or PDF + +For exanple, when pattern is density 16 $ every 2 rev $ every 3 (superimpose (iter 4)) $ rev "[black blue darkblue, grey lightblue]" +Output image is + ![0](https://i.imgur.com/MPbpH0n.jpg) -To run pattern [animation](https://youtu.be/cCmCSSb4vHs) (not good performance): +## (3) Animate one pattern + +To animate pattern (not good performance): cd ./tidal-vis/ stack repl ./src/CycleAnimation.hs @@ -16,7 +56,7 @@ To run pattern [animation](https://youtu.be/cCmCSSb4vHs) (not good performance): ah <- run swapMVar ah $ degradeBy 0.3 $ every 3 (fast 3) $ Params.s "[red, white, [purple orange green]]" -Look at _CycleAnimation.hs_ for more information. +Look at _CycleAnimation.hs_ for more information. Look at `looping` function to change animation form. ## Tutorial diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..30beddc --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Realtime.Server (animeCollectorServerU) + +main :: IO () +main = animeCollectorServerU diff --git a/examples/cycle.pdf b/examples/cycle.pdf new file mode 100644 index 0000000000000000000000000000000000000000..7e67931a7f754555558173441802dc4dc007ad5f GIT binary patch literal 3819 zcmZWsc|4Ts7mtY;!z9U+?TskgYz)Spv6QW`MN}FLGqz!7ti}Ch$yUt`*>7bjk|w&7 zB|C+Qs7XbUy+ZaV*V1pMZui&c{+`eKKF|An-}9VvzUMrDoTG#{v(P}nF<_+!v&?m{ z7JvjOo_=5h0{~$|4DzLu01Ov$00RJkupkG}iB#?yK%f)Nh+Y(LBG||XOrukYgg|ga z{@vU<=0uJ71)5R9>1OnNRv(*RMAx`HS-%SE=-BZ2G}q9pLJ7Nfw;dniU?q$SYWntYb8$XweZ}Le!<&hD zgmGXDgS=i{`L_4#ddb?%@WT0_Ekgd#R{drbHpb?geD4A~$f)0t^)OodI_DiV*U+fW z(A_U_s5Un2O&o)i)!}nC^az9Wp~GOP!PqN$TF7^-pW|8fJs)W6I0BV#Y!v!HnLe)4#tC zQMnw-c<|)u(~DPZ_lSQHidReaWRM0tQB3rjndZE1Ktjvmi9C3{fNu=42x z$%FE)Lp}MAdprVPLohwi9_^d#ZiZoOKJ(6Kt?gXTp9(X53TUZ=!+Q!cOEVW7Cn&4QVMsQP3TKD6$-7u^ruV&CyPcGTWWmbL6ZKXuAOmd_9QEC*- zElJ->u2;{5MAEx|)A!-={{H?#SdOBSC=EVl&xv|8-9dbYhjC!`J0;L^_d6dr9>WQn z<*0W{@Ik(Y*e^Fo9T&88Y^&jCD(fwYGR%cO6z)D>Ai^dUkoT%yRo&avw$YZ@``&Fx z%|#M_x;__neqPQIoY;{hwzN z+gb&83WUd*r;#N26_F0|=~0>$#xAEwLk0?;1wY}l#yc(;N%J}6O2pbW94a;upMjky zE>ByIi?d5cEqi%ac?xE9u~+)uZ!!e79J|_VR2vl$8b(TXN*>F*HlaG(ers9SjlPFg zzi~YZ|2o|}8>Uwb0`){Hm{nK0l% z<)FEE3j2f}|ECo#U4_WZwD<{3E9eE^^H7^m*p-f2A(D8%;u%B|-^@+?71*P`%3{#{ zEJM=j?ywFeOyD&E2nwykUTe8YDu=lickyN62kQr0_#CPYMqDRC{P=Q`+2PwuCvH#P z*}jz~lOg{*$j{G8G!Sb)i+amCoA|L;4d6Vv!03kwYA&bTql|#j;nyx(GJDPSQmY#G z8*AV-Mtqf-Ce8bwGjZxW2S{Wjh$8Q9jK}ERT zFD&^iJT}pK`>#&8JF^q#JDoQ=earHw#`GO#N`|U4#Dg6&&A(p3X6-l0PG%cq9XGaZ zw2@aHw!N7!t&2>1H(#F;vBy~YiBPlapTRltzA{w5G=z2VoHz^Vx zuAI0seoZ1Y)|2I~H#Z7GZDhMx zR?e(EL#+W$^Q`AYbb?76U4iHWe=Ii2?q=nSP*XbfnfFYz0%Ug{?Rvhi)VAw(XNj=6 zdXoX{!my$1Ge_@t29Y4;KIex10v8t*q|H?i3Sq2>FL8C1{6yB)twyJhy0nQKL8mim zlgE~C3&n^k&lCS}#6dSd3d5l_)Nma)xqYYn47}xHvvLNoQv8^L@EDH*GEAS8wkHs% z>!R;?oy{ctHQ8FRG1nSwHJUE*3iIS0S@?j)-H+!y<|Zz#^ki{NM2K&spf}w&M=vS6>9e-RnjI6=HQW#!X6?E4 zoe#So&79oU_aDD_k0SQ{wVj?tlH1+tGm9>zSC$E>ELe+6X*Ox=YPmR-`hC{Q4G;Dx zNIKmU8v7A~QwUs5W!L*GWwEoSQVudJG1PtRJdyclnc>16FPlp%7xUwD{OQ{-Ud(VPR~L6=E%#p(3ADMJ zQr7cKqFz5Ec3S!qL|Wg7QxTzT>)v+8ZCv5Ni;=G2$GatpE9(@o7k^8ZDc1d59-C9C zTU8J!&hWqa?f5OC&Rf=uxlWdv7=dk*-6NoLsYq~DBg!v(zPqA6LDkao#`T-{O7hyP z8zm;^le_p|XJ0#b%!XlVCmva}B6{J%%|G^&pNWZzrnUuG8mp!RxKYbJ>3G^ zI1aL1j2$XD|(>3i+&<*13|*nIhLMtA?W2K{nSA#ODd`k={4x&wNT?>@|En9B^EFCQopKt5$r9)UTs{LpDGCvBUfLMm!GU|_g>L8 zek3iI6l4eI!|%^^%N)KklDb*UDD|i?;J7!K#f2NUE+3oN^O<-cioHsNVnhK zwHETF@a-0zDjW-bp|%QTb}Y8F7DjJm>#>~bpV=x3rr&-S5;M3tC1+6YT=}desx4+K z`EW=2<%*_=twq;vy76#zvB<{lDTg^-iV2W$s(4YfvkvKm?c=PsaAlgM5)IECt~qVnAk zj@wYt$&?^7UTO}R>7kJ*EK(D#iPFaCqA+Sm%t0hl$+g1WXkq{#;BQP*Q;VAt-T;FB!BA)}!+&8&%>T(DktpsR z{I{GYH@yGCw2;{U!!YPy&eEv_asZL~y(M)dM-jO$^OE5}q0j*y@gFzlXpj#D;KlxX XGHG-ImHwTfCPqgGtfXXq%mVyh%4&RC literal 0 HcmV?d00001 diff --git a/examples/gradientRect.pdf b/examples/gradientRect.pdf new file mode 100644 index 0000000000000000000000000000000000000000..1f5c31171a70eb7f82f25308be34daeaf423e71d GIT binary patch literal 69556 zcmdsA4Ui^9c{Z@9Y%pqBSVl!g<>!dHJ3aq{=LNXq_z~r}yNDIgu-xq(i^uI{cMm}X zfs+XM6SeTKv<#6l#zbQ@_!|`wV_8N`QlwIeWe`JRB`O$=8X*$%y!|uNJw5&H%(vg{ z47r+v+ur&5o1V9yr=R!j?zfNMwq@({*i1Zq{KxPAv;UcnJl|Wq_|oZ(8@<_c=J)Si zxx|Z6w0+w1yxFY_`&Q90Tdy~A#P--8R+UH-Gj|NVP^^wUGZ4Zm{zMfV>5^7p=(UHQI$ z`>!{?Y5j9ddJ?^fA2$={_1t#e)``fUp&SCK=gs**cU&`&bjuIt4_G_ua11}&oBDniMO47 z#Dx$1%NtL<@uC+z>+G8jKke{$KmJqOPd)m&$Nu5WJ&!%~xVJp}!r-QdkKB0X&wg~z zg*%UY>XyH}cGnX&ed$d%-f-8aU+BN(E04MGgSVc2{f)=H?6XgN^wUl{_B+wzzB_y8 z=I=fEzOSGDwp*Y1)9PAy2pNSe#;k5{ikDge)P%* zANu;YuG;XQ+g|*NJKys=x4rWGtaI_{Fs|Kfr-ef0-F zoc`R_*B`m^k?$V*+&k}m+td+1{lzD~a@={pJo@4DKmF*Zv48*E9^8KYfj4hE_fNlY z{1H2L%-#CU__xn|%4gCa-}&;dUH#lchduxI?|A!xJx4wK?hCGc;-Py!e8F{Zoc`kd zC*F1Ck$-Z;{8NvLK6x0s?tu$F`Ka0NZhFa~>o0%CFTebquSGxk_O}ju!&828&u5PQ z$3MRJ^S9o&=bQ1qk39FQcmBY?fA5oSI`q=J?s(4K*Tm;t{?6N<@Xgs1wm)Y6$gBPP zU-zVU-F5a&51ssLXZ|d>{mWM$bN+Ex9kcbBxBvA;v$wtfQy;nS+AkgP;DbMZ{M;Yh z`t<4f{kvt4!M~`lQ3s>{ql?8cqu+9OoV`y`F@5xQvp}OU#;+*u!PqlX{6+bCP?w^m|g~ z;WA1>FEwjUV-J^c54xOLbDDd&^m{Vq;WA1>FEeY-Vh@*bPwHi6%~|f@((lQchs!7l zz1*xhk3C$*J*k(QHRk||Su^ti75vpd$9#YVf6X$$#W(9`J^+Ki=6!&SU-=FW$I5pQ zAghQ39$6KWKqM z8t?cgSmNPQKV%*&DhPZJm;6l-c(~LLkrxyd1c`@B{U-B*qJq%(aLM0_i)MI#DRxP{SbL^Q9+z| zxYTblFD@!bd=HoWO%iyx)DMxD6cr>eK~X`HdAQ_lsqf)ZKLlP{RFFmzULwW#2@< z$0bKd`fjDwc3yd4-kaSvw|Cw<-eVjb+vb+$_pf*b-ezAkzk6Zsw8bmD3-CcaK#InM zKJ5B3e*fmh{VVvuvd0_2i_TbDJa|AGaK*RqQu;lIpf|g7X>R}W0s6LGSE}N(yp^Sc z^XjL~JG|K~^OrB|n%{oLX;dijyM2Cn@!-;~`DIVAOxZTZ@uyn1_2B+pD+`PJ`S%A@ z!R(gB%jOpL^QJJ>0H1!G34$P@ZakCaSwtY3Nz*h0Ok^`zle=Dwm#9AtG1(YTQ#_jZ z(pWx&Sv&O-s+-=Y$GJ@MTG?FjtJ%$q`xcjW9GKe$TO04Q`2FJ2?qzA;APQ!(IAwf< z=WUmF*{@Fi0vZcl3m+%jiT~)IQ&vE4K+|N5;oijwwEim%Zb1%Mhe%A`WbH~ApS2#SkE-qarK8t_w`vg)?D?u5+ zS`0&n=&J=ja{<~?D_$`_x{y`5YJ6BnPLNS0c z*pL1aOBEjx|CrT5Pj`!E>ZQEyS~j5H7=%CtB`0Wx$Cu$M9Ll@TjkcXR`;xz%{e~X} z+ctdT-oqYs(vzpIwp|Ee7}@iJSTQ8yid-2{Jo1a?mR~__p9LqKbMUf-{fo;BE4<^) zo`Kd2y2L|Bk|kMVR$v%lb_dmm&lNIhmfk=A0x|*r$Ej!S@b=8@Tjt)fte0`+plVjo z;*Yo*!G%f6Xk42KvY2tEi;@gF)!?_$H<<)PXqN8|FNUnUW&(AGrzto$fMh7xWK|_Vuu8qmiql?Zy z4h^BLWHSb3+9MOe1rW~j0Ga5w1QX3pU0=sUiZNgXorx64O7dKViO34uH4&mq5MkYV zCMw3}#!RHw+=_|(*iSPOt}`r+@h{>eKlKs6Ft}*7+e|j%x_DdwOMNNHq`)tFb2t<7 zKb`TBLq~AeZ`|g%_-Gy4<02#;oTB#Vgd|*AKG;oO7g1xC)%s&3*pW#$9`r0anD|Hk z+9;9Q=;>3})G!h^j_iRNBk`B24B12*$*`n0IO!631SOTx%f^%hdyk752L+I(X#)bXvo8uh$ zb)Bf-F9OpY!Jk|aA^`4;^vD1R-pXkF;27W&a_HYO^?Nl#Kevv}0DKzI#P4WlM9w5? z44@AMBN(8ZaBMpCD}PrgETX722P4)&EgO@#+H2xdHIt@*b!d-^19&i5^_+qO${B-> z)ITQyny=`O1Yk)fC*B4}0&KgG0neSfu8st>K~<9he4byKvWfoZw$~#Pd_LB!p*AE@ zt|(|q0xDQCK@#X%GZ$eOJhM&!YvD7O2I#si4*k#9fhcfIj=rE;O`K?KV|BMI^b(C(t)q*xJJMiGG6P|b`ABwFFH~~;IC-{ad7&duel(+ zj6-8C?Dwbt`4X=x{KZm|4)s5c_+0<@#{jS+lj~;&#{jX^{~M;RtziIe9oYjl2H;Ec zlqH)mfLz^IG60_^HEXD4fN~LFQwC70TE@YQg8|k-FT3(fEKlLXIvDp4()O2 zf4+oM*<`wn|%c*{8rS)`fNiek@SL zLQm5FF{Xw4(f_cZu;Kt0MSWb3{@bQ*tN}hZjqH0G@cDvz#o>)cf6*VxUR|uQDQ6IB zNB?r^epBFUR5dB!cQ2S-@qfNbdeYeMzB#V3pKrTR{ic9_m$5&J{}Tal{ofx0z>Z9= zcpu!*AIi{QHg%|u0knZsX8=2TKRW&|cidlA(*Jxd z-J~gC9opmM0Nw5d2Nc?;gAgFs|C|IU{@)`BAPmT@IY1c@$}r$LQ?IKd0S!_*3FvCB zi42fi>NFCtYp5pyp&tO}h9m%2Pg`KnYDprNM$?wPnJDD{3zIOwxZ6jmG{0i`>| zJVairLbz#U-_r<)Z~IebY(hX{)1bB_+E|M!YN#b3vB8l0s14U4@om5A*;)}0%UMJl z|7H?ci*M6lX`bL81_!NjSA~W;h>3RZM(|h26Gxa)1iryj_J-C9&lM8wzBw*M#J7X1 zo}v_y*tgnIP=vf9(m~uS>XDBih~#G7!Fffg6hzx=<09NTvIpvXWXqY+UXjcMP>!-S zORDSnsI?&Cd!JP=YsE)?NSnlHk47M+5zF%cz1iTSRqm?rk>*vlMzBK`t%FY^_K(}r zh$m~9G$E}+dt8jfx5lf!q8O>nKhc3a;yxOuB=XVvqa;|8acd4wBHivwiS(Pbb2QvM zHYM@I2FjF8B$7yrpi3k>)Kg1IB85T=iKH(spA-pn>`%CSBc6$6(ge_PTb$rm5p)X8 z7vL8QcwnXuz)ye|do)s{;pxXWf(4n#r!%8{n%)LwCZTc1s!@qks4E-Q|t&3`>*7e)r9B!JntNQ3Hm8f0;9? z1Nf6SLIl9QkscWU`KCm+tl=@hpUa_t@6;P=!n52uHUsedM9Pv)hJKOVNM``spQ#=C zMJA*c4505SnG^%8gI;#&f1W^X(iE@`?QwE|a?f-LQ09c|fCISx=OjS-zdsUyC7DQv zH#`!EULr!I=hn{AaP!oVfUf2mk${+vFGCVFTfOQ@fWAqjd2JRVUDM7chYaXgGrROZ z&yF~00_eCcPVg&rW`MtpH%)$nmH<4>jby-HKl&dQWFp7q0D*tL0RFD2*Vm2yYLLc2 zTE-#+&}ems^=SPs@)T;LKkQMhp$_=sn_2;14KJkrAL;r(;5knxjs4#Af4~z`Qgbx; z2W1Y|4#s}c|1{!r{ofk{kR63BhZp(_ROqiZb)B$|HS`BOm#DI2gP~uTUf-Tsv%#~T z0fc4%mK!e5;Je|*#f)Rn{b2zc6A)pKMF0BN}jeK&at z!1X^T0n-0Hk^nNUi{#XUlL3JW1O7(c9&KSB*#~tQpsTq?Bp_tGrvICT0RxeoxJ?j1 zJsMX5lL-TMteGA9Kj3-FCrtnyx5WkiB72@L0LnuUIuHN^c(F$V>9Bj+q(LSWW*p$~ zufl(u>NaTy+%`7yc{*@K;!Tjx4Q~wp%Cn%JAZn-`{zc;P7RX=Iwr0oh-@RgXOaKJ@ z@PSE#zx(Dm@vpoy1OMeJ{K*ggmgE(=4>cE{NQqJo<0B)1Smnn(z0w7!$@Wky1VrZl z7D6B}vOu(2m6%~y2JIq6l6YU_u#fpVMRQf+DtDQy64#V!!68eyh-bkJjh{TSEeK-m z>FdR-vsXvs@RG6@v}RTp6?N7OR+0)Hw(N3&aqxm-pmLvV2Mi=xha>2g_ zZjCt3Vw?hHEQ(&`t_uCAhZ#phIOqpy4~couozpHTs8D?s?5dE_I4yBeP^V3C(~t^M z>E2MeSGNNi;_c-62UbJoh#sj3N=TeGIXop4NF`L8w=UoYvZ<)pjoDNQi6i)Qe@ON0 zvW8kEB=Y>Xp(0}^S}Q6d{^3f9HmdS})G47=?y69c>hCxV%#=)%4Q;* zKEyYbPF5GmLk7f?mxD;4A7X%Ck^!6N1$L3rIyK5kPsV;BrIJLhdEWUZAFM%(g?E-? zGi8tD1ak_L4p1j0QYSsHcBV!@&_Q$4c#eGHtdd$r>m+$7M%l&r$+u<=_2g6r^O~*H z($fI7hK_>{I`b%;j?tR-o45#|vu3ylMNh4rpwUlp&;hT)HH`sJme(g}YVvT^1D?LA%?hnG<(+Z>zEk~<6I)di zfq{||gEg%*cY(gsrZ|CbEW}m77YXG%8ta8CLf99sNPpmm8HFhaINCFrLhq#7sEEGG zSp$E~;>yvZy*vk_?Ak^$wGmMf{!OjGuOZV7lpWw-C!HL)#6LgdTsnlU+vK8w zb!wEG5J<-k+NdtV%!irS@FEqRcc$+e6 z#lOtF-vaP!fr8d#@Bxd}n1|AG*@3=gfNn!j)nKxfTxLf#1XD#(kp^4*F5 z2pdAV_>VEC-H-T(`2udj0gnHn6#sGE`PqRUN7n#f6S^A>czFzl2Ka`1vt`=-7J%;{ z_}8goc8dRGEiG|@zSE|-fv@Yu0{C49`h@r=>O!g#N;y+nSG{Z#$>(nSWA?S)x5kk2+ zwX4WK@c|eAJ<DtDP{67`(hptOlhOLnH=#jC5?ouQv( z(7F{aI_j($P69GcUML7i3{*7UOg&1U9ZfU<1#T_*kTouA_d5gn0`PQ3~7`sygC3q{mvQ`|J9_dP{JXC||gv2Q!!=s{4N+ndAu`bY|q)}0Eib7*5sw$zH8ful0$nf8Wii{HxT2YZa zE5o1hQ`!v%>|w_$&hx2Aq1A4ykWmL=*>&=10(rmyh9UeZhmk-(zyQB#r|(?KXq_76 zBq-zfg@T~E)JbTuP)giU>yMsbPGQpFIcgvCrBd2fJ4>S<=AhG4Tcsoq#3;LX(ZfrE ztEVUWrZ$dR(aSidT0+O6O*-=_oUW06kioiKduqX7jP2}5%6-i=K{X%Ds0~H70J5|iCnTU`dD>1Gc;{tuBO>qNX*NX-4yA1RR@lV(n;=ecW zlNp66hX?*dh5Bk!)`j}P4drMb8s{H00>9Ak8d#@Bxd}m6j0GWd83yFypZI`_{~qZe1s!lNXK>;_@nssd;Ou>(Vy{Y(DF6IQaKxeAiCH_PG1OqgroeSe4fX(nSGBN%5cC`RCi9dsoHxcVnTAobrTALQTz?&b`S4^$-Zg>~zG!s09nlMjmX z6iPIY76bAWj4~L&iX&pnDryOVe^r}MU}&6@&}v{Gh-1QkxrNf_2(BIk*(Gc&Czj0JqS`3?2*3b@@N77+K z+(e{%o&^z=QK!jINT8L1f5=_|!)C2srXlYG^-URJeR5MmGD&jZM+hB z9!A-%SrKqwjfhI^+H4Y%6^9KAXj1)ao`viXFK*x~^*2sC1_gXIp-QGuz}Jo?=m_`> zn~pi~Y5u<_;Aa3nkH8I2fqYDEj5w!OfpGKKz&DPDXcB*v=acBb*M|X7MXdrU^QSfp zK(b=4WE{W@XvFX2c!&-e%sJxM9SIS3dL#rN@d@u7_z^T|Kfs3xLvF?aj`-?Gh^Q`4 zj4)3P@NLwNc0H^kAy_fDw#talPoHSxdN6+8w|r(`{}DUlcXBL5FThvvEMvsy17Sz& zk2&xoc&!}xG4y^Yw0hDSn7E`hAgQWq9yQK0i_6CuT!2_=J! zRv+>#63y)>CicrJYTXWz%fH2jY{q9?A3^HF34A5-9`V4hn*+s35o&KsN5D^zB!mM$ z!&<(cfR7o_h|D-Zw}Z(U(Ao@jAvcfhb`)nNl&D<=_|+Lu9Of?L=VcZ3z%S)#GxdR! z$Yjmq0H%j{gA@2l;*HaeA&vNaR)#tenOX%JwL=Fw0zToL13!n;+Y|6H)fsX5JiHPA zqjJQr%|(Z)zY;{+h+mwSP@;A;@VV{vg^sLP)l*hc3w)8!ztxDZ2AFXGGa%p>CpnDM zjzIxmF|h%BJ`i>pZ^#kiBj96|eqZqhm@pJaG7Jy+vCM69dfic!AwLho9`TD45=zvr z0{rTR2gda1(})=ck-5JO@GT{=ZEo-UGOyu<3%i$*%8jqSl!L(L#e@4-Jf@x59b!Lh znJ;(S(&FxeyXKd?4ZG$RmKHrW!{Ql)5jI@1vU1?$SxkGNbnnvKflC&4Ezc}2?LFxv z{#Bco=I2%x7WZ$NTbcJZY&kjbS?*&R5vez@)c!ese4_84WPGcdNi5&#=DC%*eT#c} zeY_DK@vzRHS1ir%nMU7^^J%~M<0Uap^!E06qAbDc9@I^Ly#2Dw4$7(9&XyJAsj*_=fYWmhxniz8Z+R4GfyWiiXJalHEOv3$d_5ld5wbC{n^ zY1vt&ETiRUm9pHY#ZcyF^PDCujj{l@Ro`FW=R{xTeOP!FfdXvpHXbSt*OjRWr&$ywd7>#$an<2GmC@Rm{(_)Z&*gNN9G+ybpUps_%fh zy;WbB+RuWFo>qNPYS|pTZ}nZ2S(px!lvc`^&zEH6XqshdN{Q$zWf=(pvn)%kz7}Sg zWsfjVX*Zww**v2xVMZC4gy!|kGR(VIKO5EbdrZz)_K2|SpxU1!%tTcCeS|{04Bt|H zmYC01n9m2!sp2}^2p+sD32|E ziT#K&iyNN>q)9!PWq5sdSxo8v&HFGWTlL`#AnUWxlGc4;YVj#$vaPvz=6z{OeqN<4xB5$re7aWKvfQ#q48E`S-2_x@m*v(tlVAX@ za$Ul5I#|hgJ}@@Lo-1WGR#BTZCi`JX-l_T7Ftx^gNCDbET)8i|`nVr~QLFbwvHg5e zZjEJrl+!5==6A%577AC&BCEe(G_q{uCp>^=el}s21_8TR91A&V^*=wg#~zefTE$P1 ze!2S0=;Bs8GG^h;&zRkg3?kSy(_BE$=p;8Dnzw9k3v?`~Vixfp3-1 zhJnRv3}d%dUzk~(2+e9~E|gh(z(B=Sy8)^8`@`5%SzZb_PSl^o_mQG}8X16y(X|=u#FW)Mw=`UGk z=_>|&SbaQ?EN+L~u=`MM>zu$3tT6?ipVf}Q&n&+OW!AVK03TJG2aws-cYw_dR)2wS zK!FMa3qfG_@c^!5wZ8zV7H6Z(@^u5?ql%dzjA?6x`MqIo@oo^>;|E+s3+F*ZDab4J zVXUayoFs_Vj+jsUn9mZ&R{sm)8b1mHwe|j>>#TPVU($L9sc*l()Q%P4fCb8&WD_Bw76rxl=5^ z7G)Nuk*&n)Ya#GawFmZM(>_7t{b7qHEs&~~S?>Um49jQ7#wg2fA&$1K+81S3KL8YL z-wNBMtNjI%%j&x*v-&PP4ckYI7#;Cowk-mY+hz9m0v}c0#q5ZsH}H6tEm3CS7lAvA zb3zDI%SK6!PmFM#^X ziZHiheeiWH{G!Z?t3((st6CW+&03s;(a6#&D6{%du4_lJkE+J=Xz+AWF@ zgsQ%m2!gy?7Tf(Lig|Jm^PR>B=31Z4Xoa?UU&7DEs+L)Cnh5&JYDbdU?>^;;T+I65 z>RR8MCPDN9EU|PkB&(%&Bg|M^?wg9hV{KMoUm%!po%T6jEJB$rXY+-OD&Ce8Z(fNRR*9}%h3I*yoN4h`SIvNmVXJA zV~s}`1udVQBuy0y81XE=kBM}u&lfSP42{P^eJHNcS5Q(`j5Y=qs@OuA#k(=| zm31HHNv!vr*mE`*K`s762-MQvG2CveAAmY7y8$0nj=-{Ai%a4f|2&5OVc8>tqf&kM zfSdKb&|KDid1zq^^3>8pD6{x9@!=g*z87lJ;U;*mD>Kh3{ z57mB;GK;el=&R~`PT(?W&$6;Kx3F)1i7&C)vGA&SK0%1}1GC!~7gz8DzD6Dxan}Al fizvYR6Z4A8D|1ULd{z-vX7Tj#$De-g*6IHPBe+(| literal 0 HcmV?d00001 diff --git a/src/Common.hs b/src/Common.hs index 8ea83a8..b25c6a6 100644 --- a/src/Common.hs +++ b/src/Common.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} - module Common ( arrangeEvents , beatNow @@ -9,10 +8,10 @@ module Common , levels , remoteLocal , segmentator + , toPattern ) where import Control.Concurrent.MVar - import Data.Bits (shiftR, (.&.)) import Data.Colour.SRGB (sRGB) import Data.Function (on) @@ -21,20 +20,18 @@ import Data.List (groupBy, nub, sortOn) import Data.Maybe (isJust) import Data.Time (diffUTCTime, getCurrentTime) import Network.Socket (SockAddr (..), addrAddress, getAddrInfo) - import Sound.Tidal.Context import qualified Sound.OSC.FD as OSC import qualified Sound.Tidal.Tempo as Tempo --- | Common used functions. +-- | Common functions. fi :: (Integral a, Num b) => a -> b fi = fromIntegral arrangeEvents :: [Event b] -> [[Event b]] -arrangeEvents [] = [] -arrangeEvents (e:es) = addEvent e (arrangeEvents es) +arrangeEvents = foldr addEvent [] fits :: Event b -> [Event b] -> Bool fits (Event _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events @@ -51,7 +48,7 @@ levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (queryA sortOn' :: Ord a => (b -> a) -> [b] -> [b] sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x)) --- | Recover depricated functions for 1.0.7 +-- | Recover depricated functions for 1.0.13 dirtToColour :: ControlPattern -> Pattern ColourD dirtToColour = fmap (stringToColour . show) @@ -77,7 +74,7 @@ split :: Time -> [Event a] -> [Event a] split _ [] = [] split t (ev@(Event whole Arc{..} value):es) | t > start && t < stop = - Event whole (Arc start t) value : Event whole (Arc t stop) value : (split t es) + Event whole (Arc start t) value : Event whole (Arc t stop) value : split t es | otherwise = ev:split t es points :: [Event a] -> [Time] @@ -105,12 +102,15 @@ remoteLocal :: Config -> OSC.Time -> IO (MVar Tempo.Tempo) remoteLocal config time = do let tempoClientPort = cTempoClientPort config hostname = cTempoAddr config - port = cTempoPort config + remotePort = cTempoPort config (remote_addr:_) <- getAddrInfo Nothing (Just hostname) Nothing local <- OSC.udpServer "127.0.0.1" tempoClientPort - let (SockAddrInet _ a) = addrAddress remote_addr - remote = SockAddrInet (fromIntegral port) a - newMVar $ Tempo.defaultTempo time local remote - + case addrAddress remote_addr of + SockAddrInet _ a -> do + let remote = SockAddrInet (fromIntegral remotePort) a + newMVar $ Tempo.defaultTempo time local remote + _ -> error "wrong Socket" +toPattern :: [Event ControlMap] -> ControlPattern +toPattern evs = Pattern Digital $ const evs diff --git a/src/CycleAnimation.hs b/src/CycleAnimation.hs index 237116b..91b1fc3 100644 --- a/src/CycleAnimation.hs +++ b/src/CycleAnimation.hs @@ -4,165 +4,97 @@ module CycleAnimation where import Control.Concurrent import Control.Monad.Reader import Control.Monad.State - import Data.Bits import Data.Colour.SRGB import GHC.Int (Int16) - import Graphics.UI.SDL import Graphics.UI.SDL.TTF.Management import Graphics.UI.SDL.TTF.Render import Graphics.UI.SDL.TTF.Types +import Sound.Tidal.Context hiding (Event) +import Sound.Tidal.Tempo +import Sound.Tidal.Utils import qualified GHC.Word import qualified Graphics.UI.SDL.Framerate as FR import qualified Graphics.UI.SDL.Primitives as SDLP import qualified Graphics.UI.SDL.TTF.General as TTFG - -import Sound.OSC.FD (time) - -import Sound.Tidal.Config -import Sound.Tidal.Core -import Sound.Tidal.ParseBP -import Sound.Tidal.Pattern hiding (Event) -import Sound.Tidal.Tempo -import Sound.Tidal.Utils - +import qualified Sound.OSC.FD as FD import qualified Sound.Tidal.Pattern as Pat import Common --- | To run at CLI to see animation. --- | Cycle animation looks like https://www.youtube.com/watch?v=cCmCSSb4vHs --- | Rectangle animation looks ... --- @ --- stack repl --- :set -XOverloadedStrings --- ah <- run --- swapMVar ah $ degradeBy 0.3 $ every 3 (fast 3) $ Params.s "[red, white, [purple orange green]]" --- @ --- | Look at comment for 'loop' function below. -runAnimation :: IO (MVar ControlPattern) -runAnimation = do - mp <- newMVar silence - void $ forkIO $ run' mp - return mp +data Scene = Scene + { mouseXY :: (Float, Float) + , cursor :: (Float, Float) + } + +data AppConfig = AppConfig + { acScreen :: Surface + , acFont :: Font + , acTempo :: MVar Tempo + , acFps :: FR.FPSManager + , acPattern :: MVar Pat.ControlPattern + } + +type AppState = StateT Scene IO + +type AppEnv = ReaderT AppConfig AppState run' :: MVar ControlPattern -> IO () -run' mp = withInit [InitEverything] $ - do result <- TTFG.init - if not result - then putStrLn "Failed to init ttf" - else do enableUnicode True - env <- initEnv mp - --ws <- wordMenu (font env) things - let scene = Scene (0,0) (0.5,0.5) - --putStrLn $ show scene - runLoop env scene - +run' mp = withInit [InitEverything] $ do + result <- TTFG.init + if not result + then putStrLn "Failed to init ttf" + else do + enableUnicode True + env <- initEnv mp + --ws <- wordMenu (font env) things + let scene = Scene (0,0) (0.5,0.5) + runLoop env scene runLoop :: AppConfig -> Scene -> IO () -runLoop = evalStateT . runReaderT loop +runLoop = evalStateT . runReaderT looping --- | Animate pattern looply. Choose form inside 'loop'. --- | It needs to be optimized. -loop :: AppEnv () -loop = do - quit' <- whileEvents act +-- | Animate pattern looply. +-- | Choose form of pattern within 'loop'. +looping :: AppEnv () +looping = do + quit' <- whileEvents action screen <- acScreen `liftM` ask tempoM <- acTempo `liftM` ask fps <- acFps `liftM` ask mp <- acPattern `liftM` ask liftIO $ do pat <- readMVar mp + appendFile "pat" $ show pat ++ "\n\n" tempo <- readMVar tempoM beat <- beatNow tempo - bgColor <- (mapRGB . surfaceGetPixelFormat) screen 0x00 0x00 0x00 + bgColor <- (mapRGB . surfaceGetPixelFormat) screen 0x00 0x00 0x00 clipRect <- Just `liftM` getClipRect screen void $ fillRect screen clipRect bgColor -- | Use one of -- -- | (1) Cicle form of moving patterns - drawPatC (100, fi screenHeight / 2) (dirtToColour pat) screen beat + -- drawPatC (100, fi screenHeight / 2) (dirtToColour pat) screen beat -- | (2) Rectangular form of moving patterns - -- | drawPatR (0, fi screenHeight) (dirtToColour pat) screen beat + drawPatR (0, fi screenHeight) (dirtToColour pat) screen beat Graphics.UI.SDL.flip screen FR.delay fps - unless quit' loop - where act e = do scene <- get - scene' <- handleEvent scene e - put scene' - -data Scene = Scene - { mouseXY :: (Float, Float) - , cursor :: (Float, Float) - } - -data AppConfig = AppConfig - { acScreen :: Surface - , acFont :: Font - , acTempo :: MVar Tempo - , acFps :: FR.FPSManager - , acPattern :: MVar Pat.ControlPattern - } - -type AppState = StateT Scene IO - -type AppEnv = ReaderT AppConfig AppState - -screenWidth :: Int -screenWidth = 1024 - -screenHeight :: Int -screenHeight = 768 - -screenBpp :: Int -screenBpp = 32 - --- A middle of window. -middle :: (Double, Double) -middle = (fromIntegral $ screenWidth `div` 2, fromIntegral $ screenHeight `div` 2) - -fromScreen :: (Int, Int) -> (Float, Float) -fromScreen (x, y) = - ( fromIntegral x / fromIntegral screenWidth - , fromIntegral y / fromIntegral screenHeight - ) - -isInside :: Integral a => Rect -> a -> a -> Bool -isInside (Rect rx ry rw rh) x y = (x' > rx) && (x' < rx + rw) && (y' > ry) && (y' < ry + rh) - where (x', y') = (fromIntegral x, fromIntegral y) - -ctrlDown :: [Modifier] -> Bool -ctrlDown = any (`elem` [KeyModLeftCtrl, KeyModRightCtrl]) - -shiftDown :: [Modifier] -> Bool -shiftDown = any (\x -> elem x - [ KeyModLeftShift - , KeyModRightShift - , KeyModShift - ]) - -handleEvent :: Scene -> Event -> AppEnv Scene -handleEvent scene (KeyDown k) = - handleKey scene (symKey k) (symUnicode k) (symModifiers k) -handleEvent scene _ = return scene - -handleKey :: Scene -> SDLKey -> Char -> [Modifier] -> AppEnv Scene -handleKey scene SDLK_SPACE _ _ = return scene -handleKey scene _ _ _ = return scene - -applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool -applySurface x y src dst clip = blitSurface src clip dst off - where off = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 } + unless quit' looping + where + action e = do + scene <- get + scene' <- handleEvent scene e + put scene' initEnv :: MVar ControlPattern -> IO AppConfig initEnv mp = do - time' <- time + time' <- FD.time screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface] font' <- openFont "futura.ttf" 22 setCaption "Cycle" [] @@ -179,17 +111,17 @@ drawArc -> (Double, Double) -- Torus`s internal and external radiuses. -> Double -- (pi*2) * fromRational (s - (toRational $ beat / 8)) -> Double -- ((pi*2) * fromRational (e-s)) - -> Double -- step + -> Double -- pace -> IO () -drawArc screen c (x,y) (r,r') t o step' +drawArc screen c (x,y) (r,r') t o pace | o <= 0 = return () | otherwise = do let pix = colourToPixel c void $ SDLP.filledPolygon screen coords pix - drawArc screen c (x,y) (r,r') t (o-step') step' + drawArc screen c (x,y) (r,r') t (o - pace) pace return () where - a = max t (t + o - step') -- start width + a = max t (t + o - pace) -- start width b = t + o -- end width coords :: [(Int16, Int16)] coords = map (\(x',y') -> (floor $ x + x', floor $ y + y')) @@ -206,41 +138,38 @@ drawPatC -> Surface -> Double -> IO () -drawPatC (r,r') pat screen beat = mapM_ drawEvents $ event pos pat +drawPatC (r,r') pat screen beat = mapM_ drawEvents $ event (pos beat) pat where - pos :: Rational - pos = toRational $ beat / 8 - drawEvents :: ((Rational, Rational), [ColourD]) -> IO () - drawEvents ((begin,end), cs) = - mapM_ (\(index', color) -> drawEvent (begin,end) color index' (length cs)) + drawEvents ((b,e), cs) = + mapM_ (\(index', color) -> drawEvent (b,e) color index' (length cs)) (enumerate $ reverse cs) drawEvent :: (Rational, Rational) -> ColourD -> Int -> Int -> IO () - drawEvent (begin, end) color index' len = do + drawEvent (b, e) color index' len = do let thickness = (1 / fromIntegral len) * (r' - r) let thickIndex = r + thickness * fromIntegral index' drawArc screen color middle (thickIndex, thickIndex + thickness) - ((pi*2) * fromRational (begin - pos)) ((pi*2) * fromRational (end - begin)) (pi/16) + ((pi*2) * fromRational (b - pos beat)) ((pi*2) * fromRational (e - b)) (pi/16) --- Draw one cycle patterns +-- Draw one rectangle pattern drawRect :: Surface -> ColourD -> (Double, Double) -- thickIndex, thickIndex + thickness -> Double -- ((pi*2) * fromRational (start - pos)) -> Double -- ((pi*2) * fromRational (end - start)) - -> Double -- step (pi/16) + -> Double -- pace (pi/16) -> IO () -drawRect screen c (thickStart,thickEnd) t o step +drawRect screen c (thickStart,thickEnd) t o pace | o <= 0 = return () | otherwise = do let pix = colourToPixel c void $ SDLP.filledPolygon screen coords pix - drawRect screen c (thickStart, thickEnd) t (o - step) step + drawRect screen c (thickStart, thickEnd) t (o - pace) pace return () where - a = max t (t + o - step) -- + a = max t (t + o - pace) -- b = t + o coords = map (\(x',y') -> (floor x', floor y')) @@ -250,39 +179,36 @@ drawRect screen c (thickStart,thickEnd) t o step , (a, thickStart) -- 4 ] --- Draw cycle patterns continiously +-- Draw rectangle patterns continiously drawPatR :: (Double, Double) -> Pat.Pattern ColourD -> Surface -> Double -> IO () -drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event pos p +drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event (pos beat) p where - pos :: Rational - pos = toRational $ beat / 8 - drawEvents :: ((Rational, Rational), [ColourD]) -> IO () - drawEvents ((begin, end), cs) = - mapM_ (\(index', c) -> drawEvent (begin, end) c index' (length cs)) (enumerate $ reverse cs) + drawEvents ((b, e), cs) = + mapM_ (\(index', c) -> drawEvent (b, e) c index' (length cs)) (enumerate $ reverse cs) drawEvent :: (Rational, Rational) -> ColourD -> Int -> Int -> IO () - drawEvent (begin, end) color index' len = do + drawEvent (b, e) color index' len = do let thickness = (1 / fromIntegral len) * (x2 - x1) let thickIndex = thickness * fromIntegral index' let width = fi screenWidth drawRect screen color (thickIndex, thickIndex + thickness) - (width * fromRational (begin - pos)) (width * fromRational (end - begin)) 1 + (width * fromRational (b - pos beat)) (width * fromRational (e - b)) 1 event :: Rational -> Pat.Pattern ColourD -> [((Rational, Rational), [ColourD])] -event pos pat = map (\(Pat.Event _ Arc{..} events) -> - ((max start pos, min stop (pos + 1)), events)) - $ queryArc (segmentator pat) (Arc pos (pos + 1)) +event position pat = map (\(Pat.Event _ Arc{..} events) -> + ((max start position, min stop (position + 1)), events)) + $ queryArc (segmentator pat) (Arc position (position + 1)) whileEvents :: MonadIO m => (Event -> m ()) -> m Bool -whileEvents act = do +whileEvents action = do ev <- liftIO pollEvent case ev of Quit -> return True NoEvent -> return False _ -> do - act ev - whileEvents act + action ev + whileEvents action textSize :: String -> Font -> IO (Float,Float) textSize text font' = @@ -290,14 +216,12 @@ textSize text font' = return (fromScreen (surfaceGetWidth message, surfaceGetHeight message)) colourToPixel :: Colour Double -> Pixel -colourToPixel c = - -- mapRGB (surfaceGetPixelFormat screen) 255 255 255 - rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255) +colourToPixel c = rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255) where (RGB r g b) = toSRGB c colourToPixelS :: Surface -> Colour Double -> IO Pixel -colourToPixelS s c = - (mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255) +colourToPixelS surface c = + (mapRGB . surfaceGetPixelFormat) surface (floor $ r*255) (floor $ g*255) (floor $ b*255) where (RGB r g b) = toSRGB c rgbColor :: GHC.Word.Word8 -> GHC.Word.Word8 -> GHC.Word.Word8 -> Pixel @@ -311,5 +235,48 @@ rgbColor r g b = Pixel pixel :: Surface -> (GHC.Word.Word8,GHC.Word.Word8,GHC.Word.Word8) -> IO Pixel pixel face (r,g,b) = mapRGB (surfaceGetPixelFormat face) r g b +screenWidth :: Int +screenWidth = 500 +screenHeight :: Int +screenHeight = 400 +screenBpp :: Int +screenBpp = 32 + +-- A middle of window. +middle :: (Double, Double) +middle = (fromIntegral $ screenWidth `div` 2, fromIntegral $ screenHeight `div` 2) + +fromScreen :: (Int, Int) -> (Float, Float) +fromScreen (x, y) = + ( fromIntegral x / fromIntegral screenWidth + , fromIntegral y / fromIntegral screenHeight + ) + +pos :: Double -> Rational +pos beat = toRational $ beat / 8 + +isInside :: Integral a => Rect -> a -> a -> Bool +isInside (Rect rx ry rw rh) x y = + (x' > rx) && (x' < rx + rw) && (y' > ry) && (y' < ry + rh) + where (x', y') = (fromIntegral x, fromIntegral y) + +ctrlDown :: [Modifier] -> Bool +ctrlDown = any (`elem` [KeyModLeftCtrl, KeyModRightCtrl]) + +shiftDown :: [Modifier] -> Bool +shiftDown = any (`elem` [ KeyModLeftShift, KeyModRightShift, KeyModShift]) + +handleEvent :: Scene -> Event -> AppEnv Scene +handleEvent scene (KeyDown k) = + handleKey scene (symKey k) (symUnicode k) (symModifiers k) +handleEvent scene _ = return scene + +handleKey :: Scene -> SDLKey -> Char -> [Modifier] -> AppEnv Scene +handleKey scene SDLK_SPACE _ _ = return scene +handleKey scene _ _ _ = return scene + +applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool +applySurface x y src dst clip = blitSurface src clip dst rect + where rect = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 } diff --git a/src/Examples.hs b/src/Examples.hs index 32c1554..97d2b07 100644 --- a/src/Examples.hs +++ b/src/Examples.hs @@ -9,10 +9,7 @@ import VisCycle import VisGradient --- | Examples --- --- | For pattern animation look at 'runAnimation' function at 'CycleAnimation.hs' module. --- | There two forms of moving patterns: cycle and rectangle. +-- | Examples how to render still images to PDF or SVG formats. -- -- | Here is renders of still images only. main :: IO () @@ -36,6 +33,18 @@ gradientRect = renderGradientPDF "./examples/gradientRect" pip matCycleWithBorders :: IO () matCycleWithBorders = renderCyclePDF "./examples/cycle" "background text" pip +repeater :: Pattern ColourD +repeater = dirtToColour + $ juxBy 0.6 brak + $ every 2 ((* speed (1 + sine)) . ply 4) + $ stack + [ s "bd:4 ~ ~ drum:3 ~ ~ drum:2 ~" + , s "~ wind:1/2 hh:9" + , s "subroc3d:9(2,7)" + ] + # speed 0.5 + # legato 1 + -- | Prepared patterns. foo :: Pattern ColourD foo = dirtToColour $ striate 16 $ sound "[bd*3? dr2, ~ casio ~, [bd arpy]]" # n diff --git a/src/Realtime/Animation.hs b/src/Realtime/Animation.hs new file mode 100644 index 0000000..337c097 --- /dev/null +++ b/src/Realtime/Animation.hs @@ -0,0 +1,57 @@ +module Realtime.Animation + ( movingPatterns + ) where + +import Control.Concurrent +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq (..), (<|)) +import Graphics.Gloss +import Graphics.Gloss.Interface.IO.Simulate +import Realtime.Types (ColorI) + +import qualified Data.Sequence as S + + +window :: Display +window = InWindow "Nice Window" (500, 500) (20, 20) + +background :: Color +background = greyN 0.1 + +movingPatterns :: MVar [ColorI] -> IO () +movingPatterns tp = simulateIO window background 12 + (S.singleton [(200,100,200,250)]) + (pure . pictures . seqToPics) + $ \_ _ seqColors -> do + mColors <- tryTakeMVar tp + let colsNew = fromMaybe [] mColors + let headColors = seqColors `S.index` 0 + pure $ if headColors==colsNew || null colsNew then seqColors else addColorList colsNew seqColors + where + seqToPics :: Seq [ColorI] -> [Picture] + seqToPics = S.foldMapWithIndex (\i c -> makeLine (length c) i c) + + makeLine :: Int -> Int -> [ColorI] -> [Picture] + makeLine cLength i = map (\(n,col) -> rectLinesDown col n cLength i) . zip [0..] + -- Keep circle list length equal to 'n'. + refrain :: Int -> Seq [ColorI] -> Seq [ColorI] + refrain n xs + | S.length xs <= n = xs + | otherwise = S.take n xs + -- Every round number spawn circle and add it to right end. Colorize new circle with new color. + addColorList :: [ColorI] -> Seq [ColorI] -> Seq [ColorI] + addColorList colors seqColors = colors <| refrain 10 seqColors + + rectLinesDown :: ColorI -> Float -> Int -> Int -> Picture + rectLinesDown col n l i + = translate (piece * n - 250 + piece / 2) (225 - 50 * fromIntegral i) + $ color (makeColorFromIntTuple col) + $ rectangleSolid piece 50 + where + piece = 500 / fromIntegral l + +makeColorFromIntTuple :: (Int, Int, Int, Int) -> Color +makeColorFromIntTuple (r,g,b,a) = makeColorI r g b a + + + diff --git a/src/Realtime/Server.hs b/src/Realtime/Server.hs new file mode 100644 index 0000000..2d044ed --- /dev/null +++ b/src/Realtime/Server.hs @@ -0,0 +1,58 @@ +module Realtime.Server + ( animeCollectorServerU + ) where + +import Control.Concurrent +import Control.Concurrent.Async (race_) +import Control.Concurrent.Chan.Unagi.Bounded (InChan, OutChan) +import Control.Monad +import Sound.OSC + +import qualified Control.Concurrent.Chan.Unagi.Bounded as U +import qualified Sound.OSC.FD as FD + +import Realtime.Animation (movingPatterns) +import Realtime.Types (ColorI, TidalPacket (..), packetToTidalPacket) + + +-- Command to start the server in a repl for testing +-- do u <- t0; udp_close u; hoscServerTPU + +animeCollectorServerU :: IO () +animeCollectorServerU = do + (inChan, outChan) <- U.newChan 100 + mvar <- newEmptyMVar + race_ (hoscServerTPU inChan) $ race_ (collector outChan mvar) (movingPatterns mvar) + +t0 :: IO UDP +t0 = udpServer "127.0.0.1" 5050 + +-- Listen to osc packets and write them to channel. +hoscServerTPU :: InChan TidalPacket -> IO () +hoscServerTPU inChan = FD.withTransport t0 $ \udp -> forever $ do + packet <- udp_recv_packet udp + let tp = packetToTidalPacket packet + U.writeChan inChan tp + +-- Collect sync packets to list and put mvar for animation. +collector :: OutChan TidalPacket -> MVar [ColorI] -> IO () +collector outChan mvColors = do + buffer <- newEmptyMVar + forever $ do + c <- U.readChan outChan + mtp <- tryTakeMVar buffer + case mtp of + Nothing -> putMVar buffer (tpTime c, [tpColor c]) + Just tp -> + if fst tp == tpTime c + then void $ putMVar buffer (toTuple c tp) + else do + putMVar buffer (tpTime c, [tpColor c]) + putMVar mvColors $ snd tp + +-- Take time and color. +toTuple :: TidalPacket -> (Double, [ColorI]) -> (Double, [ColorI]) +toTuple tp (f,tps) = (f, tpColor tp : tps) + + + diff --git a/src/Realtime/Types.hs b/src/Realtime/Types.hs new file mode 100644 index 0000000..63534b5 --- /dev/null +++ b/src/Realtime/Types.hs @@ -0,0 +1,84 @@ +module Realtime.Types + ( TidalPacket (..) + , ColorI + , defaultTidalPacket + , packetToTidalPacket + , parsePacket + ) where + +import Data.Bits (shiftR, (.&.)) +import Data.Hashable (hash) +import Data.Maybe (fromMaybe) +import Sound.OSC + + +data TidalPacket = TidalPacket + { tpTime :: Double + , tpCycle :: Float + , tpDelta :: Float + , tpColor :: ColorI + } deriving (Eq, Show) + +type ColorI = (Int, Int, Int, Int) + +defaultTidalPacket :: TidalPacket +defaultTidalPacket = TidalPacket + { tpTime = immediately + , tpCycle = 1.0 + , tpDelta = 1.0 + , tpColor = (100, 200, 50, 250) + } + +parsePacket :: Packet -> Maybe (Int,Int,Int,Int) +parsePacket p = tupleI list + where + list = mapM datum_integral . messageDatum =<< packet_to_message p + tupleI = \case + Nothing -> Nothing + Just list' -> case list' of + (r:g:b:a:_) -> Just (r,g,b,a) + _ -> Nothing + +stringToColour :: String -> (Int,Int,Int,Int) +stringToColour str = (r, g, b, 250) + where + i = hash str `mod` 16777216 + r = (i .&. 0xFF0000) `shiftR` 16 + g = (i .&. 0x00FF00) `shiftR` 8 + b = i .&. 0x0000FF + +deleteDatumValue :: String -> [Datum] -> [Datum] +deleteDatumValue d ds = go + where + go = case break (==d') ds of + (f,x:_:xs) -> f ++ (x:xs) + _ -> [] + d' = string d + +roundFloats :: Datum -> Datum +roundFloats = \case + Float d_float -> Float (fromInteger (round $ d_float * 10000) / 10000) + x -> x + +takeDatumValue :: String -> [Datum] -> Datum +takeDatumValue d ds = go + where + go = case break (== d') ds of + (_,_:v:_) -> v + _ -> string "No value for your datum" + d' = string d + +packetToTidalPacket :: Packet -> TidalPacket +packetToTidalPacket p = TidalPacket + { tpTime = bundleTime bund + , tpCycle = cycle' + , tpDelta = delta' + , tpColor = color' + } + where + bund = packet_to_bundle p + datums = concatMap messageDatum $ bundleMessages bund + cycle' = takeFloat "cycle" datums + delta' = takeFloat "delta" datums + color' = stringToColour $ show $ deleteDatumValue "cycle" datums + takeFloat str = fromMaybe 0 . datum_floating . roundFloats . takeDatumValue str diff --git a/stack.yaml b/stack.yaml index ee4f14e..9b9f32f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,14 +1,15 @@ -resolver: lts-13.8 +resolver: lts-13.19 # packages: [] extra-deps: - - SDL-0.6.7.0 - cairo-0.13.6.0 - - tidal-1.0.7 - gtk2hs-buildtools-0.13.5.0 + - SDL-0.6.7.0 - SDL-gfx-0.7.0.0 - SDL-image-0.6.2.0 - SDL-ttf-0.6.3.0 + - unagi-chan-0.4.1.0 + diff --git a/tidal-vis.cabal b/tidal-vis.cabal index 4fbaf22..922a394 100644 --- a/tidal-vis.cabal +++ b/tidal-vis.cabal @@ -1,7 +1,6 @@ name: tidal-vis -version: 1.0.7 -synopsis: Visual rendering for Tidal patterns --- description: +version: 1.0.13 +synopsis: Visual rendering for Tidal patterns and osc messages homepage: http://yaxu.org/tidal/ license: GPL-3 license-file: LICENSE @@ -17,10 +16,34 @@ cabal-version: 2.0 Description: Tidal is a domain specific language for live coding pattern. This package allows colour patterns to be rendered as PDF or SVG files. +executable tidal-vis + hs-source-dirs: app + main-is: Main.hs + + ghc-options: -Wall + -threaded + -rtsopts + -with-rtsopts=-N + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + + build-depends: base + , tidal-vis + + default-language: Haskell2010 + library Exposed-modules: Common CycleAnimation Examples + Realtime.Animation + Realtime.Server + Realtime.Types Vis VisCycle VisGradient @@ -28,20 +51,34 @@ library hs-source-dirs: src Build-depends: base < 5 - , tidal>=1.0.7 - , colour + , async , cairo + , colour + , containers + , gloss + , hashable + , hosc , SDL - , mtl , SDL-gfx , SDL-image , SDL-ttf - , hosc - , hashable - , time + , mtl , network + , tidal>=1.0.13 + , time + , unagi-chan + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields default-language: Haskell2010 default-extensions: OverloadedStrings RecordWildCards + LambdaCase