tidal-vis 0.9.3 → 1.0.14
raw patch · 13 files changed
+1244/−74 lines, 13 filesdep +SDLdep +SDL-gfxdep +SDL-imagedep ~basedep ~tidalnew-component:exe:tidal-vis
Dependencies added: SDL, SDL-gfx, SDL-image, SDL-ttf, async, containers, gloss, hashable, hosc, mtl, network, tidal-vis, time, unagi-chan
Dependency ranges changed: base, tidal
Files
- Sound/Tidal/Vis.hs +0/−67
- app/Main.hs +6/−0
- src/Common.hs +132/−0
- src/CycleAnimation.hs +282/−0
- src/Examples.hs +117/−0
- src/Realtime/Animation.hs +57/−0
- src/Realtime/Server.hs +58/−0
- src/Realtime/Types.hs +84/−0
- src/Vis.hs +117/−0
- src/VisCycle.hs +91/−0
- src/VisGradient.hs +95/−0
- src/VisPart.hs +136/−0
- tidal-vis.cabal +69/−7
− Sound/Tidal/Vis.hs
@@ -1,67 +0,0 @@-module Sound.Tidal.Vis where--import qualified Graphics.Rendering.Cairo as C -import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import Control.Applicative-import Sound.Tidal.Parse-import Sound.Tidal.Pattern-import Sound.Tidal.Utils-import Data.Ratio--vPDF = v C.withPDFSurface-vSVG = v C.withSVGSurface--v sf fn (x,y) pat = - sf fn x y $ \surf -> do- C.renderWith surf $ do - C.save - C.scale x y- C.setOperator C.OperatorOver- C.setSourceRGB 0 0 0 - C.rectangle 0 0 1 1- C.fill- mapM_ renderEvent (events pat)- C.restore ---vLines sf fn (x,y) pat cyclesPerLine nLines = - sf fn x y $ \surf -> do- C.renderWith surf $ do - C.save - C.scale x (y / (fromIntegral nLines))- C.setOperator C.OperatorOver- C.setSourceRGB 0 0 0 - C.rectangle 0 0 1 1- C.fill- mapM_ (\x -> do C.save- C.translate 0 (fromIntegral x)- drawLine ((cyclesPerLine * (fromIntegral x)) `rotR` pat)- C.restore- ) [0 .. (nLines - 1)]- C.restore - where drawLine p = mapM_ renderEvent (events (_density cyclesPerLine p))---renderEvent (_, (s,e), (cs)) = do C.save- drawBlocks cs 0- C.restore- where height = 1/(fromIntegral $ length cs)- drawBlocks [] _ = return ()- drawBlocks (c:cs) n = do let (RGB r g b) = toSRGB c- C.setSourceRGBA r g b 1- C.rectangle x y w h- C.fill- C.stroke- drawBlocks cs (n+1)- where x = (fromRational s)- y = (fromIntegral n) * height- w = (fromRational (e-s))- h = height---events pat = (map (mapSnd' (\(s,e) -> ((s - (ticks/2))/speed,(e - (ticks/2))/speed))) $ arc (segment pat) ((ticks/2), (ticks/2)+speed))- where speed = 1-ticks = 0---pat = p "[red blue green,orange purple]" :: Sequence ColourD
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Realtime.Server (animeCollectorServerU)++main :: IO ()+main = animeCollectorServerU
+ src/Common.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE NamedFieldPuns #-}++module Common+ ( arrangeEvents+ , beatNow+ , dirtToColour+ , fi+ , levels+ , levelsWhole+ , remoteLocal+ , segmentator+ , toPattern+ ) where++import Control.Concurrent.MVar+import Data.Bits (shiftR, (.&.))+import Data.Colour.SRGB (sRGB)+import Data.Function (on)+import Data.Hashable (hash)+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 functions.+fi :: (Integral a, Num b) => a -> b+fi = fromIntegral++fitsWhole :: Event b -> [Event b] -> Bool+fitsWhole (Event whole' _ _) events = not $ any (\Event{..} -> isJust $ subArc whole' whole) events++addEventWhole :: Event b -> [[Event b]] -> [[Event b]]+addEventWhole e [] = [[e]]+addEventWhole e (level:ls)+ | fitsWhole e level = (e:level) : ls+ | otherwise = level : addEvent e ls++arrangeEventsWhole :: [Event b] -> [[Event b]]+arrangeEventsWhole = foldr addEventWhole []++levelsWhole :: Pattern a -> [[Event a]]+levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> stop - start) . part) (queryArc pat (Arc 0 1))++fits :: Event b -> [Event b] -> Bool+fits (Event _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events++addEvent :: Event b -> [[Event b]] -> [[Event b]]+addEvent e [] = [[e]]+addEvent e (level:ls)+ | fits e level = (e:level) : ls+ | otherwise = level : addEvent e ls++arrangeEvents :: [Event b] -> [[Event b]]+arrangeEvents = foldr addEvent []++levels :: Pattern a -> [[Event a]]+levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (queryArc pat (Arc 0 1))++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 deprecated functions for 1.0.13+dirtToColour :: ControlPattern -> Pattern ColourD+dirtToColour = fmap (stringToColour . show)++stringToColour :: String -> ColourD+stringToColour str = sRGB (r/256) (g/256) (b/256)+ where+ i = hash str `mod` 16777216+ r = fromIntegral $ (i .&. 0xFF0000) `shiftR` 16+ g = fromIntegral $ (i .&. 0x00FF00) `shiftR` 8+ b = fromIntegral (i .&. 0x0000FF)++segmentator :: Pattern ColourD -> Pattern [ColourD]+segmentator p@Pattern{..} = Pattern nature+ $ \(State arc@Arc{..} _)+ -> filter (\(Event _ (Arc start' stop') _) -> start' < stop && stop' > start)+ $ groupByTime (segment' (queryArc p arc))++segment' :: [Event a] -> [Event a]+segment' es = foldr split es pts+ where pts = nub $ points es++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+ | otherwise = ev:split t es++points :: [Event a] -> [Time]+points [] = []+points (Event _ Arc{..} _ : es) = start : stop : points es++groupByTime :: [Event a] -> [Event [a]]+groupByTime es = map merge $ groupBy ((==) `on` part) $ sortOn (stop . part) es+ where+ merge :: [EventF a b] -> EventF a [b]+ merge evs@(Event{whole, part} : _) = Event whole part $ map (\Event{value} -> value) evs+ merge _ = error "groupByTime"++beatNow :: Tempo.Tempo -> IO Double+beatNow t = do+ now <- getCurrentTime+ at <- case OSC.iso_8601_to_utctime $ OSC.time_pp $ Tempo.atTime t of+ Nothing -> pure now+ Just at' -> pure at'+ let delta = realToFrac $ diffUTCTime now at+ let beatDelta = Tempo.cps t * delta+ return $ Tempo.nudged t + beatDelta++remoteLocal :: Config -> OSC.Time -> IO (MVar Tempo.Tempo)+remoteLocal config time = do+ let tempoClientPort = cTempoClientPort config+ hostname = cTempoAddr config+ remotePort = cTempoPort config+ (remote_addr:_) <- getAddrInfo Nothing (Just hostname) Nothing+ local <- OSC.udpServer "127.0.0.1" tempoClientPort+ 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+
+ src/CycleAnimation.hs view
@@ -0,0 +1,282 @@+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 qualified Sound.Tidal.Pattern as Pat++import Common+++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)+ runLoop env scene++runLoop :: AppConfig -> Scene -> IO ()+runLoop = evalStateT . runReaderT looping++-- | 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+ 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++ -- | (2) Rectangular form of moving patterns+ drawPatR (0, fi screenHeight) (dirtToColour pat) screen beat++ Graphics.UI.SDL.flip screen+ FR.delay fps+ unless quit' looping+ where+ action e = do+ scene <- get+ scene' <- handleEvent scene e+ put scene'++initEnv :: MVar ControlPattern -> IO AppConfig+initEnv mp = do+ time' <- FD.time+ screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface]+ font' <- openFont "futura.ttf" 22+ setCaption "Cycle" []+ tempoMV' <- remoteLocal defaultConfig time'+ fps <- FR.new+ FR.init fps+ return $ AppConfig screen font' tempoMV' fps mp++-- Draw one cycle pattern.+drawArc+ :: Surface+ -> ColourD+ -> (Double, Double) -- Middle`s coord+ -> (Double, Double) -- Torus`s internal and external radiuses.+ -> Double -- (pi*2) * fromRational (s - (toRational $ beat / 8))+ -> Double -- ((pi*2) * fromRational (e-s))+ -> Double -- pace+ -> IO ()+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 - pace) pace+ return ()+ where+ 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'))+ [ (r * cos a, r * sin a) -- 1+ , (r' * cos a, r' * sin a) -- 2+ , (r' * cos b, r' * sin b) -- 3+ , (r * cos b, r * sin b) -- 4+ ]++-- Draw cycle patterns continiously.+drawPatC+ :: (Double, Double)+ -> Pat.Pattern ColourD+ -> Surface+ -> Double+ -> IO ()+drawPatC (r,r') pat screen beat = mapM_ drawEvents $ event (pos beat) pat+ where+ drawEvents :: ((Rational, Rational), [ColourD]) -> IO ()+ 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 (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 (b - pos beat)) ((pi*2) * fromRational (e - b)) (pi/16)++-- 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 -- pace (pi/16)+ -> IO ()+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 - pace) pace+ return ()+ where+ a = max t (t + o - pace) --+ b = t + o++ coords = map (\(x',y') -> (floor x', floor y'))+ [ (b, thickStart) -- 1+ , (b, thickEnd) -- 2+ , (a, thickEnd) -- 3+ , (a, thickStart) -- 4+ ]++-- Draw rectangle patterns continiously+drawPatR :: (Double, Double) -> Pat.Pattern ColourD -> Surface -> Double -> IO ()+drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event (pos beat) p+ where+ drawEvents :: ((Rational, Rational), [ColourD]) -> IO ()+ 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 (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 (b - pos beat)) (width * fromRational (e - b)) 1++event :: Rational -> Pat.Pattern ColourD -> [((Rational, Rational), [ColourD])]+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 action = do+ ev <- liftIO pollEvent+ case ev of+ Quit -> return True+ NoEvent -> return False+ _ -> do+ action ev+ whileEvents action++textSize :: String -> Font -> IO (Float,Float)+textSize text font' =+ do message <- renderTextSolid font' text (Color 0 0 0)+ return (fromScreen (surfaceGetWidth message, surfaceGetHeight message))++colourToPixel :: Colour Double -> Pixel+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 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+rgbColor r g b = Pixel+ ( shiftL (fi r) 24+ .|. shiftL (fi g) 16+ .|. shiftL (fi b) 8+ .|. fi (255 :: Integer)+ )++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 view
@@ -0,0 +1,117 @@+module Examples where++import Data.Colour+import Sound.Tidal.Context++import Common (dirtToColour)+import Vis+import VisCycle+import VisGradient+++-- | Examples how to render still images to PDF or SVG formats.+--+-- | Here is renders of still images only.+main :: IO ()+main = do+ renderMatBundlePDF "./examples/" [a, b, c, d, e, f, g]+ return ()++-- | Make mat rectangle pattern+matRect :: IO ()+matRect = renderMatPDF "./examples/matRect" pip++-- | Make bundle of mat rectangle pattern+matBundleRect :: IO ()+matBundleRect = renderMatBundlePDF "./examples/" [foo, pip, pop, bar, buz]++-- | Make gradient rectangle pattern+gradientRect :: IO ()+gradientRect = renderGradientPDF "./examples/gradientRect" pip++-- | Make gradient rectangle pattern+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+ "2? 3 1 2"++pip :: Pattern ColourD+pip = dirtToColour $ fast 12 $ sound+ "[bd bd bd, <[sd sd] cp>, <arpy [arpy <[arpy arpy]> arpy arpy]>, odx]"++pop :: Pattern ColourD+pop = dirtToColour $ fast 12 $ loopAt 3 $ sound+ "[~ bd bd ~] ~ [bd ~ ~ [sd ~ ~ sd] ~ ~ sd]"++bar :: Pattern ColourD+bar = dirtToColour $ fast 12 $ sound "{~ ~ ~ ~, arpy bass2 drum notes can}"++buz :: Pattern ColourD+buz =+ dirtToColour $ fast 24 $ sound "arpy*4" # pan (range 0.25 0.75 sine) # gain+ (range 1.2 0.5 sine)++a :: Pattern ColourD+a = density 16 $ every 2 rev $ every 3 (superimpose (iter 4)) $ rev+ "[black blue darkblue, grey lightblue]"++b :: Pattern (Colour Double)+b = flip darken <$> "[black blue orange, red green]*16" <*> sine++c :: Pattern (Colour Double)+c =+ density 10+ $ flip darken+ <$> "[black blue, grey ~ navy, cornflowerblue blue]*2"+ <*> (slow 5 $ (*) <$> sine <*> (slow 2 tri))++d :: Pattern (Colour Double)+d =+ every 2 rev+ $ density 10+ $ ( blend'+ <$> "blue navy"+ <*> "orange [red, orange, purple]"+ <*> (slow 6 $ sine)+ )+ where blend' x y z = blend z x y++e :: Pattern (Colour Double)+e =+ density 32+ $ flip over+ <$> "[grey olive, black ~ brown, darkgrey]"+ <*> ( withOpacity+ <$> "[beige, lightblue white darkgreen, beige]"+ <*> ((*) <$> (slow 8 $ slow 4 sine) <*> (slow 3 $ sine))+ )++f :: Pattern ColourD+f =+ density 2+ $ flip darken+ <$> (density 8 $ "[black blue, grey ~ navy, cornflowerblue blue]*2")+ <*> sine++g :: Pattern ColourD+g = density 2 $ do+ let x = "[skyblue olive, grey ~ navy, cornflowerblue green]"+ coloura <- density 8 x+ colourb <- density 4 x+ slide' <- slow 2 sine+ return $ blend slide' coloura colourb
+ src/Realtime/Animation.hs view
@@ -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 view
@@ -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 view
@@ -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
+ src/Vis.hs view
@@ -0,0 +1,117 @@+module Vis+ ( magicallyMakeEverythingFaster+ , renderMatPDF+ , renderMatSVG+ , renderMatBundlePDF+ , renderMatBundleSVG+ , svgAsString+ , vPDF+ , vSVG+ ) where++import Data.Colour.SRGB+import Sound.Tidal.Context hiding (segment)++import Common++import qualified Graphics.Rendering.Cairo as C++-- | Render PDF.+vPDF+ :: FilePath -- ^ path/filename without extansion.+ -> (Double, Double) -- ^ Image size.+ -> Pattern ColourD -- ^ Pattern. See 'Examples.hs' for pattern examples.+ -> IO ()+vPDF = v C.withPDFSurface++vSVG :: FilePath -> (Double, Double) -> Pattern ColourD -> IO ()+vSVG = v C.withSVGSurface++-- | Render bundle of patterns to PDF.+renderMatBundlePDF :: FilePath -> [Pattern ColourD] -> IO ()+renderMatBundlePDF path xs = mapM_ (\(num, p)+ -> vPDF (concat [path, "patternP_", show num, ".pdf"]) (1600,400) p)+ $ zip [(0::Int)..] xs++-- | Render bundle of patterns to SVG.+renderMatBundleSVG :: FilePath -> [Pattern ColourD] -> IO ()+renderMatBundleSVG path xs = mapM_ (\(num, p)+ -> vSVG (concat [path, "patternS_", show num, ".svg"]) (1600,400) p)+ $ zip [(0::Int)..] xs++-- | First argument is order number for name.+renderMatPDF :: String -> Pattern ColourD -> IO ()+renderMatPDF name = vPDF (concat [name, ".pdf"]) (1600, 400)++-- | First argument is order number for name.+renderMatSVG :: String -> Pattern ColourD -> IO ()+renderMatSVG name = vSVG (concat [name, ".svg"]) (1600, 400)++-- | Show svg code of pattern.+svgAsString :: Pattern ColourD -> IO String+svgAsString pat = do+ renderMatSVG "/tmp/vis2-tmp" pat+ readFile "/tmp/vis2-tmp.svg"++magicallyMakeEverythingFaster :: Pattern a -> [Event a]+magicallyMakeEverythingFaster = splitArcs 16+ where+ splitArcs num p = concatMap+ (\i -> queryArc p $ Arc i $ i+(1/num)) [0, (1/num) .. (1-(1/num))]++-- | Constant.+ticks :: Ratio Integer+ticks = 1++v :: (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ())+ -> FilePath+ -> (Double, Double) -- ^ Image output size.+ -> Pattern ColourD+ -> IO ()+v sf fn (x,y) pat =+ sf fn x y $ \surf ->+ C.renderWith surf $ do+ C.save+ C.scale x y+ C.setOperator C.OperatorOver+ C.setSourceRGB 0 0 0+ C.rectangle 0 0 1 1+ C.fill+ mapM_ renderEvent (events pat)+ C.restore++-- | Convert time and color to rendered type.+renderEvent :: Event [ColourD] -> C.Render ()+renderEvent (Event _ Arc{..} value) = do+ C.save+ drawBlocks value 0+ C.restore+ where+ height = 1 / fromIntegral (length value)+ drawBlocks :: [ColourD] -> Integer -> C.Render ()+ drawBlocks [] _ = return ()+ drawBlocks (c:cs) num = do+ let (RGB r g b) = toSRGB c+ let x = fromRational start+ let y = fromIntegral num * height+ let w = fromRational (stop - start)+ let h = height+ C.setSourceRGBA r g b 1+ C.rectangle x y w h+ C.fill+ C.stroke+ drawBlocks cs (num + 1)++events :: Pattern ColourD -> [Event [ColourD]]+events pat = map+ ( \(Event whole Arc{..} value)+ -> Event whole (Arc ((start - tick) / speed') ((stop - tick) / speed')) value+ )+ $ queryArc (segmentator pat) (Arc tick (tick + speed'))+ where+ speed' :: Ratio Integer+ speed' = 1+ tick :: Ratio Integer+ tick = ticks / 2++
+ src/VisCycle.hs view
@@ -0,0 +1,91 @@+module VisCycle+ ( renderCyclePDF+ , renderCycleSVG+ ) where++import Data.Colour.SRGB+import Sound.Tidal.Context+import Sound.Tidal.Utils++import Common++import qualified Graphics.Rendering.Cairo as C+++-- | Constants.+totalWidth :: Double+totalWidth = 500++border :: Double+border = 5++v :: (String -> Double -> Double -> (C.Surface -> IO ()) -> IO ())+ -> String -- ^ filePath+ -> (Double, Double) -- ^ size+ -> [[Event ColourD]]+ -> String -- ^ label+ -> IO ()+v sf fn (x,y) colorEvents label =+ sf fn x y $ \surf -> C.renderWith surf $ do+ C.setAntialias C.AntialiasBest+ C.save+ C.translate border border+ C.scale (totalWidth-(border*2)) (totalWidth-(border*2))+ C.setOperator C.OperatorOver+ C.selectFontFace ("Inconsolata" :: String) C.FontSlantNormal C.FontWeightNormal+ C.setFontSize 0.2+ (C.TextExtents _ _ _ textH _ _) <- C.textExtents (label :: String)+ C.moveTo 0 textH+ C.textPath (label :: String)+ C.setSourceRGB 0 0 0+ C.fill+ -- C.setSourceRGB 0 0 0+ -- C.rectangle 0 0 1 1+ -- C.fill+ mapM_ (renderLevel (length colorEvents)) $ enumerate colorEvents+ C.restore++renderLevel :: Int -> (Int, [Event ColourD]) -> C.Render ()+renderLevel total (num, level) = do+ C.save+ mapM_ drawEvent level+ C.restore+ where+ drawEvent :: Event ColourD -> C.Render ()+ drawEvent (Event _ Arc{..} c) = do+ let (RGB r g b) = toSRGB c+ let levelHeight = (1 / fi (total+1))/2+ let h = levelHeight * fi (num + 1)+ let hPi = pi / 2+ let dPi = pi * 2+ C.save+ C.setSourceRGBA r g b 1+ C.arc 0.5 0.5 (h+levelHeight) (fromRational start * dPi - hPi) (fromRational stop * dPi - hPi)+ C.arcNegative 0.5 0.5 h (fromRational stop * dPi - hPi) (fromRational start * dPi - hPi)+ C.fill+ C.setSourceRGBA 0.5 0.5 0.5 1+ C.setLineWidth 0.005+ C.arc 0.5 0.5 (h+levelHeight) (fromRational start * dPi - hPi) (fromRational stop * dPi - hPi)+ C.arcNegative 0.5 0.5 h (fromRational stop * dPi - hPi) (fromRational start * dPi - hPi)+ C.stroke+ C.restore++-- | Render a cycle pattern to pdf file.+renderCyclePDF+ :: String -- ^ File name (and path)+ -> String -- ^ Background text+ -> Pattern ColourD+ -> IO ()+renderCyclePDF name label pat = do+ v C.withPDFSurface (name ++ ".pdf") (totalWidth, totalWidth) (levels pat) label+ return ()++ -- | Render a cycle pattern to pdf file.+renderCycleSVG+ :: String -- ^ File name (and path)+ -> String -- ^ Background text+ -> Pattern ColourD+ -> IO ()+renderCycleSVG name label pat = do+ v C.withSVGSurface (name ++ ".svg") (totalWidth, totalWidth) (levels pat) label+ return ()
+ src/VisGradient.hs view
@@ -0,0 +1,95 @@+module VisGradient+ ( renderGradientSVG+ , renderGradientPDF+ ) where++import Data.Colour.SRGB+import Sound.Tidal.Context+import Sound.Tidal.Utils++import qualified Graphics.Rendering.Cairo as C++import Common+++-- | Constans+totalWidth :: Double+totalWidth = 1700++ratio :: Double+ratio = 3/40++levelHeight :: Double+levelHeight = totalWidth * ratio++v :: (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ())+ -> FilePath+ -> (Double, Double)+ -> [[Event ColourD]]+ -> IO ()+v sf fn (x,y) colorEvents = sf fn x y $ \surf ->+ C.renderWith surf $ do+ C.save+ -- C.scale x (y / (fromIntegral $ length colorEvents))+ C.setOperator C.OperatorOver+ -- C.setSourceRGB 0 0 0+ -- C.rectangle 0 0 1 1+ --C.fill+ mapM_ (renderLevel (length colorEvents)) $ enumerate colorEvents+ C.restore++renderLevel+ :: (Foldable t, Integral a)+ => p+ -> (a, t (Event ColourD))+ -> C.Render ()+renderLevel _ (num, level) = do+ C.save+ mapM_ drawEvent $ level+ C.restore+ where+ drawEvent (Event (Arc sWhole eWhole) Arc{..} c) = do+ let (RGB r g b) = toSRGB c+ let x = (fromRational start) * totalWidth+ let y = (fromIntegral num) * levelHeight+ let xWhole = (fromRational sWhole) * totalWidth+ -- let w = levelHeight+ let lineW = (fromRational (stop - start) * totalWidth)+ let wholeLineW = (fromRational (eWhole-sWhole) * totalWidth)+ -- let lineH = 2+ -- let lgap = 3+ -- let rgap = 3+ -- let border = 3+ -- let half = levelHeight / 2+ -- let quarter = levelHeight / 4+ -- C.setSourceRGBA 0.6 0.6 0.6 1+ -- C.rectangle x y lineW levelHeight+ C.withLinearPattern xWhole 0 (wholeLineW + xWhole) 0 $ \pat -> do+ -- C.patternAddColorStopRGB pat 0 0 0 0+ -- C.patternAddColorStopRGB pat 0.5 1 1 1+ C.save+ C.patternAddColorStopRGBA pat 0 r g b 1+ C.patternAddColorStopRGBA pat 1 r g b 0.5+ C.patternSetFilter pat C.FilterFast+ C.setSource pat+ -- C.setSourceRGBA r g b 1+ -- C.arc (x+half) (y+half) (w/2) 0 (2 * pi)+ C.rectangle x y lineW levelHeight+ C.fill+ C.restore+ -- C.stroke+ -- C.fill+ -- C.stroke++renderGradientSVG :: String -> Pattern ColourD -> IO ()+renderGradientSVG name pat = do+ v C.withSVGSurface (name ++ ".svg")+ (totalWidth, levelHeight * (fromIntegral $ length $ levels pat)) $ levels pat+ return ()++renderGradientPDF :: String -> Pattern ColourD -> IO ()+renderGradientPDF name pat = do+ v C.withPDFSurface (name ++ ".pdf")+ (totalWidth, levelHeight * (fromIntegral $ length $ levels pat)) $ levels pat+ return ()+
+ src/VisPart.hs view
@@ -0,0 +1,136 @@+module VisPart+ ( renderPartSVG+ , renderPartPDF+ ) where++import Data.Colour.SRGB+import Sound.Tidal.Context+import Sound.Tidal.Utils++import qualified Graphics.Rendering.Cairo as C++import Common+++-- | Constans+totalWidth :: Double+totalWidth = 1700++ratio :: Double+ratio = 3/40++levelHeight :: Double+levelHeight = totalWidth * ratio++v :: Show a => (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ())+ -> FilePath+ -> (Double, Double)+ -> [[Event a]]+ -> IO ()+v sf fn (x,y) es = sf fn x y $ \surf ->+ C.renderWith surf $ do+ C.save+ -- C.scale x (y / (fromIntegral $ length colorEvents))+ C.setOperator C.OperatorOver+ -- C.setSourceRGB 0 0 0+ -- C.rectangle 0 0 1 1+ --C.fill+ C.setAntialias C.AntialiasBest+ mapM_ (renderLevel (length es)) $ enumerate es+ C.restore++renderLevel+ :: (Foldable t, Integral a, Show b)+ => p+ -> (a, t (Event b))+ -> C.Render ()+renderLevel _ (num, level) = do+ C.save+ mapM_ drawEvent $ level+ C.restore+ where+ drawEvent (Event (Arc sWhole eWhole) (Arc sPart ePart) v) = do+ let (r, g, b) = (0,0,0)+ let px = (fromRational sPart) * totalWidth+ let wx = (fromRational sWhole) * totalWidth+ let y = (fromIntegral num) * levelHeight+ let pw = (fromRational (ePart - sPart) * totalWidth)+ let ww = (fromRational (eWhole - sWhole) * totalWidth)+ let gap = 12+ let lw = 2+ halfLw = lw /2+ halfGap = gap / 2++ C.withLinearPattern wx 0 (ww + wx) 0 $ \pat -> do+ C.save+ C.patternAddColorStopRGBA pat 0 0.8 0.8 0.8 1+ C.patternAddColorStopRGBA pat 1 0 0 0 0.5+ C.patternSetFilter pat C.FilterFast+ C.setSource pat+ let leftGap = if px == wx then halfGap else 0+ rightGap = if px+pw == wx+ww then halfGap else 0+ C.rectangle (px+leftGap) (y+halfGap) ((pw-(leftGap+rightGap))) (levelHeight-gap)+ C.fill+ C.restore+ C.save+ C.setSourceRGBA 0 0 0 1+ C.setLineWidth lw+ C.moveTo (px+leftGap) (y+halfGap)+ C.lineTo (px+pw-(rightGap)) (y+halfGap)+ C.moveTo (px+leftGap) (y+levelHeight-halfGap)+ C.lineTo (px+pw-(rightGap)) (y+levelHeight-halfGap)+ C.stroke+ if px == wx+ then do C.moveTo (px+halfGap) (y+levelHeight-halfGap)+ C.lineTo (px+halfGap) (y+halfGap)+ C.stroke+ else (do C.setDash [6,4] 6+ C.moveTo (px) (y+halfGap)+ C.lineTo (wx+halfGap) (y+halfGap)+ C.lineTo (wx+halfGap) (y+levelHeight-halfGap)+ C.lineTo (px) (y+levelHeight-halfGap)+ C.stroke+ C.setDash [] 0+ return ()+ )+ if (px+pw) == (wx+ww)+ then do C.moveTo (px+pw-halfGap) (y+levelHeight-halfGap)+ C.lineTo (px+pw-halfGap) (y+halfGap)+ C.stroke+ return ()+ else (do C.setDash [6,4] 0+ C.moveTo (px+pw) (y+halfGap)+ C.lineTo (wx+ww-halfGap) (y+halfGap)+ C.lineTo (wx+ww-halfGap) (y+levelHeight-halfGap)+ C.lineTo (px+pw) (y+levelHeight-halfGap)+ C.stroke+ C.setDash [] 0+ return ()+ )+ C.restore+ C.selectFontFace ("Inconsolata" :: String) C.FontSlantNormal C.FontWeightNormal+ C.setFontSize 35+ (C.TextExtents _ _ textW textH _ _) <- C.textExtents (show v)+ C.moveTo (wx + 12) (y + textH + 16)+ C.textPath (show v)+ C.setSourceRGB 0 0 0+ C.fill+-- C.save+-- C.translate border border+-- C.scale (totalWidth-(border*2)) (totalWidth-(border*2))+-- C.setOperator C.OperatorOver+ -- C.fill+ -- C.stroke++renderPartSVG :: Show a => String -> Pattern a -> IO ()+renderPartSVG name pat = do+ v C.withSVGSurface (name ++ ".svg")+ (totalWidth, levelHeight * (fromIntegral $ length $ levelsWhole pat)) $ levelsWhole pat+ return ()++renderPartPDF :: Show a => String -> Pattern a -> IO ()+renderPartPDF name pat = do+ v C.withPDFSurface (name ++ ".pdf")+ (totalWidth, levelHeight * (fromIntegral $ length $ levelsWhole pat)) $ levelsWhole pat+ return ()+
tidal-vis.cabal view
@@ -1,23 +1,85 @@ name: tidal-vis-version: 0.9.3-synopsis: Visual rendering for Tidal patterns--- description: +version: 1.0.14+synopsis: Visual rendering for Tidal patterns and osc messages homepage: http://yaxu.org/tidal/ license: GPL-3 license-file: LICENSE author: Alex McLean maintainer: alex@slab.org Stability: Experimental-Copyright: (c) Alex McLean and others, 2017+Copyright: (c) Alex McLean and others, 2019 category: Sound build-type: Simple-cabal-version: >=1.4+cabal-version: 2.0 --Extra-source-files: README.md tidal.el doc/tidal.md doc/tidal.pdf 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: Sound.Tidal.Vis+ Exposed-modules: Common+ CycleAnimation+ Examples+ Realtime.Animation+ Realtime.Server+ Realtime.Types+ Vis+ VisCycle+ VisGradient+ VisPart - Build-depends: base < 5, tidal>=0.9.3, colour, cairo+ hs-source-dirs: src++ Build-depends: base < 5+ , async+ , cairo+ , colour+ , containers+ , gloss+ , hashable+ , hosc+ , SDL+ , SDL-gfx+ , SDL-image+ , SDL-ttf+ , mtl+ , network+ , tidal >= 1.0.15+ , 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