tidal-0.1: Stream.lhs

> {-# LANGUAGE OverloadedStrings, FlexibleInstances, RankNTypes #-}

> module Stream where

> import Sound.OpenSoundControl
> import Network.Netclock.Client
> import Pattern
> import Rhythm
> import Data.Maybe
> import qualified Data.Map as Map
> import Control.Applicative
> import Control.Concurrent
> import Control.Concurrent.MVar
> import OscType
> import Control.Monad

> data OscShape = OscShape {path :: String, 
>                           params :: [Param], 
>                           timestamp :: Bool
>                           }
> type OscMap = Map.Map Param (Maybe Datum)
> type OscPattern = Pattern OscMap

 client = "158.223.59.84"
 server = "158.223.51.82"

 client = "127.0.0.1"
 server = "127.0.0.1"

> magicOffset :: Int
> magicOffset = 2

> tpb :: Int
> tpb = 4

> 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 tpb ot
>          return patternM

> onTick :: UDP -> OscShape -> MVar (OscPattern) -> BpsChange -> Int -> IO ()
> onTick s shape patternM change ticks
>     = do p <- readMVar patternM
>          let messages = mapMaybe (toMessage shape) (at p (ticks + magicOffset))
>          mapM_ (send s) messages
>          return ()

> 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 ()


> data Param = S {name :: String, sDefault :: Maybe String}
>            | F {name :: String, fDefault :: Maybe Double}
>            | I {name :: String, iDefault :: Maybe Int}
>            | T 

> instance Ord Param where
>     compare T T = EQ
>     compare _ T = GT
>     compare T _ = LT
>     compare a b = compare (name a) (name b)

> instance Eq Param where
>     T == T = True
>     T == _ = False
>     _ == T = False
>     a == b = name a == name b

> instance Show Param where
>     show T = "__timestamp"
>     show p = name p

> 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 T = Nothing
> defaultDatum _ = Nothing

> hasDefault :: Param -> Bool
> hasDefault (S _ Nothing) = False
> hasDefault (I _ Nothing) = False
> hasDefault (F _ Nothing) = False
> hasDefault T = True
> hasDefault _ = True

> defaultMap :: OscShape -> OscMap
> defaultMap s 
>     = Map.fromList $ map (\x -> (x, defaultDatum x)) (defaulted s)

> required :: OscShape -> [Param]
> required = filter (not . hasDefault) . params

> defaulted :: OscShape -> [Param]
> defaulted = filter hasDefault . params

> toMessage :: OscShape -> Maybe OscMap -> Maybe OSC
> toMessage s m = do m' <- applyShape' s m
>                    let ps = (params s)
>                        oscdata = catMaybes $ mapMaybe (\x -> Map.lookup x m') ps
>                        osc = Message (path s) oscdata
>                        -- TODO fix time stamping
>                        --osc' = stamp s t (join $ Map.lookup T m') osc
>                    return osc

> stamp :: OscShape -> Double -> (Maybe Datum) -> OSC -> OSC
> -- timestamp set to false
> stamp (OscShape _ _ False) _ _ osc = osc
> -- no offset given
> stamp _ t Nothing osc = Bundle (NTPi $ utcr_ntpi t) [osc]
> -- offset given
> stamp _ t (Just (Float offset)) osc = Bundle (NTPi ts) [osc]
>     where ts = utcr_ntpi (t + offset)

 toMsgPattern :: OscShape -> OscPattern -> Pattern (Maybe OSC)
 toMsgPattern s p = fmap (toMessage s) p

> applyShape :: OscShape -> OscPattern -> OscPattern
> applyShape s p = Pattern l (period p)
>     where l = map (applyShape' s) . at p

> applyShape' :: OscShape -> Maybe OscMap -> Maybe OscMap
> applyShape' _ Nothing = Nothing
> applyShape' s (Just m) | hasRequired s m = Just $ Map.union m (defaultMap s)
>                        | otherwise = Nothing

> 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

> make :: (a -> Datum) -> OscShape -> String -> Pattern a -> OscPattern
> make toOsc s nm p = Pattern l (period p)
>     where l n = map (\x -> Just $ Map.singleton nParam (defaultV x)) (at p n)
>           nParam = param s nm
>           defaultV (Just a) = Just $ toOsc a
>           defaultV Nothing = defaultDatum nParam

> makeS = make String
> makeF = make Float
> makeI = make Int
> makeT s = make Float s "__timestamp" 

> param :: OscShape -> String -> Param
> param _ "__timestamp" = T
> 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