Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 8a0eb586ec
Fetching contributors…

Cannot retrieve contributors at this time

136 lines (105 sloc) 4.344 kb
{-# LANGUAGE OverloadedStrings, FlexibleInstances, RankNTypes #-}
module Stream where
import Data.Maybe
import Sound.OpenSoundControl
import Control.Applicative
import Network.Netclock.Client
import Control.Concurrent
import Control.Concurrent.MVar
import Pattern
import Data.Ratio
import qualified Data.Map as Map
data Param = S {name :: String, sDefault :: Maybe String}
| F {name :: String, fDefault :: Maybe Double}
| I {name :: String, iDefault :: Maybe Int}
instance Eq Param where
a == b = name a == name b
instance Ord Param where
compare a b = compare (name a) (name b)
instance Show Param where
show p = name p
data OscShape = OscShape {path :: String,
params :: [Param],
timestamp :: Bool
}
type OscMap = Map.Map Param (Maybe Datum)
type OscPattern = Pattern OscMap
defaultDatum :: Param -> Maybe Datum
defaultDatum (S _ (Just x)) = Just $ String x
defaultDatum (I _ (Just x)) = Just $ Int x
defaultDatum (F _ (Just x)) = Just $ Float x
defaultDatum _ = Nothing
hasDefault :: Param -> Bool
hasDefault (S _ Nothing) = False
hasDefault (I _ Nothing) = False
hasDefault (F _ Nothing) = False
hasDefault _ = True
defaulted :: OscShape -> [Param]
defaulted = filter hasDefault . params
defaultMap :: OscShape -> OscMap
defaultMap s
= Map.fromList $ map (\x -> (x, defaultDatum x)) (defaulted s)
required :: OscShape -> [Param]
required = filter (not . hasDefault) . params
hasRequired :: OscShape -> OscMap -> Bool
hasRequired s m = isSubset (required s) (Map.keys (Map.filter (\x -> x /= Nothing) m))
isSubset :: (Eq a) => [a] -> [a] -> Bool
isSubset xs ys = all (\x -> elem x ys) xs
tpb = 1
toMessage :: OscShape -> BpsChange -> Int -> (Double, OscMap) -> Maybe OSC
toMessage s change ticks (o, m) =
do m' <- applyShape' s m
let beat = fromIntegral ticks / fromIntegral tpb
latency = 0.04
logicalNow = (logicalTime change beat)
beat' = (fromIntegral ticks + 1) / fromIntegral tpb
logicalPeriod = (logicalTime change (beat + 1)) - logicalNow
logicalOnset = logicalNow + (logicalPeriod * o) + latency
sec = floor logicalOnset
usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))
oscdata = catMaybes $ mapMaybe (\x -> Map.lookup x m') (params s)
oscdata' = ((Int sec):(Int usec):oscdata)
osc = Message (path s) oscdata'
return osc
applyShape' :: OscShape -> OscMap -> Maybe OscMap
applyShape' s m | hasRequired s m = Just $ Map.union m (defaultMap s)
| otherwise = Nothing
start :: String -> String -> String -> String -> Int -> OscShape -> IO (MVar OscPattern)
start client server name address port shape
= do patternM <- newMVar silence
putStrLn $ "connecting " ++ (show address) ++ ":" ++ (show port)
s <- openUDP address port
putStrLn $ "connected "
let ot = (onTick s shape patternM) :: BpsChange -> Int -> IO ()
forkIO $ clocked name client server 1 ot
return patternM
stream :: String -> String -> String -> String -> Int -> OscShape -> IO (OscPattern -> IO ())
stream client server name address port shape
= do patternM <- start client server name address port shape
return $ \p -> do swapMVar patternM p
return ()
onTick :: UDP -> OscShape -> MVar (OscPattern) -> BpsChange -> Int -> IO ()
onTick s shape patternM change ticks
= do p <- readMVar patternM
let tpb' = fromIntegral tpb
ticks' = fromIntegral ticks
messages = mapMaybe
(toMessage shape change ticks)
(flat' (0,1) p)
--putStrLn $ "tick " ++ show ticks ++ " = " ++ show messages
mapM_ (send s) messages
return ()
make :: (a -> Datum) -> OscShape -> String -> Pattern a -> OscPattern
make toOsc s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p
where nParam = param s nm
defaultV a = Just $ toOsc a
--defaultV Nothing = defaultDatum nParam
makeS = make String
makeF = make Float
makeI = make Int
param :: OscShape -> String -> Param
param shape n = head $ filter (\x -> name x == n) (params shape)
merge :: OscPattern -> OscPattern -> OscPattern
merge x y = Map.union <$> x <*> y
infixr 1 ~~
(~~) = merge
Jump to Line
Something went wrong with that request. Please try again.