Alex McLean
GitHub
commit
129bb8392a
|
|
@ -1,283 +0,0 @@
|
|||
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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
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))]
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,83 +0,0 @@
|
|||
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 = 50 :: Double
|
||||
border = 5
|
||||
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 label =
|
||||
sf fn x y $ \surf -> do
|
||||
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" C.FontSlantNormal C.FontWeightNormal
|
||||
C.setFontSize 0.2
|
||||
(C.TextExtents _ _ textW 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 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
|
||||
|
||||
visCycle :: [Char] -> String -> Pattern ColourD -> IO ()
|
||||
visCycle name label pat =
|
||||
do v (C.withPDFSurface) (name ++ ".pdf") (totalWidth, totalWidth) levels label
|
||||
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 visCycle "/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))]
|
||||
|
|
@ -1,91 +0,0 @@
|
|||
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))]
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
{-# 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
|
||||
|
||||
|
||||
Binary file not shown.
|
|
@ -0,0 +1,116 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
|
||||
module Common
|
||||
( arrangeEvents
|
||||
, beatNow
|
||||
, dirtToColour
|
||||
, fi
|
||||
, levels
|
||||
, remoteLocal
|
||||
, segmentator
|
||||
) 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 used functions.
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
|
||||
arrangeEvents :: [Event b] -> [[Event b]]
|
||||
arrangeEvents [] = []
|
||||
arrangeEvents (e:es) = addEvent e (arrangeEvents es)
|
||||
|
||||
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
|
||||
|
||||
levels :: Pattern ColourD -> [[Event ColourD]]
|
||||
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 depricated functions for 1.0.7
|
||||
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
|
||||
port = cTempoPort config
|
||||
(remote_addr:_) <- getAddrInfo Nothing (Just hostname) Nothing
|
||||
local <- OSC.udpServer "127.0.0.1" tempoClientPort
|
||||
let (SockAddrInet _ a) = addrAddress remote_addr
|
||||
remote = SockAddrInet (fromIntegral port) a
|
||||
newMVar $ Tempo.defaultTempo time local remote
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,315 @@
|
|||
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 qualified GHC.Word
|
||||
import qualified Graphics.UI.SDL.Framerate as FR
|
||||
import qualified Graphics.UI.SDL.Primitives as SDLP
|
||||
import qualified Graphics.UI.SDL.TTF.General as TTFG
|
||||
|
||||
import Sound.OSC.FD (time)
|
||||
|
||||
import Sound.Tidal.Config
|
||||
import Sound.Tidal.Core
|
||||
import Sound.Tidal.ParseBP
|
||||
import Sound.Tidal.Pattern hiding (Event)
|
||||
import Sound.Tidal.Tempo
|
||||
import Sound.Tidal.Utils
|
||||
|
||||
import qualified Sound.Tidal.Pattern as Pat
|
||||
|
||||
import Common
|
||||
|
||||
|
||||
-- | To run at CLI to see animation.
|
||||
-- | Cycle animation looks like https://www.youtube.com/watch?v=cCmCSSb4vHs
|
||||
-- | Rectangle animation looks ...
|
||||
-- @
|
||||
-- stack repl
|
||||
-- :set -XOverloadedStrings
|
||||
-- ah <- run
|
||||
-- swapMVar ah $ degradeBy 0.3 $ every 3 (fast 3) $ Params.s "[red, white, [purple orange green]]"
|
||||
-- @
|
||||
-- | Look at comment for 'loop' function below.
|
||||
runAnimation :: IO (MVar ControlPattern)
|
||||
runAnimation = do
|
||||
mp <- newMVar silence
|
||||
void $ forkIO $ run' mp
|
||||
return mp
|
||||
|
||||
run' :: MVar ControlPattern -> IO ()
|
||||
run' mp = withInit [InitEverything] $
|
||||
do result <- TTFG.init
|
||||
if not result
|
||||
then putStrLn "Failed to init ttf"
|
||||
else do enableUnicode True
|
||||
env <- initEnv mp
|
||||
--ws <- wordMenu (font env) things
|
||||
let scene = Scene (0,0) (0.5,0.5)
|
||||
--putStrLn $ show scene
|
||||
runLoop env scene
|
||||
|
||||
|
||||
runLoop :: AppConfig -> Scene -> IO ()
|
||||
runLoop = evalStateT . runReaderT loop
|
||||
|
||||
-- | Animate pattern looply. Choose form inside 'loop'.
|
||||
-- | It needs to be optimized.
|
||||
loop :: AppEnv ()
|
||||
loop = do
|
||||
quit' <- whileEvents act
|
||||
screen <- acScreen `liftM` ask
|
||||
tempoM <- acTempo `liftM` ask
|
||||
fps <- acFps `liftM` ask
|
||||
mp <- acPattern `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
|
||||
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' loop
|
||||
where act e = do scene <- get
|
||||
scene' <- handleEvent scene e
|
||||
put scene'
|
||||
|
||||
data Scene = Scene
|
||||
{ mouseXY :: (Float, Float)
|
||||
, cursor :: (Float, Float)
|
||||
}
|
||||
|
||||
data AppConfig = AppConfig
|
||||
{ acScreen :: Surface
|
||||
, acFont :: Font
|
||||
, acTempo :: MVar Tempo
|
||||
, acFps :: FR.FPSManager
|
||||
, acPattern :: MVar Pat.ControlPattern
|
||||
}
|
||||
|
||||
type AppState = StateT Scene IO
|
||||
|
||||
type AppEnv = ReaderT AppConfig AppState
|
||||
|
||||
screenWidth :: Int
|
||||
screenWidth = 1024
|
||||
|
||||
screenHeight :: Int
|
||||
screenHeight = 768
|
||||
|
||||
screenBpp :: Int
|
||||
screenBpp = 32
|
||||
|
||||
-- A middle of window.
|
||||
middle :: (Double, Double)
|
||||
middle = (fromIntegral $ screenWidth `div` 2, fromIntegral $ screenHeight `div` 2)
|
||||
|
||||
fromScreen :: (Int, Int) -> (Float, Float)
|
||||
fromScreen (x, y) =
|
||||
( fromIntegral x / fromIntegral screenWidth
|
||||
, fromIntegral y / fromIntegral screenHeight
|
||||
)
|
||||
|
||||
isInside :: Integral a => Rect -> a -> a -> Bool
|
||||
isInside (Rect rx ry rw rh) x y = (x' > rx) && (x' < rx + rw) && (y' > ry) && (y' < ry + rh)
|
||||
where (x', y') = (fromIntegral x, fromIntegral y)
|
||||
|
||||
ctrlDown :: [Modifier] -> Bool
|
||||
ctrlDown = any (`elem` [KeyModLeftCtrl, KeyModRightCtrl])
|
||||
|
||||
shiftDown :: [Modifier] -> Bool
|
||||
shiftDown = any (\x -> elem x
|
||||
[ KeyModLeftShift
|
||||
, KeyModRightShift
|
||||
, KeyModShift
|
||||
])
|
||||
|
||||
handleEvent :: Scene -> Event -> AppEnv Scene
|
||||
handleEvent scene (KeyDown k) =
|
||||
handleKey scene (symKey k) (symUnicode k) (symModifiers k)
|
||||
handleEvent scene _ = return scene
|
||||
|
||||
handleKey :: Scene -> SDLKey -> Char -> [Modifier] -> AppEnv Scene
|
||||
handleKey scene SDLK_SPACE _ _ = return scene
|
||||
handleKey scene _ _ _ = return scene
|
||||
|
||||
applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool
|
||||
applySurface x y src dst clip = blitSurface src clip dst off
|
||||
where off = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 }
|
||||
|
||||
initEnv :: MVar ControlPattern -> IO AppConfig
|
||||
initEnv mp = do
|
||||
time' <- 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 -- step
|
||||
-> IO ()
|
||||
drawArc screen c (x,y) (r,r') t o step'
|
||||
| o <= 0 = return ()
|
||||
| otherwise = do
|
||||
let pix = colourToPixel c
|
||||
void $ SDLP.filledPolygon screen coords pix
|
||||
drawArc screen c (x,y) (r,r') t (o-step') step'
|
||||
return ()
|
||||
where
|
||||
a = max t (t + o - step') -- 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 pat
|
||||
where
|
||||
pos :: Rational
|
||||
pos = toRational $ beat / 8
|
||||
|
||||
drawEvents :: ((Rational, Rational), [ColourD]) -> IO ()
|
||||
drawEvents ((begin,end), cs) =
|
||||
mapM_ (\(index', color) -> drawEvent (begin,end) color index' (length cs))
|
||||
(enumerate $ reverse cs)
|
||||
|
||||
drawEvent :: (Rational, Rational) -> ColourD -> Int -> Int -> IO ()
|
||||
drawEvent (begin, end) color index' len = do
|
||||
let thickness = (1 / fromIntegral len) * (r' - r)
|
||||
let thickIndex = r + thickness * fromIntegral index'
|
||||
|
||||
drawArc screen color middle (thickIndex, thickIndex + thickness)
|
||||
((pi*2) * fromRational (begin - pos)) ((pi*2) * fromRational (end - begin)) (pi/16)
|
||||
|
||||
-- Draw one cycle patterns
|
||||
drawRect :: Surface
|
||||
-> ColourD
|
||||
-> (Double, Double) -- thickIndex, thickIndex + thickness
|
||||
-> Double -- ((pi*2) * fromRational (start - pos))
|
||||
-> Double -- ((pi*2) * fromRational (end - start))
|
||||
-> Double -- step (pi/16)
|
||||
-> IO ()
|
||||
drawRect screen c (thickStart,thickEnd) t o step
|
||||
| o <= 0 = return ()
|
||||
| otherwise = do
|
||||
let pix = colourToPixel c
|
||||
void $ SDLP.filledPolygon screen coords pix
|
||||
drawRect screen c (thickStart, thickEnd) t (o - step) step
|
||||
return ()
|
||||
where
|
||||
a = max t (t + o - step) --
|
||||
b = t + o
|
||||
|
||||
coords = map (\(x',y') -> (floor x', floor y'))
|
||||
[ (b, thickStart) -- 1
|
||||
, (b, thickEnd) -- 2
|
||||
, (a, thickEnd) -- 3
|
||||
, (a, thickStart) -- 4
|
||||
]
|
||||
|
||||
-- Draw cycle patterns continiously
|
||||
drawPatR :: (Double, Double) -> Pat.Pattern ColourD -> Surface -> Double -> IO ()
|
||||
drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event pos p
|
||||
where
|
||||
pos :: Rational
|
||||
pos = toRational $ beat / 8
|
||||
|
||||
drawEvents :: ((Rational, Rational), [ColourD]) -> IO ()
|
||||
drawEvents ((begin, end), cs) =
|
||||
mapM_ (\(index', c) -> drawEvent (begin, end) c index' (length cs)) (enumerate $ reverse cs)
|
||||
|
||||
drawEvent :: (Rational, Rational) -> ColourD -> Int -> Int -> IO ()
|
||||
drawEvent (begin, end) color index' len = do
|
||||
let thickness = (1 / fromIntegral len) * (x2 - x1)
|
||||
let thickIndex = thickness * fromIntegral index'
|
||||
let width = fi screenWidth
|
||||
drawRect screen color (thickIndex, thickIndex + thickness)
|
||||
(width * fromRational (begin - pos)) (width * fromRational (end - begin)) 1
|
||||
|
||||
event :: Rational -> Pat.Pattern ColourD -> [((Rational, Rational), [ColourD])]
|
||||
event pos pat = map (\(Pat.Event _ Arc{..} events) ->
|
||||
((max start pos, min stop (pos + 1)), events))
|
||||
$ queryArc (segmentator pat) (Arc pos (pos + 1))
|
||||
|
||||
whileEvents :: MonadIO m => (Event -> m ()) -> m Bool
|
||||
whileEvents act = do
|
||||
ev <- liftIO pollEvent
|
||||
case ev of
|
||||
Quit -> return True
|
||||
NoEvent -> return False
|
||||
_ -> do
|
||||
act ev
|
||||
whileEvents act
|
||||
|
||||
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 =
|
||||
-- mapRGB (surfaceGetPixelFormat screen) 255 255 255
|
||||
rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255)
|
||||
where (RGB r g b) = toSRGB c
|
||||
|
||||
colourToPixelS :: Surface -> Colour Double -> IO Pixel
|
||||
colourToPixelS s c =
|
||||
(mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255)
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
module Examples where
|
||||
|
||||
import Data.Colour
|
||||
import Sound.Tidal.Context
|
||||
|
||||
import Common (dirtToColour)
|
||||
import Vis
|
||||
import VisCycle
|
||||
import VisGradient
|
||||
|
||||
|
||||
-- | Examples
|
||||
--
|
||||
-- | For pattern animation look at 'runAnimation' function at 'CycleAnimation.hs' module.
|
||||
-- | There two forms of moving patterns: cycle and rectangle.
|
||||
--
|
||||
-- | 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
|
||||
|
||||
-- | Prepared patterns.
|
||||
foo :: Pattern ColourD
|
||||
foo = dirtToColour $ striate 16 $ sound "[bd*3? dr2, ~ casio ~, [bd arpy]]" # n
|
||||
"2? 3 1 2"
|
||||
|
||||
pip :: Pattern ColourD
|
||||
pip = dirtToColour $ fast 12 $ sound
|
||||
"[bd bd bd, <[sd sd] cp>, <arpy [arpy <[arpy arpy]> arpy arpy]>, odx]"
|
||||
|
||||
pop :: Pattern ColourD
|
||||
pop = dirtToColour $ fast 12 $ loopAt 3 $ sound
|
||||
"[~ bd bd ~] ~ [bd ~ ~ [sd ~ ~ sd] ~ ~ sd]"
|
||||
|
||||
bar :: Pattern ColourD
|
||||
bar = dirtToColour $ fast 12 $ sound "{~ ~ ~ ~, arpy bass2 drum notes can}"
|
||||
|
||||
buz :: Pattern ColourD
|
||||
buz =
|
||||
dirtToColour $ fast 24 $ sound "arpy*4" # pan (range 0.25 0.75 sine) # gain
|
||||
(range 1.2 0.5 sine)
|
||||
|
||||
a :: Pattern ColourD
|
||||
a = density 16 $ every 2 rev $ every 3 (superimpose (iter 4)) $ rev
|
||||
"[black blue darkblue, grey lightblue]"
|
||||
|
||||
b :: Pattern (Colour Double)
|
||||
b = flip darken <$> "[black blue orange, red green]*16" <*> sine
|
||||
|
||||
c :: Pattern (Colour Double)
|
||||
c =
|
||||
density 10
|
||||
$ flip darken
|
||||
<$> "[black blue, grey ~ navy, cornflowerblue blue]*2"
|
||||
<*> (slow 5 $ (*) <$> sine <*> (slow 2 tri))
|
||||
|
||||
d :: Pattern (Colour Double)
|
||||
d =
|
||||
every 2 rev
|
||||
$ density 10
|
||||
$ ( blend'
|
||||
<$> "blue navy"
|
||||
<*> "orange [red, orange, purple]"
|
||||
<*> (slow 6 $ sine)
|
||||
)
|
||||
where blend' x y z = blend z x y
|
||||
|
||||
e :: Pattern (Colour Double)
|
||||
e =
|
||||
density 32
|
||||
$ flip over
|
||||
<$> "[grey olive, black ~ brown, darkgrey]"
|
||||
<*> ( withOpacity
|
||||
<$> "[beige, lightblue white darkgreen, beige]"
|
||||
<*> ((*) <$> (slow 8 $ slow 4 sine) <*> (slow 3 $ sine))
|
||||
)
|
||||
|
||||
f :: Pattern ColourD
|
||||
f =
|
||||
density 2
|
||||
$ flip darken
|
||||
<$> (density 8 $ "[black blue, grey ~ navy, cornflowerblue blue]*2")
|
||||
<*> sine
|
||||
|
||||
g :: Pattern ColourD
|
||||
g = density 2 $ do
|
||||
let x = "[skyblue olive, grey ~ navy, cornflowerblue green]"
|
||||
coloura <- density 8 x
|
||||
colourb <- density 4 x
|
||||
slide' <- slow 2 sine
|
||||
return $ blend slide' coloura colourb
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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 ()
|
||||
|
|
@ -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 ()
|
||||
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
resolver: lts-13.8
|
||||
|
||||
# packages: []
|
||||
|
||||
|
||||
extra-deps:
|
||||
- SDL-0.6.7.0
|
||||
- cairo-0.13.6.0
|
||||
- tidal-1.0.7
|
||||
- gtk2hs-buildtools-0.13.5.0
|
||||
- SDL-gfx-0.7.0.0
|
||||
- SDL-image-0.6.2.0
|
||||
- SDL-ttf-0.6.3.0
|
||||
|
||||
|
|
@ -1,25 +1,47 @@
|
|||
name: tidal-vis
|
||||
version: 0.9.5
|
||||
version: 1.0.7
|
||||
synopsis: Visual rendering for Tidal patterns
|
||||
-- description:
|
||||
-- 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
|
||||
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.
|
||||
|
||||
library
|
||||
Exposed-modules: Sound.Tidal.Vis
|
||||
Sound.Tidal.Vis2
|
||||
Sound.Tidal.VisCycle
|
||||
Exposed-modules: Common
|
||||
CycleAnimation
|
||||
Examples
|
||||
Vis
|
||||
VisCycle
|
||||
VisGradient
|
||||
|
||||
Build-depends: base < 5, tidal>=0.9.5, colour, cairo, process
|
||||
hs-source-dirs: src
|
||||
|
||||
Build-depends: base < 5
|
||||
, tidal>=1.0.7
|
||||
, colour
|
||||
, cairo
|
||||
, SDL
|
||||
, mtl
|
||||
, SDL-gfx
|
||||
, SDL-image
|
||||
, SDL-ttf
|
||||
, hosc
|
||||
, hashable
|
||||
, time
|
||||
, network
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
default-extensions: OverloadedStrings
|
||||
RecordWildCards
|
||||
|
|
|
|||
Loading…
Reference in New Issue