twiddle

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

Conflicts:
	Dirt.hs

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]")
+

Parse.hs

@@ -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

Pattern.hs

@@ -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)
+

Stream.hs

@@ -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

Visual.hs

@@ -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