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,5 +1,5 @@
|
||||||
name: tidal-vis
|
name: tidal-vis
|
||||||
version: 0.9.5
|
version: 1.0.7
|
||||||
synopsis: Visual rendering for Tidal patterns
|
synopsis: Visual rendering for Tidal patterns
|
||||||
-- description:
|
-- description:
|
||||||
homepage: http://yaxu.org/tidal/
|
homepage: http://yaxu.org/tidal/
|
||||||
|
|
@ -8,18 +8,40 @@ license-file: LICENSE
|
||||||
author: Alex McLean
|
author: Alex McLean
|
||||||
maintainer: alex@slab.org
|
maintainer: alex@slab.org
|
||||||
Stability: Experimental
|
Stability: Experimental
|
||||||
Copyright: (c) Alex McLean and others, 2017
|
Copyright: (c) Alex McLean and others, 2019
|
||||||
category: Sound
|
category: Sound
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
cabal-version: >=1.4
|
cabal-version: 2.0
|
||||||
|
|
||||||
--Extra-source-files: README.md tidal.el doc/tidal.md doc/tidal.pdf
|
--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.
|
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
|
library
|
||||||
Exposed-modules: Sound.Tidal.Vis
|
Exposed-modules: Common
|
||||||
Sound.Tidal.Vis2
|
CycleAnimation
|
||||||
Sound.Tidal.VisCycle
|
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