moved from tidal repo
alex
parent
d827774658
commit
0aea9d73df
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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))]
|
||||
|
|
@ -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
|
||||
|
|
@ -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))]
|
||||
|
|
@ -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))]
|
||||
Binary file not shown.
|
|
@ -0,0 +1,70 @@
|
|||
%PDF-1.5
|
||||
%µí®û
|
||||
3 0 obj
|
||||
<< /Length 4 0 R
|
||||
/Filter /FlateDecode
|
||||
>>
|
||||
stream
|
||||
xœ<EFBFBD>W[r ! ü÷)æ!HÇðò‘ø;Îý«ÂcØi¶\®òöÒ uÏß{”Ÿï¯ãç/{|ý«ŸÉÚòï÷ïãÏGû“Ø ?~øþÐòäC/¶‡¿cÊ¢ <09>£MSW+ÐÈ*Ðop a2ÆŒ£ä PclÈ ¥‰à@Æ{¤˜ Ðøí®ÚŠ6^×£ {"]b‹3P’0FóÓŒœé4ù²X×%ýœcŸà$lЀÉF<C389>XŒ ѵ‚×aß% ™PÑ<50>‚p&²›`’€É˜##]™™¯EF6Q¹….BªsA÷*rJ¥ c°ÌÀï{o¡õbóÕU–N¤H6Î8QÁ„.PmÎWoÜ÷0òqï<71>½~ŸÏ[VôK)ägv€îõK êç|´§~,ößʬõ_ìi`X–•«_,ƒ"HðÅA }—Sg߸·*¨V<C2A8>¡¨†¶ã¥†[y•Ž«3—Äá7]”DÚì;û¢ÌÈÓ” î]<5D>Èl¤O¿¡Á:v/a›YBð1ô±énÔZÛU„hFóÀÍŒú<C592>®¸øæ„Ë•öb^œú ~Çî͸™SöÁ¿\ö-'<27> eKZÍXõ¤ *0ˆ³p¥ Ú4 (<28>UÇá”>NìVÉ3%•–<E280A2>ž\¯{òÆueEæ´d9<64>ÝÉp² ÔPo‡C¸Œj«åHú‘!te¼ópä2$<24>Íã²°–Gf~
|
||||
‰²K™|¹<>_€’šž‚M5ƒØß3ŸÖÜ#›ž1«c{pJPt!ÏÞ¢c~½Ä=ùjIqâŽOQDë2bDž<44>’<EFBFBD>ä³'ºŠKJ\\(“ GR=1æÖã×LKJdÄl9M!ß·SO´bf ‰Ñª¡e3þÚ6ªþe€"¹ö²rnœA
Ž#£ž -rH®ï”ìhËe÷®ÖØ\Ó¥”_ßîôO÷r¢"^ÿZ¥šÄìxýÒÃãD§ÇÇyo¤Èó8rIîhî>ƒâKÛ<4B>ü!E¢lY˽Q «7K}9–räÌç• 9²é9rj:¯äÈs@”o˜_Z<>œ¹Ÿ‚$ŠŽµŒ2Ô «OñŠS’äJ©GÉ<47>4èQrt„ŽÝêyX–’…Ð+Þ²|èeÙ³f‡EÕ²Î\Qqr<71>\Õ y¦‡9”ŽÝGŸ–¦JÒ†’Î
|
||||
5FNÜBS~~ü~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
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue