Permalink
Browse files

twiddle

Merge branch 'master' of github.com:yaxu/smooth

Conflicts:
	Dirt.hs
  • Loading branch information...
2 parents 3e4e832 + afcd347 commit 15ec723a8dc855bf4ec1bc17ff55ab96817511e2 @yaxu committed Dec 28, 2012
Showing with 175 additions and 5 deletions.
  1. +36 −1 Dirt.hs
  2. +0 −1 Parse.hs
  3. +31 −3 Pattern.hs
  4. +15 −0 Stream.hs
  5. +93 −0 Visual.hs
View
37 Dirt.hs
@@ -7,7 +7,14 @@ import Pattern
import Parse
import Sound.OpenSoundControl
import qualified Data.Map as Map
+import Control.Applicative
import Control.Concurrent.MVar
+import Visual
+import Data.Colour.SRGB
+import Data.Colour.Names
+import Data.Hashable
+import Data.Bits
+import Data.Maybe
dirt :: OscShape
dirt = OscShape {path = "/play",
@@ -35,6 +42,33 @@ dirt = OscShape {path = "/play",
dirtstream name = stream "127.0.0.1" "127.0.0.1" name "127.0.0.1" 7771 dirt
+dirtToColour :: OscSequence -> Sequence ColourD
+dirtToColour p = s
+ where s = fmap (\x -> maybe black (maybe black datumToColour) (Map.lookup (param dirt "sound") x)) p
+
+datumToColour :: Datum -> ColourD
+datumToColour = stringToColour . show
+
+stringToColour :: String -> ColourD
+stringToColour s = sRGB (r/256) (g/256) (b/256)
+ where i = (hash s) `mod` 16777216
+ r = fromIntegral $ (i .&. 0xFF0000) `shiftR` 16;
+ g = fromIntegral $ (i .&. 0x00FF00) `shiftR` 8;
+ b = fromIntegral $ (i .&. 0x0000FF);
+
+
+visualcallback :: IO (OscSequence -> IO ())
+visualcallback = do t <- ticker
+ mv <- startVis t
+ let f p = do let p' = dirtToColour p
+ swapMVar mv p'
+ return ()
+ return f
+
+dirtyvisualstream name = do cb <- visualcallback
+ streamcallback cb "127.0.0.1" "127.0.0.1" name "127.0.0.1" 7771 dirt
+
+
sound = makeS dirt "sound"
offset = makeF dirt "offset"
begin = makeF dirt "begin"
@@ -58,4 +92,5 @@ striateO :: OscSequence -> Int -> Double -> OscSequence
striateO p n o = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]
where off i p = p ~~ begin ((atom $ (fromIntegral i / fromIntegral n) + o) :: Sequence Double) ~~ end ((atom $ (fromIntegral (i+1) / fromIntegral n) + o) :: Sequence Double)
-metronome = slow 2 $ sound (p "[odx, [hh]*8]")
+metronome = slow 2 $ sound (p "[odx, [hh]*8]")
+
View
@@ -10,7 +10,6 @@ import Data.Ratio
import Data.Colour
import Data.Colour.Names
import Data.Colour.SRGB
-
import GHC.Exts( IsString(..) )
class (Pattern p) => ParseablePattern p where
View
@@ -9,6 +9,7 @@ import Data.Maybe
import Data.Ratio
import Debug.Trace
import Data.Typeable
+import Data.Function
type Time = Rational
type Arc = (Time, Time)
@@ -17,9 +18,8 @@ type Range = (Time, Maybe Time)
type Event a = (Arc, a)
data Sequence a = Sequence {range :: Range -> [Event a]}
- deriving (Typeable)
+
data Signal a = Signal {at :: Time -> [a]}
- deriving (Typeable)
instance (Show a) => Show (Sequence a) where
show p@(Sequence _) = show $ range p (0, Just 1)
@@ -160,7 +160,6 @@ infixl 4 <~>
(\x -> ((o,d), f x))
(at (toSignal xs) o)
) (fs r)
-
{-
(Signal fs) <*> px@(Sequence _) =
Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (range px (t,Nothing))
@@ -193,6 +192,15 @@ slow :: Pattern p => Time -> p a -> p a
slow 1 p = p
slow r p = mapTimeOut (* r) $ mapTime (/ r) p
+
+revT :: (Time, Time) -> (Time, Time)
+revT (s, d) = (s', d)
+ where sam' = sam s
+ x = s - sam'
+ y = sam' - x - d
+ z = y + d
+ s' = y + (z - s)
+
--rev :: Pattern p => p a -> p a
--rev p = mapTimeOut revT $ mapOnset revT p
@@ -238,3 +246,23 @@ mapSnd f (x,y) = (x,f y)
mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]
mapSnds = fmap . mapSnd
+segment :: Sequence a -> Sequence [a]
+segment p = Sequence $ \r -> groupByTime (segment' (range p r))
+
+segment' :: [Event a] -> [Event a]
+segment' es = foldr split es pts
+ where pts = nub $ points es
+
+groupByTime :: [Event a] -> [Event [a]]
+groupByTime es = map mrg $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) es
+ where mrg es@((a, _):_) = (a, map snd es)
+
+split :: Time -> [Event a] -> [Event a]
+split _ [] = []
+split t ((e@((s,d), v)):es) | t > s && t < s+d = ((s,t-s),v):((t,(s+d)-t),v):(split t es)
+ | otherwise = e:split t es
+
+points :: [Event a] -> [Time]
+points [] = []
+points (((s,d), _):es) = s:(s+d):(points es)
+
View
@@ -105,6 +105,13 @@ stream client server name address port shape
return $ \p -> do swapMVar patternM p
return ()
+streamcallback :: (OscSequence -> IO ()) -> String -> String -> String -> String -> Int -> OscShape -> IO (OscSequence -> IO ())
+streamcallback callback client server name address port shape
+ = do f <- stream client server name address port shape
+ let f' p = do callback p
+ f p
+ return f'
+
onTick :: UDP -> OscShape -> MVar (OscSequence) -> BpsChange -> Int -> IO ()
onTick s shape patternM change ticks
= do p <- readMVar patternM
@@ -121,6 +128,14 @@ onTick s shape patternM change ticks
catch (mapM_ (sendOSC s) messages) (\msg -> putStrLn $ "oops " ++ show msg)
return ()
+ticker :: IO (MVar Rational)
+ticker = do mv <- newMVar 0
+ forkIO $ clocked "ticker" "127.0.0.1" "127.0.0.1" tpb (f mv)
+ return mv
+ where f mv change ticks = do swapMVar mv ((fromIntegral ticks) / (fromIntegral tpb))
+ return ()
+ tpb = 32
+
make :: ParseablePattern p => (a -> Datum) -> OscShape -> String -> p a -> (p OscMap)
make toOsc s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p
where nParam = param s nm
View
@@ -0,0 +1,93 @@
+module Visual where
+
+import System.Exit ( exitWith, ExitCode(ExitSuccess) )
+import Graphics.UI.GLUT
+import Parse
+import Pattern
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Data.Colour
+import Data.Colour.Names
+import Data.Colour.SRGB
+
+drawOneLine :: Vertex2 GLfloat -> Vertex2 GLfloat -> IO ()
+drawOneLine p1 p2 = renderPrimitive Lines $ do vertex p1; vertex p2
+
+drawRect :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
+drawRect x y x' y'
+ = renderPrimitive Polygon $ do vertex$Vertex2 x y
+ vertex$Vertex2 x y'
+ vertex$Vertex2 x' y'
+ vertex$Vertex2 x' y
+ return ()
+
+myInit :: IO ()
+myInit = do
+ clearColor $= Color4 0 0 0 0
+ shadeModel $= Flat
+
+w = 1024
+lw = 150
+
+translatef = translate :: Vector3 GLfloat -> IO ()
+
+
+drawEvent e = do lineWidth $= lw'
+ preservingMatrix $ drawEvent' lw' e
+ where lw' = lw / (fromIntegral $ length $ snd e)
+
+drawEvent' :: GLfloat -> (Event [ColourD]) -> DisplayCallback
+drawEvent' _ (_, []) = return ()
+drawEvent' lw' ((t, d), c:cs)
+ = do let (Data.Colour.SRGB.RGB r g b) = toSRGB c
+ color (Color3 r g b)
+ --drawOneLine (Vertex2 (w * (fromRational t)) y) (Vertex2 (w * (fromRational $ t+d)) y)
+ drawRect (w * (fromRational t)) 0 (w * (fromRational $ t+d)) lw'
+ translatef (Vector3 0 (lw') 0)
+ drawEvent' lw' ((t,d), cs)
+ where y = (lw'/2)
+
+display :: MVar Rational -> MVar (Sequence ColourD) -> DisplayCallback
+display t mv = do
+ clear [ ColorBuffer ]
+ ticks <- readMVar t
+ p <-readMVar mv
+ mapM_ drawEvent (map (mapFst (\(t,d) -> ((t - (ticks/2))/speed,d/speed))) $ range (segment p) ((ticks/2), Just speed))
+ flush
+ where speed = 4
+
+reshape :: ReshapeCallback
+reshape size@(Size w h) = do
+ viewport $= (Position 0 0, size)
+ matrixMode $= Projection
+ loadIdentity
+ ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
+ -- the following line is not in the original example, but it's good style...
+ matrixMode $= Modelview 0
+
+keyboard :: KeyboardMouseCallback
+keyboard (Char '\27') Down _ _ = exitWith ExitSuccess
+keyboard _ _ _ _ = return ()
+
+animate = do
+ postRedisplay Nothing
+ addTimerCallback 16 $ animate
+
+-- Request double buffer display mode.
+-- Register mouse input callback functions
+startVis :: MVar Rational -> IO (MVar (Sequence ColourD))
+startVis t =
+ do initialize "smooth" []
+ initialDisplayMode $= [ SingleBuffered, RGBMode ]
+ initialWindowSize $= Size 1024 150
+ initialWindowPosition $= Position 100 100
+ createWindow "smooth"
+ myInit
+ mp <- newMVar (pure black)
+ displayCallback $= (display t mp)
+ addTimerCallback 80 $ animate
+ reshapeCallback $= Just reshape
+ keyboardMouseCallback $= Just keyboard
+ forkIO $ mainLoop
+ return mp

0 comments on commit 15ec723

Please sign in to comment.