Permalink
Browse files

visualisation working a bit more

  • Loading branch information...
1 parent 8c942dc commit afcd34746c6db719c05351f7aacff9beec438ab3 alex committed Dec 20, 2012
Showing with 78 additions and 29 deletions.
  1. +36 −1 Dirt.hs
  2. +9 −1 Stream.hs
  3. +33 −27 Visual.hs
View
37 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]"
View
@@ -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
View
@@ -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

0 comments on commit afcd347

Please sign in to comment.