diff --git a/Sound/Tidal/Vis.hs b/Sound/Tidal/Vis.hs deleted file mode 100644 --- a/Sound/Tidal/Vis.hs +++ /dev/null @@ -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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Realtime.Server (animeCollectorServerU) + +main :: IO () +main = animeCollectorServerU diff --git a/src/Common.hs b/src/Common.hs new file mode 100644 --- /dev/null +++ b/src/Common.hs @@ -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 + diff --git a/src/CycleAnimation.hs b/src/CycleAnimation.hs new file mode 100644 --- /dev/null +++ b/src/CycleAnimation.hs @@ -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 } diff --git a/src/Examples.hs b/src/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Examples.hs @@ -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]>, 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 diff --git a/src/Realtime/Animation.hs b/src/Realtime/Animation.hs new file mode 100644 --- /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 --- /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 --- /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/src/Vis.hs b/src/Vis.hs new file mode 100644 --- /dev/null +++ b/src/Vis.hs @@ -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 + + diff --git a/src/VisCycle.hs b/src/VisCycle.hs new file mode 100644 --- /dev/null +++ b/src/VisCycle.hs @@ -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 () diff --git a/src/VisGradient.hs b/src/VisGradient.hs new file mode 100644 --- /dev/null +++ b/src/VisGradient.hs @@ -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 () + diff --git a/src/VisPart.hs b/src/VisPart.hs new file mode 100644 --- /dev/null +++ b/src/VisPart.hs @@ -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 () + diff --git a/tidal-vis.cabal b/tidal-vis.cabal --- a/tidal-vis.cabal +++ b/tidal-vis.cabal @@ -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