Alex McLean
GitHub
commit
3f4fa7748b
48
README.md
48
README.md
|
|
@ -1,14 +1,54 @@
|
|||
# tidal-vis
|
||||
|
||||
Tidal is a domain specific language for live coding pattern. This package allows colour patterns to be rendered as PDF or SVG files. See _Examples.hs_ module for more help.
|
||||
Tidal is a domain specific language for live coding pattern. This package allows several things:
|
||||
|
||||
## Example
|
||||
1. OSC messages sent to SC to be dynamicly rendered in realtime with at separate window.
|
||||
[Demo of realtime visualisation.](https://youtu.be/bZS6WufE8FY)
|
||||
2. Colour patterns to be rendered as PDF or SVG files. See _Examples.hs_ module for more help.
|
||||
3. Colour patterns to be rendered to be rendered dynamicly in separate window. See _CycleAnimation.hs_ for more. [Demo.](https://youtu.be/cCmCSSb4vHs)
|
||||
|
||||
## (1) Realtime animation during livecoding
|
||||
|
||||
1. Add following lines to _BootTidal.hs_
|
||||
|
||||
-- OSCTarget for pattern visualizing.
|
||||
patternTarget = OSCTarget { oName = "Pattern handler", oAddress = "127.0.0.1", oPort = 5050, oPath = "/trigger/something", oShape = Nothing, oLatency = 0.02, oPreamble = [], oTimestamp = BundleStamp }
|
||||
|
||||
-- OSCTarget for play music via SuperCollider.
|
||||
musicTarget = superdirtTarget { oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120 }
|
||||
|
||||
config = defaultConfig {cFrameTimespan = 1/20}
|
||||
|
||||
-- Send pattern as osc both to SC and to tidal-vis
|
||||
tidal <- startMulti [musicTarget, patternTarget] config
|
||||
|
||||
-- Send pattern as osc to SC only
|
||||
-- tidal <- startTidal musicTarget config
|
||||
|
||||
2. Comment `tidal <- startTidal...` and uncomment `tidal <- startMulti...`
|
||||
|
||||
3. Build _tidal-vis_ and run
|
||||
|
||||
cd /tidal-vis
|
||||
stack build
|
||||
stack exec tidal-vis
|
||||
|
||||
4. Eval your tidal code.
|
||||
5. Profit.
|
||||
|
||||
## (2) Render SVG or PDF
|
||||
|
||||
For exanple, when pattern is
|
||||
|
||||
density 16 $ every 2 rev $ every 3 (superimpose (iter 4)) $ rev "[black blue darkblue, grey lightblue]"
|
||||
|
||||
Output image is
|
||||
|
||||
|
||||
|
||||
To run pattern [animation](https://youtu.be/cCmCSSb4vHs) (not good performance):
|
||||
## (3) Animate one pattern
|
||||
|
||||
To animate pattern (not good performance):
|
||||
|
||||
cd ./tidal-vis/
|
||||
stack repl ./src/CycleAnimation.hs
|
||||
|
|
@ -16,7 +56,7 @@ To run pattern [animation](https://youtu.be/cCmCSSb4vHs) (not good performance):
|
|||
ah <- run
|
||||
swapMVar ah $ degradeBy 0.3 $ every 3 (fast 3) $ Params.s "[red, white, [purple orange green]]"
|
||||
|
||||
Look at _CycleAnimation.hs_ for more information.
|
||||
Look at _CycleAnimation.hs_ for more information. Look at `looping` function to change animation form.
|
||||
|
||||
## Tutorial
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
module Main where
|
||||
|
||||
import Realtime.Server (animeCollectorServerU)
|
||||
|
||||
main :: IO ()
|
||||
main = animeCollectorServerU
|
||||
Binary file not shown.
Binary file not shown.
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
|
||||
module Common
|
||||
( arrangeEvents
|
||||
, beatNow
|
||||
|
|
@ -9,10 +8,10 @@ module Common
|
|||
, levels
|
||||
, remoteLocal
|
||||
, segmentator
|
||||
, toPattern
|
||||
) where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import Data.Colour.SRGB (sRGB)
|
||||
import Data.Function (on)
|
||||
|
|
@ -21,20 +20,18 @@ 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.
|
||||
-- | Common functions.
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
|
||||
arrangeEvents :: [Event b] -> [[Event b]]
|
||||
arrangeEvents [] = []
|
||||
arrangeEvents (e:es) = addEvent e (arrangeEvents es)
|
||||
arrangeEvents = foldr addEvent []
|
||||
|
||||
fits :: Event b -> [Event b] -> Bool
|
||||
fits (Event _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events
|
||||
|
|
@ -51,7 +48,7 @@ levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (queryA
|
|||
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
|
||||
-- | Recover depricated functions for 1.0.13
|
||||
dirtToColour :: ControlPattern -> Pattern ColourD
|
||||
dirtToColour = fmap (stringToColour . show)
|
||||
|
||||
|
|
@ -77,7 +74,7 @@ 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)
|
||||
Event whole (Arc start t) value : Event whole (Arc t stop) value : split t es
|
||||
| otherwise = ev:split t es
|
||||
|
||||
points :: [Event a] -> [Time]
|
||||
|
|
@ -105,12 +102,15 @@ remoteLocal :: Config -> OSC.Time -> IO (MVar Tempo.Tempo)
|
|||
remoteLocal config time = do
|
||||
let tempoClientPort = cTempoClientPort config
|
||||
hostname = cTempoAddr config
|
||||
port = cTempoPort config
|
||||
remotePort = 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
|
||||
case addrAddress remote_addr of
|
||||
SockAddrInet _ a -> do
|
||||
let remote = SockAddrInet (fromIntegral remotePort) a
|
||||
newMVar $ Tempo.defaultTempo time local remote
|
||||
_ -> error "wrong Socket"
|
||||
|
||||
|
||||
toPattern :: [Event ControlMap] -> ControlPattern
|
||||
toPattern evs = Pattern Digital $ const evs
|
||||
|
||||
|
|
|
|||
|
|
@ -4,99 +4,27 @@ module CycleAnimation where
|
|||
import Control.Concurrent
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
|
||||
import Data.Bits
|
||||
import Data.Colour.SRGB
|
||||
import GHC.Int (Int16)
|
||||
|
||||
import Graphics.UI.SDL
|
||||
import Graphics.UI.SDL.TTF.Management
|
||||
import Graphics.UI.SDL.TTF.Render
|
||||
import Graphics.UI.SDL.TTF.Types
|
||||
import Sound.Tidal.Context hiding (Event)
|
||||
import Sound.Tidal.Tempo
|
||||
import Sound.Tidal.Utils
|
||||
|
||||
import qualified GHC.Word
|
||||
import qualified Graphics.UI.SDL.Framerate as FR
|
||||
import qualified Graphics.UI.SDL.Primitives as SDLP
|
||||
import qualified Graphics.UI.SDL.TTF.General as TTFG
|
||||
|
||||
import 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.OSC.FD as FD
|
||||
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)
|
||||
|
|
@ -114,55 +42,59 @@ type AppState = StateT Scene IO
|
|||
|
||||
type AppEnv = ReaderT AppConfig AppState
|
||||
|
||||
screenWidth :: Int
|
||||
screenWidth = 1024
|
||||
run' :: MVar ControlPattern -> IO ()
|
||||
run' mp = withInit [InitEverything] $ do
|
||||
result <- TTFG.init
|
||||
if not result
|
||||
then putStrLn "Failed to init ttf"
|
||||
else do
|
||||
enableUnicode True
|
||||
env <- initEnv mp
|
||||
--ws <- wordMenu (font env) things
|
||||
let scene = Scene (0,0) (0.5,0.5)
|
||||
runLoop env scene
|
||||
|
||||
screenHeight :: Int
|
||||
screenHeight = 768
|
||||
runLoop :: AppConfig -> Scene -> IO ()
|
||||
runLoop = evalStateT . runReaderT looping
|
||||
|
||||
screenBpp :: Int
|
||||
screenBpp = 32
|
||||
-- | Animate pattern looply.
|
||||
-- | Choose form of pattern within 'loop'.
|
||||
looping :: AppEnv ()
|
||||
looping = do
|
||||
quit' <- whileEvents action
|
||||
screen <- acScreen `liftM` ask
|
||||
tempoM <- acTempo `liftM` ask
|
||||
fps <- acFps `liftM` ask
|
||||
mp <- acPattern `liftM` ask
|
||||
liftIO $ do
|
||||
pat <- readMVar mp
|
||||
appendFile "pat" $ show pat ++ "\n\n"
|
||||
tempo <- readMVar tempoM
|
||||
beat <- beatNow tempo
|
||||
bgColor <- (mapRGB . surfaceGetPixelFormat) screen 0x00 0x00 0x00
|
||||
clipRect <- Just `liftM` getClipRect screen
|
||||
void $ fillRect screen clipRect bgColor
|
||||
|
||||
-- A middle of window.
|
||||
middle :: (Double, Double)
|
||||
middle = (fromIntegral $ screenWidth `div` 2, fromIntegral $ screenHeight `div` 2)
|
||||
-- | Use one of
|
||||
--
|
||||
-- | (1) Cicle form of moving patterns
|
||||
-- drawPatC (100, fi screenHeight / 2) (dirtToColour pat) screen beat
|
||||
|
||||
fromScreen :: (Int, Int) -> (Float, Float)
|
||||
fromScreen (x, y) =
|
||||
( fromIntegral x / fromIntegral screenWidth
|
||||
, fromIntegral y / fromIntegral screenHeight
|
||||
)
|
||||
-- | (2) Rectangular form of moving patterns
|
||||
drawPatR (0, fi screenHeight) (dirtToColour pat) screen beat
|
||||
|
||||
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 }
|
||||
Graphics.UI.SDL.flip screen
|
||||
FR.delay fps
|
||||
unless quit' looping
|
||||
where
|
||||
action e = do
|
||||
scene <- get
|
||||
scene' <- handleEvent scene e
|
||||
put scene'
|
||||
|
||||
initEnv :: MVar ControlPattern -> IO AppConfig
|
||||
initEnv mp = do
|
||||
time' <- time
|
||||
time' <- FD.time
|
||||
screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface]
|
||||
font' <- openFont "futura.ttf" 22
|
||||
setCaption "Cycle" []
|
||||
|
|
@ -179,17 +111,17 @@ drawArc
|
|||
-> (Double, Double) -- Torus`s internal and external radiuses.
|
||||
-> Double -- (pi*2) * fromRational (s - (toRational $ beat / 8))
|
||||
-> Double -- ((pi*2) * fromRational (e-s))
|
||||
-> Double -- step
|
||||
-> Double -- pace
|
||||
-> IO ()
|
||||
drawArc screen c (x,y) (r,r') t o step'
|
||||
drawArc screen c (x,y) (r,r') t o pace
|
||||
| o <= 0 = return ()
|
||||
| otherwise = do
|
||||
let pix = colourToPixel c
|
||||
void $ SDLP.filledPolygon screen coords pix
|
||||
drawArc screen c (x,y) (r,r') t (o-step') step'
|
||||
drawArc screen c (x,y) (r,r') t (o - pace) pace
|
||||
return ()
|
||||
where
|
||||
a = max t (t + o - step') -- start width
|
||||
a = max t (t + o - pace) -- start width
|
||||
b = t + o -- end width
|
||||
coords :: [(Int16, Int16)]
|
||||
coords = map (\(x',y') -> (floor $ x + x', floor $ y + y'))
|
||||
|
|
@ -206,41 +138,38 @@ drawPatC
|
|||
-> Surface
|
||||
-> Double
|
||||
-> IO ()
|
||||
drawPatC (r,r') pat screen beat = mapM_ drawEvents $ event pos pat
|
||||
drawPatC (r,r') pat screen beat = mapM_ drawEvents $ event (pos beat) 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))
|
||||
drawEvents ((b,e), cs) =
|
||||
mapM_ (\(index', color) -> drawEvent (b,e) color index' (length cs))
|
||||
(enumerate $ reverse cs)
|
||||
|
||||
drawEvent :: (Rational, Rational) -> ColourD -> Int -> Int -> IO ()
|
||||
drawEvent (begin, end) color index' len = do
|
||||
drawEvent (b, e) color index' len = do
|
||||
let thickness = (1 / fromIntegral len) * (r' - r)
|
||||
let thickIndex = r + thickness * fromIntegral index'
|
||||
|
||||
drawArc screen color middle (thickIndex, thickIndex + thickness)
|
||||
((pi*2) * fromRational (begin - pos)) ((pi*2) * fromRational (end - begin)) (pi/16)
|
||||
((pi*2) * fromRational (b - pos beat)) ((pi*2) * fromRational (e - b)) (pi/16)
|
||||
|
||||
-- Draw one cycle patterns
|
||||
-- Draw one rectangle pattern
|
||||
drawRect :: Surface
|
||||
-> ColourD
|
||||
-> (Double, Double) -- thickIndex, thickIndex + thickness
|
||||
-> Double -- ((pi*2) * fromRational (start - pos))
|
||||
-> Double -- ((pi*2) * fromRational (end - start))
|
||||
-> Double -- step (pi/16)
|
||||
-> Double -- pace (pi/16)
|
||||
-> IO ()
|
||||
drawRect screen c (thickStart,thickEnd) t o step
|
||||
drawRect screen c (thickStart,thickEnd) t o pace
|
||||
| o <= 0 = return ()
|
||||
| otherwise = do
|
||||
let pix = colourToPixel c
|
||||
void $ SDLP.filledPolygon screen coords pix
|
||||
drawRect screen c (thickStart, thickEnd) t (o - step) step
|
||||
drawRect screen c (thickStart, thickEnd) t (o - pace) pace
|
||||
return ()
|
||||
where
|
||||
a = max t (t + o - step) --
|
||||
a = max t (t + o - pace) --
|
||||
b = t + o
|
||||
|
||||
coords = map (\(x',y') -> (floor x', floor y'))
|
||||
|
|
@ -250,39 +179,36 @@ drawRect screen c (thickStart,thickEnd) t o step
|
|||
, (a, thickStart) -- 4
|
||||
]
|
||||
|
||||
-- Draw cycle patterns continiously
|
||||
-- Draw rectangle patterns continiously
|
||||
drawPatR :: (Double, Double) -> Pat.Pattern ColourD -> Surface -> Double -> IO ()
|
||||
drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event pos p
|
||||
drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event (pos beat) 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)
|
||||
drawEvents ((b, e), cs) =
|
||||
mapM_ (\(index', c) -> drawEvent (b, e) c index' (length cs)) (enumerate $ reverse cs)
|
||||
|
||||
drawEvent :: (Rational, Rational) -> ColourD -> Int -> Int -> IO ()
|
||||
drawEvent (begin, end) color index' len = do
|
||||
drawEvent (b, e) color index' len = do
|
||||
let thickness = (1 / fromIntegral len) * (x2 - x1)
|
||||
let thickIndex = thickness * fromIntegral index'
|
||||
let width = fi screenWidth
|
||||
drawRect screen color (thickIndex, thickIndex + thickness)
|
||||
(width * fromRational (begin - pos)) (width * fromRational (end - begin)) 1
|
||||
(width * fromRational (b - pos beat)) (width * fromRational (e - b)) 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))
|
||||
event position pat = map (\(Pat.Event _ Arc{..} events) ->
|
||||
((max start position, min stop (position + 1)), events))
|
||||
$ queryArc (segmentator pat) (Arc position (position + 1))
|
||||
|
||||
whileEvents :: MonadIO m => (Event -> m ()) -> m Bool
|
||||
whileEvents act = do
|
||||
whileEvents action = do
|
||||
ev <- liftIO pollEvent
|
||||
case ev of
|
||||
Quit -> return True
|
||||
NoEvent -> return False
|
||||
_ -> do
|
||||
act ev
|
||||
whileEvents act
|
||||
action ev
|
||||
whileEvents action
|
||||
|
||||
textSize :: String -> Font -> IO (Float,Float)
|
||||
textSize text font' =
|
||||
|
|
@ -290,14 +216,12 @@ textSize text font' =
|
|||
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)
|
||||
colourToPixel c = rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255)
|
||||
where (RGB r g b) = toSRGB c
|
||||
|
||||
colourToPixelS :: Surface -> Colour Double -> IO Pixel
|
||||
colourToPixelS s c =
|
||||
(mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255)
|
||||
colourToPixelS surface c =
|
||||
(mapRGB . surfaceGetPixelFormat) surface (floor $ r*255) (floor $ g*255) (floor $ b*255)
|
||||
where (RGB r g b) = toSRGB c
|
||||
|
||||
rgbColor :: GHC.Word.Word8 -> GHC.Word.Word8 -> GHC.Word.Word8 -> Pixel
|
||||
|
|
@ -311,5 +235,48 @@ rgbColor r g b = Pixel
|
|||
pixel :: Surface -> (GHC.Word.Word8,GHC.Word.Word8,GHC.Word.Word8) -> IO Pixel
|
||||
pixel face (r,g,b) = mapRGB (surfaceGetPixelFormat face) r g b
|
||||
|
||||
screenWidth :: Int
|
||||
screenWidth = 500
|
||||
|
||||
screenHeight :: Int
|
||||
screenHeight = 400
|
||||
|
||||
screenBpp :: Int
|
||||
screenBpp = 32
|
||||
|
||||
-- A middle of window.
|
||||
middle :: (Double, Double)
|
||||
middle = (fromIntegral $ screenWidth `div` 2, fromIntegral $ screenHeight `div` 2)
|
||||
|
||||
fromScreen :: (Int, Int) -> (Float, Float)
|
||||
fromScreen (x, y) =
|
||||
( fromIntegral x / fromIntegral screenWidth
|
||||
, fromIntegral y / fromIntegral screenHeight
|
||||
)
|
||||
|
||||
pos :: Double -> Rational
|
||||
pos beat = toRational $ beat / 8
|
||||
|
||||
isInside :: Integral a => Rect -> a -> a -> Bool
|
||||
isInside (Rect rx ry rw rh) x y =
|
||||
(x' > rx) && (x' < rx + rw) && (y' > ry) && (y' < ry + rh)
|
||||
where (x', y') = (fromIntegral x, fromIntegral y)
|
||||
|
||||
ctrlDown :: [Modifier] -> Bool
|
||||
ctrlDown = any (`elem` [KeyModLeftCtrl, KeyModRightCtrl])
|
||||
|
||||
shiftDown :: [Modifier] -> Bool
|
||||
shiftDown = any (`elem` [ KeyModLeftShift, KeyModRightShift, KeyModShift])
|
||||
|
||||
handleEvent :: Scene -> Event -> AppEnv Scene
|
||||
handleEvent scene (KeyDown k) =
|
||||
handleKey scene (symKey k) (symUnicode k) (symModifiers k)
|
||||
handleEvent scene _ = return scene
|
||||
|
||||
handleKey :: Scene -> SDLKey -> Char -> [Modifier] -> AppEnv Scene
|
||||
handleKey scene SDLK_SPACE _ _ = return scene
|
||||
handleKey scene _ _ _ = return scene
|
||||
|
||||
applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool
|
||||
applySurface x y src dst clip = blitSurface src clip dst rect
|
||||
where rect = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 }
|
||||
|
|
|
|||
|
|
@ -9,10 +9,7 @@ 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.
|
||||
-- | Examples how to render still images to PDF or SVG formats.
|
||||
--
|
||||
-- | Here is renders of still images only.
|
||||
main :: IO ()
|
||||
|
|
@ -36,6 +33,18 @@ gradientRect = renderGradientPDF "./examples/gradientRect" pip
|
|||
matCycleWithBorders :: IO ()
|
||||
matCycleWithBorders = renderCyclePDF "./examples/cycle" "background text" pip
|
||||
|
||||
repeater :: Pattern ColourD
|
||||
repeater = dirtToColour
|
||||
$ juxBy 0.6 brak
|
||||
$ every 2 ((* speed (1 + sine)) . ply 4)
|
||||
$ stack
|
||||
[ s "bd:4 ~ ~ drum:3 ~ ~ drum:2 ~"
|
||||
, s "~ wind:1/2 hh:9"
|
||||
, s "subroc3d:9(2,7)"
|
||||
]
|
||||
# speed 0.5
|
||||
# legato 1
|
||||
|
||||
-- | Prepared patterns.
|
||||
foo :: Pattern ColourD
|
||||
foo = dirtToColour $ striate 16 $ sound "[bd*3? dr2, ~ casio ~, [bd arpy]]" # n
|
||||
|
|
|
|||
|
|
@ -0,0 +1,57 @@
|
|||
module Realtime.Animation
|
||||
( movingPatterns
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Sequence (Seq (..), (<|))
|
||||
import Graphics.Gloss
|
||||
import Graphics.Gloss.Interface.IO.Simulate
|
||||
import Realtime.Types (ColorI)
|
||||
|
||||
import qualified Data.Sequence as S
|
||||
|
||||
|
||||
window :: Display
|
||||
window = InWindow "Nice Window" (500, 500) (20, 20)
|
||||
|
||||
background :: Color
|
||||
background = greyN 0.1
|
||||
|
||||
movingPatterns :: MVar [ColorI] -> IO ()
|
||||
movingPatterns tp = simulateIO window background 12
|
||||
(S.singleton [(200,100,200,250)])
|
||||
(pure . pictures . seqToPics)
|
||||
$ \_ _ seqColors -> do
|
||||
mColors <- tryTakeMVar tp
|
||||
let colsNew = fromMaybe [] mColors
|
||||
let headColors = seqColors `S.index` 0
|
||||
pure $ if headColors==colsNew || null colsNew then seqColors else addColorList colsNew seqColors
|
||||
where
|
||||
seqToPics :: Seq [ColorI] -> [Picture]
|
||||
seqToPics = S.foldMapWithIndex (\i c -> makeLine (length c) i c)
|
||||
|
||||
makeLine :: Int -> Int -> [ColorI] -> [Picture]
|
||||
makeLine cLength i = map (\(n,col) -> rectLinesDown col n cLength i) . zip [0..]
|
||||
-- Keep circle list length equal to 'n'.
|
||||
refrain :: Int -> Seq [ColorI] -> Seq [ColorI]
|
||||
refrain n xs
|
||||
| S.length xs <= n = xs
|
||||
| otherwise = S.take n xs
|
||||
-- Every round number spawn circle and add it to right end. Colorize new circle with new color.
|
||||
addColorList :: [ColorI] -> Seq [ColorI] -> Seq [ColorI]
|
||||
addColorList colors seqColors = colors <| refrain 10 seqColors
|
||||
|
||||
rectLinesDown :: ColorI -> Float -> Int -> Int -> Picture
|
||||
rectLinesDown col n l i
|
||||
= translate (piece * n - 250 + piece / 2) (225 - 50 * fromIntegral i)
|
||||
$ color (makeColorFromIntTuple col)
|
||||
$ rectangleSolid piece 50
|
||||
where
|
||||
piece = 500 / fromIntegral l
|
||||
|
||||
makeColorFromIntTuple :: (Int, Int, Int, Int) -> Color
|
||||
makeColorFromIntTuple (r,g,b,a) = makeColorI r g b a
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,58 @@
|
|||
module Realtime.Server
|
||||
( animeCollectorServerU
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.Async (race_)
|
||||
import Control.Concurrent.Chan.Unagi.Bounded (InChan, OutChan)
|
||||
import Control.Monad
|
||||
import Sound.OSC
|
||||
|
||||
import qualified Control.Concurrent.Chan.Unagi.Bounded as U
|
||||
import qualified Sound.OSC.FD as FD
|
||||
|
||||
import Realtime.Animation (movingPatterns)
|
||||
import Realtime.Types (ColorI, TidalPacket (..), packetToTidalPacket)
|
||||
|
||||
|
||||
-- Command to start the server in a repl for testing
|
||||
-- do u <- t0; udp_close u; hoscServerTPU
|
||||
|
||||
animeCollectorServerU :: IO ()
|
||||
animeCollectorServerU = do
|
||||
(inChan, outChan) <- U.newChan 100
|
||||
mvar <- newEmptyMVar
|
||||
race_ (hoscServerTPU inChan) $ race_ (collector outChan mvar) (movingPatterns mvar)
|
||||
|
||||
t0 :: IO UDP
|
||||
t0 = udpServer "127.0.0.1" 5050
|
||||
|
||||
-- Listen to osc packets and write them to channel.
|
||||
hoscServerTPU :: InChan TidalPacket -> IO ()
|
||||
hoscServerTPU inChan = FD.withTransport t0 $ \udp -> forever $ do
|
||||
packet <- udp_recv_packet udp
|
||||
let tp = packetToTidalPacket packet
|
||||
U.writeChan inChan tp
|
||||
|
||||
-- Collect sync packets to list and put mvar for animation.
|
||||
collector :: OutChan TidalPacket -> MVar [ColorI] -> IO ()
|
||||
collector outChan mvColors = do
|
||||
buffer <- newEmptyMVar
|
||||
forever $ do
|
||||
c <- U.readChan outChan
|
||||
mtp <- tryTakeMVar buffer
|
||||
case mtp of
|
||||
Nothing -> putMVar buffer (tpTime c, [tpColor c])
|
||||
Just tp ->
|
||||
if fst tp == tpTime c
|
||||
then void $ putMVar buffer (toTuple c tp)
|
||||
else do
|
||||
putMVar buffer (tpTime c, [tpColor c])
|
||||
putMVar mvColors $ snd tp
|
||||
|
||||
-- Take time and color.
|
||||
toTuple :: TidalPacket -> (Double, [ColorI]) -> (Double, [ColorI])
|
||||
toTuple tp (f,tps) = (f, tpColor tp : tps)
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
module Realtime.Types
|
||||
( TidalPacket (..)
|
||||
, ColorI
|
||||
, defaultTidalPacket
|
||||
, packetToTidalPacket
|
||||
, parsePacket
|
||||
) where
|
||||
|
||||
import Data.Bits (shiftR, (.&.))
|
||||
import Data.Hashable (hash)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Sound.OSC
|
||||
|
||||
|
||||
data TidalPacket = TidalPacket
|
||||
{ tpTime :: Double
|
||||
, tpCycle :: Float
|
||||
, tpDelta :: Float
|
||||
, tpColor :: ColorI
|
||||
} deriving (Eq, Show)
|
||||
|
||||
type ColorI = (Int, Int, Int, Int)
|
||||
|
||||
defaultTidalPacket :: TidalPacket
|
||||
defaultTidalPacket = TidalPacket
|
||||
{ tpTime = immediately
|
||||
, tpCycle = 1.0
|
||||
, tpDelta = 1.0
|
||||
, tpColor = (100, 200, 50, 250)
|
||||
}
|
||||
|
||||
parsePacket :: Packet -> Maybe (Int,Int,Int,Int)
|
||||
parsePacket p = tupleI list
|
||||
where
|
||||
list = mapM datum_integral . messageDatum =<< packet_to_message p
|
||||
tupleI = \case
|
||||
Nothing -> Nothing
|
||||
Just list' -> case list' of
|
||||
(r:g:b:a:_) -> Just (r,g,b,a)
|
||||
_ -> Nothing
|
||||
|
||||
stringToColour :: String -> (Int,Int,Int,Int)
|
||||
stringToColour str = (r, g, b, 250)
|
||||
where
|
||||
i = hash str `mod` 16777216
|
||||
r = (i .&. 0xFF0000) `shiftR` 16
|
||||
g = (i .&. 0x00FF00) `shiftR` 8
|
||||
b = i .&. 0x0000FF
|
||||
|
||||
deleteDatumValue :: String -> [Datum] -> [Datum]
|
||||
deleteDatumValue d ds = go
|
||||
where
|
||||
go = case break (==d') ds of
|
||||
(f,x:_:xs) -> f ++ (x:xs)
|
||||
_ -> []
|
||||
d' = string d
|
||||
|
||||
roundFloats :: Datum -> Datum
|
||||
roundFloats = \case
|
||||
Float d_float -> Float (fromInteger (round $ d_float * 10000) / 10000)
|
||||
x -> x
|
||||
|
||||
takeDatumValue :: String -> [Datum] -> Datum
|
||||
takeDatumValue d ds = go
|
||||
where
|
||||
go = case break (== d') ds of
|
||||
(_,_:v:_) -> v
|
||||
_ -> string "No value for your datum"
|
||||
d' = string d
|
||||
|
||||
packetToTidalPacket :: Packet -> TidalPacket
|
||||
packetToTidalPacket p = TidalPacket
|
||||
{ tpTime = bundleTime bund
|
||||
, tpCycle = cycle'
|
||||
, tpDelta = delta'
|
||||
, tpColor = color'
|
||||
}
|
||||
where
|
||||
bund = packet_to_bundle p
|
||||
datums = concatMap messageDatum $ bundleMessages bund
|
||||
cycle' = takeFloat "cycle" datums
|
||||
delta' = takeFloat "delta" datums
|
||||
color' = stringToColour $ show $ deleteDatumValue "cycle" datums
|
||||
takeFloat str = fromMaybe 0 . datum_floating . roundFloats . takeDatumValue str
|
||||
|
|
@ -1,14 +1,15 @@
|
|||
resolver: lts-13.8
|
||||
resolver: lts-13.19
|
||||
|
||||
# packages: []
|
||||
|
||||
|
||||
extra-deps:
|
||||
- SDL-0.6.7.0
|
||||
- cairo-0.13.6.0
|
||||
- tidal-1.0.7
|
||||
- gtk2hs-buildtools-0.13.5.0
|
||||
- SDL-0.6.7.0
|
||||
- SDL-gfx-0.7.0.0
|
||||
- SDL-image-0.6.2.0
|
||||
- SDL-ttf-0.6.3.0
|
||||
- unagi-chan-0.4.1.0
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
name: tidal-vis
|
||||
version: 1.0.7
|
||||
synopsis: Visual rendering for Tidal patterns
|
||||
-- description:
|
||||
version: 1.0.13
|
||||
synopsis: Visual rendering for Tidal patterns and osc messages
|
||||
homepage: http://yaxu.org/tidal/
|
||||
license: GPL-3
|
||||
license-file: LICENSE
|
||||
|
|
@ -17,10 +16,34 @@ cabal-version: 2.0
|
|||
|
||||
Description: Tidal is a domain specific language for live coding pattern. This package allows colour patterns to be rendered as PDF or SVG files.
|
||||
|
||||
executable tidal-vis
|
||||
hs-source-dirs: app
|
||||
main-is: Main.hs
|
||||
|
||||
ghc-options: -Wall
|
||||
-threaded
|
||||
-rtsopts
|
||||
-with-rtsopts=-N
|
||||
-Wincomplete-uni-patterns
|
||||
-Wincomplete-record-updates
|
||||
-Wcompat
|
||||
-Widentities
|
||||
-Wredundant-constraints
|
||||
-fhide-source-paths
|
||||
-Wpartial-fields
|
||||
|
||||
build-depends: base
|
||||
, tidal-vis
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
library
|
||||
Exposed-modules: Common
|
||||
CycleAnimation
|
||||
Examples
|
||||
Realtime.Animation
|
||||
Realtime.Server
|
||||
Realtime.Types
|
||||
Vis
|
||||
VisCycle
|
||||
VisGradient
|
||||
|
|
@ -28,20 +51,34 @@ library
|
|||
hs-source-dirs: src
|
||||
|
||||
Build-depends: base < 5
|
||||
, tidal>=1.0.7
|
||||
, colour
|
||||
, async
|
||||
, cairo
|
||||
, colour
|
||||
, containers
|
||||
, gloss
|
||||
, hashable
|
||||
, hosc
|
||||
, SDL
|
||||
, mtl
|
||||
, SDL-gfx
|
||||
, SDL-image
|
||||
, SDL-ttf
|
||||
, hosc
|
||||
, hashable
|
||||
, time
|
||||
, mtl
|
||||
, network
|
||||
, tidal>=1.0.13
|
||||
, time
|
||||
, unagi-chan
|
||||
|
||||
ghc-options: -Wall
|
||||
-Wincomplete-uni-patterns
|
||||
-Wincomplete-record-updates
|
||||
-Wcompat
|
||||
-Widentities
|
||||
-Wredundant-constraints
|
||||
-fhide-source-paths
|
||||
-Wpartial-fields
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
default-extensions: OverloadedStrings
|
||||
RecordWildCards
|
||||
LambdaCase
|
||||
|
|
|
|||
Loading…
Reference in New Issue