diff --git a/Sound/Tidal/Cycle.hs b/Sound/Tidal/Cycle.hs new file mode 100644 index 0000000..8182eeb --- /dev/null +++ b/Sound/Tidal/Cycle.hs @@ -0,0 +1,283 @@ +module Sound.Tidal.Cycle where + +import Control.Monad +import Control.Monad.State +import Control.Monad.Reader +import Control.Concurrent.MVar +import Data.Array.IArray + +import Graphics.UI.SDL +import Graphics.UI.SDL.Image +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 Graphics.UI.SDL.TTF.Management +import Graphics.UI.SDL.TTF.Render +import Graphics.UI.SDL.TTF.Types +import Data.Maybe (listToMaybe, fromMaybe, fromJust, isJust, catMaybes) +import GHC.Int (Int16) +import Data.List (intercalate, tails, nub, sortBy) +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB +import Data.Colour.RGBSpace.HSV (hsv) +import qualified GHC.Word +import Data.Bits +import Data.Ratio +import Debug.Trace (trace) +import Data.Fixed (mod') +import Control.Concurrent +import System.Exit + +import Sound.OSC.FD + +import Sound.Tidal.Stream (ParamPattern) +import Sound.Tidal.Pattern +import Sound.Tidal.Parse +import Sound.Tidal.Tempo +import qualified Sound.Tidal.Time as Time +import Sound.Tidal.Utils + + +--enumerate :: [a] -> [(Int, a)] +--enumerate = zip [0..] + +maybeHead [] = Nothing +maybeHead (x:_) = Just x + +sortByFst :: Ord a => [(a, b)] -> [(a, b)] +sortByFst = sortBy (\a b -> compare (fst a) (fst b)) + +parenthesise :: String -> String +parenthesise x = "(" ++ x ++ ")" + +spaces :: Int -> String +spaces n = take n $ repeat ' ' + +single :: [a] -> Maybe a +single (x:[]) = Just x +single _ = Nothing + +fromJust' (Just x) = x +fromJust' Nothing = error "nothing is just" + +data Scene = Scene {mouseXY :: (Float, Float), + cursor :: (Float, Float) + } + +data AppConfig = AppConfig { + screen :: Surface, + font :: Font, + tempoMV :: MVar (Tempo), + fr :: FR.FPSManager, + mpat :: MVar (Pattern ColourD) +} + +type AppState = StateT Scene IO +type AppEnv = ReaderT AppConfig AppState + + + +screenWidth = 1024 +screenHeight = 768 +screenBpp = 32 +middle = (fromIntegral $ screenWidth`div`2,fromIntegral $ screenHeight`div`2) + +toScreen :: (Float, Float) -> (Int, Int) +toScreen (x, y) = (floor (x * (fromIntegral screenWidth)), + floor (y * (fromIntegral screenHeight)) + ) + +toScreen16 :: (Float, Float) -> (Int16, Int16) +toScreen16 (x, y) = (fromIntegral $ floor (x * (fromIntegral screenWidth)), + fromIntegral $ floor (y * (fromIntegral screenHeight)) + ) + +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 mods = or $ map (\x -> elem x [KeyModLeftCtrl, + KeyModRightCtrl + ] + ) mods + +shiftDown mods = or $ map (\x -> elem x [KeyModLeftShift, + KeyModRightShift, + KeyModShift + ] + ) mods + +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 offset + where offset = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 } + +initEnv :: MVar (Pattern ColourD) -> IO AppConfig +initEnv mp = do + screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface] + font <- openFont "futura.ttf" 22 + setCaption "Cycle" [] + tempoMV <- tempoMVar + fps <- FR.new + FR.init fps + FR.set fps 15 + return $ AppConfig screen font tempoMV fps mp + +blankWidth = 0.015 + +drawArc' :: Surface -> ColourD -> (Double, Double) -> (Double, Double) -> Double -> Double -> Double -> IO () +drawArc' screen c (x,y) (r,r') t o step | o <= 0 = return () + | otherwise = + do let pix = (colourToPixel c) + steps = [t, (t + step) .. (t + o)] + coords = map (\s -> (floor $ x + (r*cos(s)),floor $ y + (r*sin(s)))) steps + ++ map (\s -> (floor $ x + (r'*cos(s)),floor $ y + (r'*sin(s)))) (reverse steps) + SDLP.filledPolygon screen coords pix + --drawArc screen c (x,y) (r,r') t (o-step) step + return () + where a = max t (t + o - step) + b = t + o + + +drawArc :: Surface -> ColourD -> (Double, Double) -> (Double, Double) -> Double -> Double -> Double -> IO () +drawArc screen c (x,y) (r,r') t o step | o <= 0 = return () + | otherwise = + do let pix = (colourToPixel c) + SDLP.filledPolygon screen coords pix + drawArc screen c (x,y) (r,r') t (o-step) step + return () + where a = max t (t + o - step) + b = t + o + coords = map ((\(x',y') -> (floor $ x + x', floor $ y + y'))) + [(r * cos(a), r * sin(a)), + (r' * cos(a), r' * sin(a)), + (r' * cos(b), r' * sin(b)), + (r * cos(b), r * sin(b)) + ] + +loop :: AppEnv () +loop = do + quit <- whileEvents $ act + screen <- screen `liftM` ask + font <- font `liftM` ask + tempoM <- tempoMV `liftM` ask + fps <- fr `liftM` ask + scene <- get + mp <- mpat `liftM` ask + liftIO $ do + pat <- readMVar mp + tempo <- readMVar tempoM + beat <- beatNow tempo + bgColor <- (mapRGB . surfaceGetPixelFormat) screen 0x00 0x00 0x00 + clipRect <- Just `liftM` getClipRect screen + fillRect screen clipRect bgColor + --drawArc screen middle (100,110) ((beat) * pi) (pi/2) (pi/32) + drawPat middle (100,(fi screenHeight)/2) 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' + +drawPat :: (Double, Double) -> (Double, Double) -> Pattern ColourD -> Surface -> Double -> IO () +drawPat (x, y) (r,r') p screen beat = mapM_ drawEvents es + where es = map (\(_, (s,e), evs) -> ((max s pos, min e (pos + 1)), evs)) $ arc (segment p) (pos, pos + 1) + pos = toRational $ beat / 8 + drawEvents ((s,e), cs) = + mapM_ (\(n', c) -> drawEvent (s,e) c n' (length cs)) (enumerate $ reverse cs) + drawEvent (s,e) c n' len = + do let thickness = (1 / fromIntegral len) * (r' - r) + let start = r + thickness * (fromIntegral n') + drawArc screen c middle (start,start+thickness) ((pi*2) * (fromRational (s-pos))) ((pi*2) * fromRational (e-s)) (pi/16) +{- (thickLine h (n*scale+n') (linesz/ (fromIntegral scale)) + (x1 + (xd * fromRational (e-pos))) + (y1 + (yd * fromRational (e-pos))) + (x1 + (xd * fromRational (s-pos))) + (y1 + (yd * fromRational (s-pos))) + ) + screen (colourToPixel c)-} + +segment2 :: Pattern a -> Pattern [(Bool, a)] +segment2 p = Pattern $ \(s,e) -> filter (\(_, (s',e'),_) -> s' < e && e' > s) $ groupByTime (segment2' (arc (fmap (\x -> (True, x)) p) (s,e))) + + +segment2' :: [Time.Event (Bool, a)] -> [Time.Event (Bool, a)] +segment2' es = foldr splitEs es pts + where pts = nub $ points es + +splitEs :: Time.Time -> [Time.Event (Bool, a)] -> [Time.Event (Bool, a)] +splitEs _ [] = [] +splitEs t ((ev@(a, (s,e), (h,v))):es) | t > s && t < e = (a, (s,t),(h,v)):(a, (t,e),(False,v)):(splitEs t es) + | otherwise = ev:splitEs t es + +whileEvents :: MonadIO m => (Event -> m ()) -> m Bool +whileEvents act = do + event <- liftIO pollEvent + case event of + Quit -> return True + NoEvent -> return False + _ -> do + act event + whileEvents act + +runLoop :: AppConfig -> Scene -> IO () +runLoop = evalStateT . runReaderT loop + +textSize :: String -> Font -> IO ((Float,Float)) +textSize text font = + do message <- renderTextSolid font text (Color 0 0 0) + return (fromScreen (surfaceGetWidth message, surfaceGetHeight message)) + +run = do mp <- newMVar silence + forkIO $ run' mp + return mp + + +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 + + +-- colourToPixel :: Colour Double -> Pixel +-- colourToPixel c = rgbColor (floor $ 256*r) (floor $ 256* g) (floor $ 256*b) +-- where (RGB r g b) = toSRGB c + +colourToPixel :: Colour Double -> Pixel +colourToPixel c = rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255) -- mapRGB (surfaceGetPixelFormat screen) 255 255 255 + where (RGB r g b) = toSRGB c + +--colourToPixel :: Surface -> Colour Double -> IO Pixel +--colourToPixel s c = (mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255) + + +fi a = fromIntegral a + +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)) + +pixel :: Surface -> (GHC.Word.Word8,GHC.Word.Word8,GHC.Word.Word8) -> IO Pixel +pixel surface (r,g,b) = mapRGB (surfaceGetPixelFormat surface) r g b diff --git a/Sound/Tidal/Vis.hs b/Sound/Tidal/Vis.hs new file mode 100644 index 0000000..216c720 --- /dev/null +++ b/Sound/Tidal/Vis.hs @@ -0,0 +1,67 @@ +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/Sound/Tidal/Vis2.hs b/Sound/Tidal/Vis2.hs new file mode 100644 index 0000000..ed38e03 --- /dev/null +++ b/Sound/Tidal/Vis2.hs @@ -0,0 +1,91 @@ +module Sound.Tidal.Vis2 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.Time +import Sound.Tidal.Utils +import Data.Ratio +import Data.Maybe +import System.Cmd +import Data.List +import Data.Ord ( comparing ) + +totalWidth = 200 :: Double +ratio = 2/40 +levelHeight = totalWidth * ratio + +arrangeEvents [] = [] +arrangeEvents (e:es) = addEvent e (arrangeEvents es) +fits e es = null $ filter (id) $ map (\e' -> isJust $ subArc (snd' e) (snd' e')) es +addEvent e [] = [[e]] +addEvent e (level:levels) | fits e level = (e:level):levels + | otherwise = level:(addEvent e levels) + +v sf fn (x,y) levels = + sf fn x y $ \surf -> do + C.renderWith surf $ do + C.save + -- C.scale x (y / (fromIntegral $ length levels)) + C.setOperator C.OperatorOver + -- C.setSourceRGB 0 0 0 + -- C.rectangle 0 0 1 1 + --C.fill + mapM_ (renderLevel (length levels)) $ enumerate levels + C.restore + +renderLevel total (n, level) = do C.save + mapM_ drawEvent $ level + C.restore + where drawEvent ((sWhole, eWhole), (s,e), c) = + do let (RGB r g b) = toSRGB c + -- C.setSourceRGBA 0.6 0.6 0.6 1 + -- C.rectangle x y lineW levelHeight + C.withLinearPattern xWhole 0 (wholeLineW+xWhole) 0 $ \pattern -> + do --C.patternAddColorStopRGB pattern 0 0 0 0 + --C.patternAddColorStopRGB pattern 0.5 1 1 1 + C.save + C.patternAddColorStopRGBA pattern 0 r g b 1 + C.patternAddColorStopRGBA pattern 1 r g b 0.5 + C.patternSetFilter pattern C.FilterFast + C.setSource pattern + -- 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 + where x = (fromRational s) * totalWidth + y = (fromIntegral n) * levelHeight + xWhole = (fromRational sWhole) * totalWidth + w = levelHeight + lineW = ((fromRational $ e-s) * totalWidth) + wholeLineW = ((fromRational $ eWhole-sWhole) * totalWidth) + lineH = 2 + lgap = 3 + rgap = 3 + border = 3 + half = levelHeight / 2 + quarter = levelHeight / 4 + vPDF = v C.withPDFSurface + +vis name pat = do v (C.withSVGSurface) (name ++ ".svg") (totalWidth, levelHeight*(fromIntegral $ length levels)) levels + -- rawSystem "/home/alex/Dropbox/bin/fixsvg.pl" [name ++ ".svg"] + -- rawSystem "convert" [name ++ ".svg", name ++ ".pdf"] + return () + where levels = arrangeEvents $ sortOn ((\x -> snd x - fst x) . snd') (arc pat (0,1)) + sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +visAsString pat = do vis "/tmp/vis2-tmp" pat + svg <- readFile "/tmp/vis2-tmp.svg" + return svg + + +magicallyMakeEverythingFaster = splitArcs 16 + where splitArcs n p = concatMap (\i -> arc p (i,i+(1/n))) [0, (1/n) .. (1-(1/n))] diff --git a/Sound/Tidal/Vis2.hs~ b/Sound/Tidal/Vis2.hs~ new file mode 100644 index 0000000..f254c69 --- /dev/null +++ b/Sound/Tidal/Vis2.hs~ @@ -0,0 +1,85 @@ +module Sound.Tidal.Vis2 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.Time +import Sound.Tidal.Utils +import Data.Ratio +import Data.Maybe +import System.Cmd +import Data.List + +totalWidth = 600 :: Double +ratio = 1/40 +levelHeight = totalWidth * ratio + +arrangeEvents [] = [] +arrangeEvents (e:es) = addEvent e (arrangeEvents es) +fits e es = null $ filter (id) $ map (\e' -> isJust $ subArc (snd' e) (snd' e')) es +addEvent e [] = [[e]] +addEvent e (level:levels) | fits e level = (e:level):levels + | otherwise = level:(addEvent e levels) + +v sf fn (x,y) levels = + sf fn x y $ \surf -> do + C.renderWith surf $ do + C.save + -- C.scale x (y / (fromIntegral $ length levels)) + C.setOperator C.OperatorOver + -- C.setSourceRGB 0 0 0 + -- C.rectangle 0 0 1 1 + --C.fill + mapM_ (renderLevel (length levels)) $ enumerate levels + C.restore + +renderLevel total (n, level) = do C.save + mapM_ drawEvent $ level + C.restore + where drawEvent ((sWhole, eWhole), (s,e), c) = + do let (RGB r g b) = toSRGB c + -- C.setSourceRGBA 0.6 0.6 0.6 1 + -- C.rectangle x y lineW levelHeight + C.withLinearPattern xWhole 0 (wholeLineW+xWhole) 0 $ \pattern -> + do --C.patternAddColorStopRGB pattern 0 0 0 0 + --C.patternAddColorStopRGB pattern 0.5 1 1 1 + C.save + C.patternAddColorStopRGBA pattern 0 r g b 1 + C.patternAddColorStopRGBA pattern 1 r g b 0.5 + C.patternSetFilter pattern C.FilterFast + C.setSource pattern + -- 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 + where x = (fromRational s) * totalWidth + y = (fromIntegral n) * levelHeight + xWhole = (fromRational sWhole) * totalWidth + w = levelHeight + lineW = ((fromRational $ e-s) * totalWidth) + wholeLineW = ((fromRational $ eWhole-sWhole) * totalWidth) + lineH = 2 + lgap = 3 + rgap = 3 + border = 3 + half = levelHeight / 2 + quarter = levelHeight / 4 + vPDF = v C.withPDFSurface + +vis name pat = do v (C.withSVGSurface) (name ++ ".svg") (totalWidth, levelHeight*(fromIntegral $ length levels)) levels + rawSystem "/home/alex/Dropbox/bin/fixsvg.pl" [name ++ ".svg"] + -- rawSystem "convert" [name ++ ".svg", name ++ ".pdf"] + return () + where levels = arrangeEvents $ sortOn ((\x -> snd x - fst x) . snd') (arc pat (0,1)) + +visAsString pat = do vis "/tmp/vis2-tmp" pat + svg <- readFile "/tmp/vis2-tmp.svg" + return svg diff --git a/Sound/Tidal/VisCycle.hs b/Sound/Tidal/VisCycle.hs new file mode 100644 index 0000000..cecd3c5 --- /dev/null +++ b/Sound/Tidal/VisCycle.hs @@ -0,0 +1,72 @@ +module Sound.Tidal.VisCycle 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.Time +import Sound.Tidal.Utils +import Data.Ratio +import Data.Maybe +import System.Cmd +import Data.List +import Data.Ord ( comparing ) + +totalWidth = 1080 :: Double +ratio = 1 + +arrangeEvents [] = [] +arrangeEvents (e:es) = addEvent e (arrangeEvents es) +fits e es = null $ filter (id) $ map (\e' -> isJust $ subArc (snd' e) (snd' e')) es +addEvent e [] = [[e]] +addEvent e (level:levels) | fits e level = (e:level):levels + | otherwise = level:(addEvent e levels) + +v sf fn (x,y) levels = + sf fn x y $ \surf -> do + C.renderWith surf $ do + C.setAntialias C.AntialiasBest + C.save + C.scale totalWidth totalWidth + C.setOperator C.OperatorOver + -- C.setSourceRGB 0 0 0 + -- C.rectangle 0 0 1 1 + --C.fill + mapM_ (renderLevel (length levels)) $ enumerate levels + C.restore + +renderLevel total (n, level) = do C.save + mapM_ drawEvent $ level + C.restore + where drawEvent ((sWhole, eWhole), (s,e), c) = + do let (RGB r g b) = toSRGB c + C.save + C.setSourceRGBA r g b 1 + C.arc 0.5 0.5 (h+levelHeight) ((fromRational s)*(pi*2)-(pi/2)) ((fromRational e)*(pi*2)-(pi/2)) + C.arcNegative 0.5 0.5 h ((fromRational e)*(pi*2)-(pi/2)) ((fromRational s)*(pi*2)-(pi/2)) + C.fill + C.setSourceRGBA 0.5 0.5 0.5 1 + C.setLineWidth 0.005 + C.arc 0.5 0.5 (h+levelHeight) ((fromRational s)*(pi*2)-(pi/2)) ((fromRational e)*(pi*2)-(pi/2)) + C.arcNegative 0.5 0.5 h ((fromRational e)*(pi*2)-(pi/2)) ((fromRational s)*(pi*2)-(pi/2)) + C.stroke + C.restore + where h = levelHeight * (fromIntegral (n + 1)) + levelHeight = (1 / fromIntegral (total+1))/2 + vPDF = v C.withPDFSurface + +vis name pat = do v (C.withPDFSurface) (name ++ ".pdf") (totalWidth, totalWidth) levels + return () + where levels = arrangeEvents $ sortOn ((\x -> snd x - fst x) . snd') (arc pat (0,1)) + sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +visAsString pat = do vis "/tmp/vis2-tmp" pat + svg <- readFile "/tmp/vis2-tmp.svg" + return svg + + +magicallyMakeEverythingFaster = splitArcs 16 + where splitArcs n p = concatMap (\i -> arc p (i,i+(1/n))) [0, (1/n) .. (1-(1/n))] diff --git a/Sound/Tidal/VisCycle.hs~ b/Sound/Tidal/VisCycle.hs~ new file mode 100644 index 0000000..96aec5d --- /dev/null +++ b/Sound/Tidal/VisCycle.hs~ @@ -0,0 +1,91 @@ +module Sound.Tidal.VisCycle 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.Time +import Sound.Tidal.Utils +import Data.Ratio +import Data.Maybe +import System.Cmd +import Data.List +import Data.Ord ( comparing ) + +totalWidth = 200 :: Double +ratio = 2/40 +levelHeight = totalWidth * ratio + +arrangeEvents [] = [] +arrangeEvents (e:es) = addEvent e (arrangeEvents es) +fits e es = null $ filter (id) $ map (\e' -> isJust $ subArc (snd' e) (snd' e')) es +addEvent e [] = [[e]] +addEvent e (level:levels) | fits e level = (e:level):levels + | otherwise = level:(addEvent e levels) + +v sf fn (x,y) levels = + sf fn x y $ \surf -> do + C.renderWith surf $ do + C.save + -- C.scale x (y / (fromIntegral $ length levels)) + C.setOperator C.OperatorOver + -- C.setSourceRGB 0 0 0 + -- C.rectangle 0 0 1 1 + --C.fill + mapM_ (renderLevel (length levels)) $ enumerate levels + C.restore + +renderLevel total (n, level) = do C.save + mapM_ drawEvent $ level + C.restore + where drawEvent ((sWhole, eWhole), (s,e), c) = + do let (RGB r g b) = toSRGB c + -- C.setSourceRGBA 0.6 0.6 0.6 1 + -- C.rectangle x y lineW levelHeight + C.withLinearPattern xWhole 0 (wholeLineW+xWhole) 0 $ \pattern -> + do --C.patternAddColorStopRGB pattern 0 0 0 0 + --C.patternAddColorStopRGB pattern 0.5 1 1 1 + C.save + C.patternAddColorStopRGBA pattern 0 r g b 1 + C.patternAddColorStopRGBA pattern 1 r g b 0.5 + C.patternSetFilter pattern C.FilterFast + C.setSource pattern + -- 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 + where x = (fromRational s) * totalWidth + y = (fromIntegral n) * levelHeight + xWhole = (fromRational sWhole) * totalWidth + w = levelHeight + lineW = ((fromRational $ e-s) * totalWidth) + wholeLineW = ((fromRational $ eWhole-sWhole) * totalWidth) + lineH = 2 + lgap = 3 + rgap = 3 + border = 3 + half = levelHeight / 2 + quarter = levelHeight / 4 + vPDF = v C.withPDFSurface + +vis name pat = do v (C.withSVGSurface) (name ++ ".svg") (totalWidth, levelHeight*(fromIntegral $ length levels)) levels + -- rawSystem "/home/alex/Dropbox/bin/fixsvg.pl" [name ++ ".svg"] + -- rawSystem "convert" [name ++ ".svg", name ++ ".pdf"] + return () + where levels = arrangeEvents $ sortOn ((\x -> snd x - fst x) . snd') (arc pat (0,1)) + sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +visAsString pat = do vis "/tmp/vis2-tmp" pat + svg <- readFile "/tmp/vis2-tmp.svg" + return svg + + +magicallyMakeEverythingFaster = splitArcs 16 + where splitArcs n p = concatMap (\i -> arc p (i,i+(1/n))) [0, (1/n) .. (1-(1/n))] diff --git a/examples/0.pdf b/examples/0.pdf new file mode 100644 index 0000000..80ed415 Binary files /dev/null and b/examples/0.pdf differ diff --git a/examples/1.pdf b/examples/1.pdf new file mode 100644 index 0000000..4e1a9cf --- /dev/null +++ b/examples/1.pdf @@ -0,0 +1,70 @@ +%PDF-1.5 +% +3 0 obj +<< /Length 4 0 R + /Filter /FlateDecode +>> +stream +xW[r! )!H;ci\ u{/{|Gؠ?~C/cʢ MSW+*op a2ƌPcl@{ڊ6^ף {"]b3P0Fӌ4X%c$lЭFX ѵa%Pѐp&`##]EF6Q.BsA*rJ c̭{obUN¤H68Q.PmWo0q~[VK)gvK|~,ʬ_i`X_,"HA}Sg߸*V㥆[y37]D;Ӕ]lO:v/aYB1nZUhF͌˕b^~͸S\-'eKZX*0p 4(U>NV3%\{ƭueEd9p PoCjH!tep2$Gf~ +K|_M53#1c{pJPt!ޢc~=jIqOQD2bD'KJ\\(GR=1LKJdl9M!߷SObfѪe36e"rnA #-rHhe\ӥ_Or"^ZxDyo8rIh>K۝!ElY˽Q7K}9r99rj:s@o_Z$2OSJGɁ4QrtyX+޲|eٳfEղ\Qqr\y9GJ҆ +5FNBS~~~4, +endstream +endobj +4 0 obj + 893 +endobj +2 0 obj +<< + /ExtGState << + /a0 << /CA 1 /ca 1 >> + >> +>> +endobj +5 0 obj +<< /Type /Page + /Parent 1 0 R + /MediaBox [ 0 0 300 100 ] + /Contents 3 0 R + /Group << + /Type /Group + /S /Transparency + /I true + /CS /DeviceRGB + >> + /Resources 2 0 R +>> +endobj +1 0 obj +<< /Type /Pages + /Kids [ 5 0 R ] + /Count 1 +>> +endobj +6 0 obj +<< /Creator (cairo 1.12.16 (http://cairographics.org)) + /Producer (cairo 1.12.16 (http://cairographics.org)) +>> +endobj +7 0 obj +<< /Type /Catalog + /Pages 1 0 R +>> +endobj +xref +0 8 +0000000000 65535 f +0000001293 00000 n +0000001007 00000 n +0000000015 00000 n +0000000985 00000 n +0000001079 00000 n +0000001358 00000 n +0000001487 00000 n +trailer +<< /Size 8 + /Root 7 0 R + /Info 6 0 R +>> +startxref +1539 +%%EOF diff --git a/examples/2.pdf b/examples/2.pdf new file mode 100644 index 0000000..eb8b82c Binary files /dev/null and b/examples/2.pdf differ diff --git a/examples/3.pdf b/examples/3.pdf new file mode 100644 index 0000000..d105e8d Binary files /dev/null and b/examples/3.pdf differ diff --git a/examples/4.pdf b/examples/4.pdf new file mode 100644 index 0000000..7d48197 Binary files /dev/null and b/examples/4.pdf differ diff --git a/examples/5.pdf b/examples/5.pdf new file mode 100644 index 0000000..4d653c7 Binary files /dev/null and b/examples/5.pdf differ diff --git a/examples/6.pdf b/examples/6.pdf new file mode 100644 index 0000000..5abd6b3 Binary files /dev/null and b/examples/6.pdf differ diff --git a/examples/example.hs b/examples/example.hs new file mode 100644 index 0000000..be3f907 --- /dev/null +++ b/examples/example.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Sound.Tidal.Context +import Sound.Tidal.Vis +import Data.Colour + +render :: [Pattern ColourD] -> IO () +render xs = mapM_ (\(n, p) -> vPDF (show n ++ ".pdf") (300,100) p) $ zip [0..] xs + +main = do render [a,b,c,d,e,f,g] + return () + +a = density 16 $ every 2 rev $ every 3 (superimpose (iter 4)) $ rev "[black blue darkblue, grey lightblue]" + +b = flip darken <$> "[black blue orange, red green]*16" <*> sinewave1 + +c = density 10 $ flip darken + <$> "[black blue, grey ~ navy, cornflowerblue blue]*2" + <*> (slow 5 $ (*) <$> sinewave1 <*> (slow 2 triwave1)) + +d = every 2 rev $ density 10 $ (blend' + <$> "blue navy" + <*> "orange [red, orange, purple]" + <*> (slow 6 $ sinewave1) + ) + where blend' a b c = blend c a b + +e = density 32 $ (flip over + <$> ("[grey olive, black ~ brown, darkgrey]") + <*> (withOpacity + <$> "[beige, lightblue white darkgreen, beige]" + <*> ((*) <$> (slow 8 $ slow 4 sinewave1) <*> (slow 3 $ sinewave1))) + ) + +f = density 2 $ (flip darken + <$> (density 8 $ "[black blue, grey ~ navy, cornflowerblue blue]*2") + <*> sinewave1 + ) + +g = density 2 $ + do let x = "[skyblue olive, grey ~ navy, cornflowerblue green]" + coloura <- density 8 x + colourb <- density 4 x + slide <- slow 2 sinewave1 + return $ blend slide coloura colourb + + diff --git a/tidal-vis.cabal b/tidal-vis.cabal new file mode 100644 index 0000000..289319a --- /dev/null +++ b/tidal-vis.cabal @@ -0,0 +1,25 @@ +name: tidal-vis +version: 0.9.5 +synopsis: Visual rendering for Tidal patterns +-- description: +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 +category: Sound +build-type: Simple +cabal-version: >=1.4 + +--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. + +library + Exposed-modules: Sound.Tidal.Vis + Sound.Tidal.Vis2 + Sound.Tidal.VisCycle + + Build-depends: base < 5, tidal>=0.9.5, colour, cairo, process