etc

minipat-dirt/src/Minipat/Dirt/EStream.hs

@@ -5,12 +5,7 @@ module Minipat.Dirt.EStream where
 
 import Control.Exception (Exception, SomeException (..))
 import Data.Kind (Type)
-import Data.Proxy (Proxy (..))
 import Data.Semigroup (Semigroup (..))
-import Data.String (IsString (..))
-import Data.Text (Text)
-import Data.Typeable (Typeable)
--- import Minipat.Eval (evalPat)
 import Minipat.Stream (Stream)
 import Minipat.Stream qualified as S
 

minipat-dirt/src/Minipat/Dirt/Eval.hs

@@ -1,11 +1,11 @@
 -- {-# LANGUAGE OverloadedStrings #-}
 
-module Minipat.Dirt.Eval
-  -- ( liveEvalPat
-  -- , liveEvalSoundPat
-  -- , liveEvalNotePat
-  -- )
-where
+module Minipat.Dirt.Eval where
+
+-- ( liveEvalPat
+-- , liveEvalSoundPat
+-- , liveEvalNotePat
+-- )
 
 -- import Control.Exception (Exception)
 -- import Dahdit.Midi.Osc (Datum (..), DatumType (..))

minipat-dirt/src/Minipat/Dirt/Osc.hs

@@ -1,8 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Minipat.Dirt.Osc
-  ( Timed (..)
+  ( DatumTypeProxy (..)
+  , unDatumTypeProxy
+  , Timed (..)
   , Attrs
+  , attrs
+  , IsAttrs (..)
+  , Attr (..)
   , PlayErr (..)
   , PlayEnv (..)
   , convertEvent
@@ -15,9 +20,10 @@ where
 import Control.Exception (Exception)
 import Control.Monad (foldM)
 import Control.Monad.Except (throwError)
-import Dahdit.Midi.Osc (Datum (..), Msg (..), Packet (..))
+import Dahdit.Midi.Osc (Datum (..), DatumType (..), IsDatum (..), Msg (..), Packet (..))
 import Dahdit.Midi.OscAddr (RawAddrPat)
 import Data.Foldable (foldl')
+import Data.Int (Int32)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Sequence (Seq (..))
@@ -27,6 +33,17 @@ import Minipat.Stream (Ev (..), Tape, tapeToList)
 import Minipat.Time (CycleDelta (..), CycleTime (..), Span, spanCycle, spanDelta)
 import Nanotime (PosixTime, TimeDelta (..), addTime, timeDeltaFromFracSecs, timeDeltaToNanos)
 
+data DatumTypeProxy a where
+  DatumLikeInt32 :: DatumTypeProxy Int32
+  DatumLikeFloat :: DatumTypeProxy Float
+  DatumLikeString :: DatumTypeProxy Text
+
+unDatumTypeProxy :: DatumTypeProxy a -> DatumType
+unDatumTypeProxy = \case
+  DatumLikeInt32 -> DatumTypeInt32
+  DatumLikeFloat -> DatumTypeFloat
+  DatumLikeString -> DatumTypeString
+
 data Timed a = Timed
   { timedKey :: !PosixTime
   , timedVal :: !a
@@ -35,6 +52,24 @@ data Timed a = Timed
 
 type Attrs = Map Text Datum
 
+attrs :: [(Text, Datum)] -> Attrs
+attrs = Map.fromList
+
+class IsAttrs a where
+  toAttrs :: a -> Attrs
+
+instance IsAttrs Attrs where
+  toAttrs = id
+
+data Attr a = Attr
+  { attrKey :: !Text
+  , attrVal :: !a
+  }
+  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance (IsDatum a) => IsAttrs (Attr a) where
+  toAttrs (Attr k v) = Map.singleton k (toDatum v)
+
 namedPayload :: Attrs -> Seq Datum
 namedPayload = foldl' go Empty . Map.toList
  where
@@ -114,26 +149,26 @@ timeDeltaToMicros td =
   let (_, ns) = timeDeltaToNanos td
   in  fromIntegral ns / 1000
 
-convertEvent :: PlayEnv -> Ev Attrs -> M (Timed Attrs)
+convertEvent :: (IsAttrs a) => PlayEnv -> Ev a -> M (Timed Attrs)
 convertEvent (PlayEnv startTime startCyc cps) (Ev sp dat) = do
   targetCyc <- fmap unCycleTime (spanCycleM sp)
   let cycOffset = targetCyc - fromInteger startCyc
       onset = addTime startTime (timeDeltaFromFracSecs (cycOffset / cps))
   deltaCyc <- fmap unCycleDelta (spanDeltaM sp)
   let deltaTime = timeDeltaToMicros (timeDeltaFromFracSecs (deltaCyc / cps))
-  dat' <- replaceAliases playAliases dat
+  dat' <- replaceAliases playAliases (toAttrs dat)
   dat'' <- insertSafe "delta" (DatumFloat deltaTime) dat'
   dat''' <- insertSafe "cps" (DatumFloat (realToFrac cps)) dat''
   pure (Timed onset dat''')
 
-convertTape :: PlayEnv -> Tape Attrs -> M (Seq (Timed Attrs))
+convertTape :: (IsAttrs a) => PlayEnv -> Tape a -> M (Seq (Timed Attrs))
 convertTape penv = traverse (convertEvent penv) . Seq.fromList . tapeToList
 
 playAddr :: RawAddrPat
 playAddr = "/dirt/play"
 
 playPacket :: Attrs -> Packet
-playPacket attrs = PacketMsg (Msg playAddr (namedPayload attrs))
+playPacket ats = PacketMsg (Msg playAddr (namedPayload ats))
 
 handshakeAddr :: RawAddrPat
 handshakeAddr = "/dirt/handshake"

minipat-dirt/src/Minipat/Dirt/Prelude.hs

@@ -2,28 +2,27 @@
 
 module Minipat.Dirt.Prelude where
 
-import Dahdit.Midi.Osc (Datum (..), DatumType (..), IsDatum (..))
-import Data.Map.Strict qualified as Map
+import Data.Int (Int32)
 import Data.Text (Text)
--- import Minipat.Dirt.Eval (liveEvalNotePat, liveEvalPat, liveEvalSoundPat)
-import Minipat.Dirt.Osc (Attrs)
+import Minipat.Dirt.Osc (Attr (..), Attrs, IsAttrs (..))
 import Minipat.Stream (Stream (..), streamInnerBind)
 
-setIn, (#) :: Stream Attrs -> Stream Attrs -> Stream Attrs
-setIn p1 p2 = streamInnerBind p1 (\m1 -> fmap (<> m1) p2)
+setIn, (#) :: (IsAttrs a, IsAttrs b) => Stream a -> Stream b -> Stream Attrs
+setIn p1 p2 = streamInnerBind p1 $ \m1 ->
+  let a1 = toAttrs m1 in fmap (\m2 -> toAttrs m2 <> a1) p2
 (#) = setIn
 
-pF :: (Real a) => Text -> Stream a -> Stream Attrs
-pF k = fmap (Map.singleton k . DatumFloat . realToFrac)
+pF :: (Real a) => Text -> Stream a -> Stream (Attr Float)
+pF k = fmap (Attr k . realToFrac)
 
-pI :: (Integral a) => Text -> Stream a -> Stream Attrs
-pI k = fmap (Map.singleton k . DatumInt32 . fromIntegral)
+pI :: (Integral a) => Text -> Stream a -> Stream (Attr Int32)
+pI k = fmap (Attr k . fromIntegral)
 
--- pat :: DatumType -> Text -> Text -> Stream Attrs
--- pat dt k t = stream k (liveEvalPat dt t)
+stream :: Text -> Stream a -> Stream (Attr a)
+stream k = fmap (Attr k)
 
-stream :: (IsDatum a) => Text -> Stream a -> Stream Attrs
-stream k = fmap (Map.singleton k . toDatum)
+-- pat :: IsDatum a => DatumTypeProxy a -> Text -> Text -> Stream (Attr a)
+-- pat dtp k t = stream k (liveEvalPat dt t)
 
 -- sound, s :: Text -> Stream Attrs
 -- sound = liveEvalSoundPat
@@ -37,6 +36,7 @@ stream k = fmap (Map.singleton k . toDatum)
 -- default note is c5, so we subtract 60 to get to note 0
 -- midinote :: Text -> Stream Attrs
 
+-- TODO check these are all float, not int
 -- Basic effect parameters
 accelerate
   , attack
@@ -68,7 +68,7 @@ accelerate
   , sustain
   , tremolodepth
   , tremolorate
-    :: (Real a) => Stream a -> Stream Attrs
+    :: (Real a) => Stream a -> Stream (Attr Float)
 accelerate = pF "accelerate"
 attack = pF "attack"
 bandf = pF "bandf"
@@ -120,7 +120,7 @@ accel
   , sz
   , tremdp
   , tremr
-    :: (Real a) => Stream a -> Stream Attrs
+    :: (Real a) => Stream a -> Stream (Attr Float)
 att = attack
 bpf = bandf
 bpq = bandq

minipat-dirt/src/Minipat/Dirt/Test.hs

@@ -6,7 +6,6 @@ import Control.Concurrent.MVar (withMVar)
 import Control.Exception (throwIO)
 import Dahdit.Midi.Osc (Datum (..))
 import Data.Foldable (for_)
-import Data.Map.Strict qualified as Map
 import Data.Ratio ((%))
 import Data.Sequence (Seq)
 import Minipat.Dirt.Core
@@ -20,7 +19,7 @@ import Minipat.Dirt.Core
   , setTempo
   , withSt
   )
-import Minipat.Dirt.Osc (Attrs, PlayEnv (..), PlayErr, Timed (..), convertTape, handshakePacket, playPacket)
+import Minipat.Dirt.Osc (Attrs, PlayEnv (..), PlayErr, Timed (..), attrs, convertTape, handshakePacket, playPacket)
 import Minipat.Stream (Ev (..), streamFastBy, tapeSingleton)
 import Minipat.Time (Arc (..), Span (..))
 import Nanotime (TimeLike (..), threadDelayDelta, timeDeltaFromFracSecs)
@@ -63,7 +62,7 @@ testPlay = do
           convertTape penv $
             tapeSingleton $
               Ev (Span (Arc 0 1) (Just (Arc 0 1))) $
-                Map.fromList
+                attrs
                   [ ("sound", DatumString "tabla")
                   , ("orbit", DatumInt32 0)
                   ]
@@ -76,7 +75,7 @@ testReal = do
   withSt $ \st -> do
     withMVar (stRes st) (sendHandshake . resConn)
     let m =
-          Map.fromList
+          attrs
             [ ("sound", DatumString "cpu")
             , ("orbit", DatumInt32 0)
             ]