Add realtime animation

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
 

app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Realtime.Server (animeCollectorServerU)
+
+main :: IO ()
+main = animeCollectorServerU

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 = foldr addEvent []
-arrangeEvents (e:es) = addEvent e (arrangeEvents es)
 
 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
+  case addrAddress remote_addr of
-      remote = SockAddrInet (fromIntegral port) a
+    SockAddrInet _ a -> do
-  newMVar $ Tempo.defaultTempo time local remote
+      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
 

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 qualified Sound.OSC.FD as FD
-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.Tidal.Pattern as Pat
 
 import Common
 
 
--- | To run at CLI to see animation.
+data Scene = Scene
--- | Cycle animation looks like https://www.youtube.com/watch?v=cCmCSSb4vHs
+  { mouseXY :: (Float, Float)
--- | Rectangle animation looks ...
+  , cursor  :: (Float, Float)
--- @
+  }
--- stack repl
+
--- :set -XOverloadedStrings
+data AppConfig = AppConfig
--- ah <- run
+  { acScreen  :: Surface
--- swapMVar ah $ degradeBy 0.3 $ every 3 (fast 3) $  Params.s "[red, white, [purple orange green]]"
+  , acFont    :: Font
--- @
+  , acTempo   :: MVar Tempo
--- | Look at comment for 'loop' function below.
+  , acFps     :: FR.FPSManager
-runAnimation :: IO (MVar ControlPattern)
+  , acPattern :: MVar Pat.ControlPattern
-runAnimation = do
+  }
-    mp <- newMVar silence
+
-    void $ forkIO $ run' mp
+type AppState = StateT Scene IO
-    return mp
+
+type AppEnv = ReaderT AppConfig AppState
 
 run' :: MVar ControlPattern -> IO ()
-run' mp = withInit [InitEverything] $
+run' mp = withInit [InitEverything] $ do
-        do  result <- TTFG.init
+  result <- TTFG.init
-            if not result
+  if not result
-              then putStrLn "Failed to init ttf"
+    then putStrLn "Failed to init ttf"
-              else do enableUnicode True
+    else do
-                      env <- initEnv mp
+      enableUnicode True
-                      --ws <- wordMenu (font env) things
+      env <- initEnv mp
-                      let scene = Scene (0,0) (0.5,0.5)
+      --ws <- wordMenu (font env) things
-                      --putStrLn $ show scene
+      let scene = Scene (0,0) (0.5,0.5)
-                      runLoop env scene
+      runLoop env scene
-
 
 runLoop :: AppConfig -> Scene -> IO ()
-runLoop = evalStateT . runReaderT loop
+runLoop = evalStateT . runReaderT looping
 
--- | Animate pattern looply. Choose form inside 'loop'.
+-- | Animate pattern looply.
--- | It needs to be optimized.
+-- | Choose form of pattern within 'loop'.
-loop :: AppEnv ()
+looping :: AppEnv ()
-loop = do
+looping = do
-    quit' <- whileEvents act
+    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
+    unless quit' looping
-      where act e = do scene <- get
+  where
-                       scene' <- handleEvent scene e
+    action e = do
-                       put scene'
+      scene <- get
-
+      scene' <- handleEvent scene e
-data Scene = Scene
+      put 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 }
 
 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) =
+    drawEvents ((b,e), cs) =
-        mapM_ (\(index', color) -> drawEvent (begin,end) color index' (length 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) =
+    drawEvents ((b, e), cs) =
-          mapM_ (\(index', c) -> drawEvent (begin, end) c index' (length cs)) (enumerate $ reverse 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) ->
+event position pat = map (\(Pat.Event _ Arc{..} events) ->
-    ((max start pos, min stop (pos + 1)), events))
+    ((max start position, min stop (position + 1)), events))
-        $ queryArc (segmentator pat) (Arc pos (pos + 1))
+        $ 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
+            action ev
-            whileEvents act
+            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 =
+colourToPixel c = rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255)
-    -- mapRGB (surfaceGetPixelFormat screen) 255 255 255
-    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 =
+colourToPixelS surface c =
-    (mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255)
+    (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 }

src/Examples.hs

@@ -9,10 +9,7 @@ import VisCycle
 import VisGradient
 
 
--- | Examples
+-- | Examples how to render still images to PDF or SVG formats.
---
--- | For  pattern animation look at 'runAnimation' function at 'CycleAnimation.hs' module.
--- | There two forms of moving patterns: cycle and rectangle.
 --
 -- | 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

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
+
+
+

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)
+
+
+

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

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
+
 

tidal-vis.cabal

@@ -1,7 +1,6 @@
 name:                tidal-vis
-version:             1.0.7
+version:             1.0.13
-synopsis:            Visual rendering for Tidal patterns
+synopsis:            Visual rendering for Tidal patterns and osc messages
--- description:
 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
+                  , async
-                  , colour
                   , cairo
+                  , colour
+                  , containers
+                  , gloss
+                  , hashable
+                  , hosc
                   , SDL
-                  , mtl
                   , SDL-gfx
                   , SDL-image
                   , SDL-ttf
-                  , hosc
+                  , mtl
-                  , hashable
-                  , time
                   , 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