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 0000000..7e67931 Binary files /dev/null and b/examples/cycle.pdf differ diff --git a/examples/gradientRect.pdf b/examples/gradientRect.pdf new file mode 100644 index 0000000..1f5c311 Binary files /dev/null and b/examples/gradientRect.pdf differ 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