Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 168 lines (136 sloc) 5.792 kb
945543de » alex
2012-12-28 ressurect Stream.hs
1 {-# LANGUAGE OverloadedStrings, FlexibleInstances, RankNTypes, NoMonomorphismRestriction #-}
2
3 module Stream where
4
5 import Data.Maybe
6 import Sound.OSC.FD
7 import Sound.OpenSoundControl
8 import Control.Applicative
9 import Network.Netclock.Client
10 import Control.Concurrent
11 import Control.Concurrent.MVar
12 import Pattern
13 import Data.Ratio
14 --import Control.Exception
15 import Parse
16
17 import qualified Data.Map as Map
18
19 data Param = S {name :: String, sDefault :: Maybe String}
20 | F {name :: String, fDefault :: Maybe Double}
21 | I {name :: String, iDefault :: Maybe Int}
22
23 instance Eq Param where
24 a == b = name a == name b
25
26 instance Ord Param where
27 compare a b = compare (name a) (name b)
28 instance Show Param where
29 show p = name p
30
31 data OscShape = OscShape {path :: String,
32 params :: [Param],
33 timestamp :: Bool
34 }
35 type OscMap = Map.Map Param (Maybe Datum)
36
37 type OscSequence = Sequence OscMap
38 type OscSignal = Signal OscMap
39
40 defaultDatum :: Param -> Maybe Datum
41 defaultDatum (S _ (Just x)) = Just $ String x
42 defaultDatum (I _ (Just x)) = Just $ Int x
43 defaultDatum (F _ (Just x)) = Just $ Float x
44 defaultDatum _ = Nothing
45
46 hasDefault :: Param -> Bool
47 hasDefault (S _ Nothing) = False
48 hasDefault (I _ Nothing) = False
49 hasDefault (F _ Nothing) = False
50 hasDefault _ = True
51
52 defaulted :: OscShape -> [Param]
53 defaulted = filter hasDefault . params
54
55 defaultMap :: OscShape -> OscMap
56 defaultMap s
57 = Map.fromList $ map (\x -> (x, defaultDatum x)) (defaulted s)
58
59 required :: OscShape -> [Param]
60 required = filter (not . hasDefault) . params
61
62 hasRequired :: OscShape -> OscMap -> Bool
63 hasRequired s m = isSubset (required s) (Map.keys (Map.filter (\x -> x /= Nothing) m))
64
65 isSubset :: (Eq a) => [a] -> [a] -> Bool
66 isSubset xs ys = all (\x -> elem x ys) xs
67
68 tpb = 1
69
70 toMessage :: OscShape -> BpsChange -> Int -> (Double, OscMap) -> Maybe Bundle
71 toMessage s change ticks (o, m) =
72 do m' <- applyShape' s m
73 let beat = fromIntegral ticks / fromIntegral tpb
74 latency = 0.019
75 logicalNow = (logicalTime change beat)
76 beat' = (fromIntegral ticks + 1) / fromIntegral tpb
77 logicalPeriod = (logicalTime change (beat + 1)) - logicalNow
78 logicalOnset = ntpr_to_ut $ logicalNow + (logicalPeriod * o) + latency
79 sec = floor logicalOnset
80 usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))
81 oscdata = catMaybes $ mapMaybe (\x -> Map.lookup x m') (params s)
82 oscdata' = ((Int sec):(Int usec):oscdata)
83 osc | timestamp s = Bundle (immediately) [Message (path s) oscdata']
84 | otherwise = Bundle (immediately) [Message (path s) oscdata]
85 return osc
86
87
88 applyShape' :: OscShape -> OscMap -> Maybe OscMap
89 applyShape' s m | hasRequired s m = Just $ Map.union m (defaultMap s)
90 | otherwise = Nothing
91
92 start :: String -> String -> String -> String -> Int -> OscShape -> IO (MVar (OscSequence))
93 start client server name address port shape
94 = do patternM <- newMVar silence
95 putStrLn $ "connecting " ++ (show address) ++ ":" ++ (show port)
96 s <- openUDP address port
97 putStrLn $ "connected "
98 let ot = (onTick s shape patternM) :: BpsChange -> Int -> IO ()
99 forkIO $ clocked name client server 1 ot
100 return patternM
101
102 stream :: String -> String -> String -> String -> Int -> OscShape -> IO (OscSequence -> IO ())
103 stream client server name address port shape
104 = do patternM <- start client server name address port shape
105 return $ \p -> do swapMVar patternM p
106 return ()
107
108 streamcallback :: (OscSequence -> IO ()) -> String -> String -> String -> String -> Int -> OscShape -> IO (OscSequence -> IO ())
109 streamcallback callback client server name address port shape
110 = do f <- stream client server name address port shape
111 let f' p = do callback p
112 f p
113 return f'
114
115 onTick :: UDP -> OscShape -> MVar (OscSequence) -> BpsChange -> Int -> IO ()
116 onTick s shape patternM change ticks
117 = do p <- readMVar patternM
118 let tpb' = 2 :: Integer
119 ticks' = (fromIntegral ticks) :: Integer
120 a = ticks' % tpb'
121 --a = (ticks' `mod` tpb') % tpb'
122 b = 1 % tpb'
123 messages = mapMaybe
124 (toMessage shape change ticks)
125 (seqToRelOnsets (a, Just b) p)
126 --putStrLn $ (show a) ++ ", " ++ (show b)
127 --putStrLn $ "tick " ++ show ticks ++ " = " ++ show messages
128 catch (mapM_ (sendOSC s) messages) (\msg -> putStrLn $ "oops " ++ show msg)
129 return ()
130
131 ticker :: IO (MVar Rational)
132 ticker = do mv <- newMVar 0
133 forkIO $ clocked "ticker" "127.0.0.1" "127.0.0.1" tpb (f mv)
134 return mv
135 where f mv change ticks = do swapMVar mv ((fromIntegral ticks) / (fromIntegral tpb))
136 return ()
137 tpb = 32
138
139 make :: ParseablePattern p => (a -> Datum) -> OscShape -> String -> p a -> (p OscMap)
140 make toOsc s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p
141 where nParam = param s nm
142 defaultV a = Just $ toOsc a
143 --defaultV Nothing = defaultDatum nParam
144
145 makeS = make String
146 makeF = make Float
147 makeI = make Int
148
149 param :: OscShape -> String -> Param
150 param shape n = head $ filter (\x -> name x == n) (params shape)
151
152 -- Merge any pattern with a sequence
153 merge :: ParseablePattern p => OscSequence -> p OscMap -> OscSequence
154 merge x y = Map.union <$> x <~> y
155
156 merge' :: ParseablePattern p => OscSequence -> p OscMap -> OscSequence
157 merge' x y = Map.union <$> x <~> y
158
159 infixr 1 ~~
160 (~~) = merge
161
162 infixr 1 |+|
163 (|+|) :: OscSequence -> OscSequence -> OscSequence
164 (|+|) = (~~)
165
166 infixr 1 |+~
167 (|+~) :: OscSequence -> OscSignal -> OscSequence
168 (|+~) = (~~)
169
Something went wrong with that request. Please try again.