visualisation working a bit more

Dirt.hs

@@ -7,8 +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",
@@ -36,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"
@@ -59,4 +92,6 @@ 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 "[odx, [hh]*8]"
+
+
+--metronome = slow 2 $ sound "[odx, [hh]*8]"

Stream.hs

@@ -105,7 +105,7 @@ 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 :: (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
@@ -128,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

@@ -1,16 +1,10 @@
-{-
-   Lines.hs (adapted from lines.c which is (c) Silicon Graphics, Inc.)
-   Copyright (c) Sven Panne 2002-2005 <sven.panne@aedion.de>
-   This file is part of HOpenGL and distributed under a BSD-style license
-   See the file libraries/GLUT/LICENSE
-
-   This program demonstrates geometric primitives and their attributes.
--}
+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
@@ -20,13 +14,21 @@ 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 = 400
+lw = 150
 
 translatef = translate :: Vector3 GLfloat -> IO ()
 
@@ -40,17 +42,20 @@ 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)
+       --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 (Sequence ColourD)) -> DisplayCallback
-display mv = do
+display :: MVar Rational -> MVar (Sequence ColourD) -> DisplayCallback
+display t mv = do
    clear [ ColorBuffer ]
+   ticks <- readMVar t
    p <-readMVar mv
-   mapM_ drawEvent (range (segment p) (0, Just 1))
+   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
@@ -71,17 +76,18 @@ animate = do
 
 --  Request double buffer display mode.
 --  Register mouse input callback functions
-start :: IO (MVar (Sequence ColourD))
-start = do initialize "smooth" []
-           initialDisplayMode $= [ SingleBuffered, RGBMode ]
-           initialWindowSize $= Size 1024 400
-           initialWindowPosition $= Position 100 100
-           createWindow "smooth"
-           myInit
-           mp <- newMVar (p "[white [red, [green orange] blue] red, tomato yellow]")
-           displayCallback $= (display mp)
-           addTimerCallback 100 $ animate  -- refresh every 1/10sec
-           reshapeCallback $= Just reshape
-           keyboardMouseCallback $= Just keyboard
-           forkIO $ mainLoop
-           return mp
+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