etc

BootDirt.hs

@@ -17,7 +17,7 @@ putStrLn "============================================================"
 
 dirtSt <- initialize
 
-instance LiveSt where { type LiveEnv = DirtEnv; type LiveData = DirtData; liveSt = dirtSt }
+instance LiveSt where { type LiveBackend = DirtBackend; liveSt = dirtSt }
 
 handshake
 

README.md

@@ -33,4 +33,5 @@ everything set up:
 * Implement polymeters
 * Additional combinators like `arp, off, jux, |+, every, squiz, range`
 * Backends for... Plain old MIDI? Renoise?
-
+* Backend with push/pull of textual patterns
+* More meaningful `Pretty` subclasses for pattern rep or plain old logging

minipat-dirt/minipat-dirt.cabal

@@ -62,11 +62,15 @@ library
       ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds
   build-depends:
-      base >=4.12 && <5
+      async
+    , base >=4.12 && <5
     , containers ==0.6.*
     , dahdit-midi >=0.5.5 && <0.6
     , dahdit-network >=0.5.2 && <0.6
+    , minipat
     , minipat-live ==0.1.*
     , nanotime >=0.3.2 && <0.4
     , network ==3.1.*
+    , stm
+    , text
   default-language: GHC2021

minipat-dirt/package.yaml

@@ -21,6 +21,10 @@ dependencies:
 - minipat-live >= 0.1 && < 0.2
 - nanotime >= 0.3.2 && < 0.4
 - network >= 3.1 && < 3.2
+- text
+- stm
+- minipat
+- async
 
 library:
   source-dirs: src

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

@@ -1,8 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Minipat.Dirt.Boot
-  ( D.DirtEnv
-  , D.DirtData
+  ( D.DirtBackend
+  , D.DirtSt
   , DirtLiveSt
   , initialize
   , handshake
@@ -15,13 +15,13 @@ import Minipat.Live.Boot
 import Minipat.Live.Core qualified as C
 import Minipat.Live.Logger qualified as L
 
-type DirtLiveSt = (LiveSt, LiveEnv ~ D.DirtEnv, LiveData ~ D.DirtData)
+type DirtLiveSt = (LiveSt, LiveBackend ~ D.DirtBackend)
 
 initialize :: IO D.DirtSt
 initialize = do
   logger <- L.newLogger
   L.logInfo logger "Initializing"
-  C.initAsyncSt logger D.dirtImpl (C.defaultEnv D.defaultDirtEnv)
+  C.initAsyncSt logger D.defaultDirtBackend C.defaultEnv
 
 handshake :: (DirtLiveSt) => IO ()
 handshake = D.handshake liveSt

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

@@ -2,77 +2,102 @@
 
 -- | Superdirt-specific implementation
 module Minipat.Dirt.Impl
-  ( DirtEnv (..)
-  , defaultDirtEnv
-  , DirtData
+  ( DirtBackend (..)
+  , defaultDirtBackend
   , DirtSt
-  , dirtImpl
   , handshake
   )
 where
 
+import Control.Concurrent.Async (Async)
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TQueue (TQueue, flushTQueue, newTQueueIO, writeTQueue)
 import Control.Exception (SomeException, bracket, throwIO)
+import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
 import Dahdit.Midi.Osc (Datum (..), Msg (..), Packet (..))
 import Dahdit.Midi.OscAddr (RawAddrPat)
 import Dahdit.Network (Conn (..), HostPort (..), resolveAddr, runDecoder, runEncoder, udpServerConn)
 import Data.Either (isRight)
-import Data.Foldable (foldl')
+import Data.Foldable (foldl', for_)
 import Data.Sequence (Seq (..))
+import Data.Text (Text)
 import Minipat.Live.Attrs (Attrs, attrsToList)
-import Minipat.Live.Core (Env (..), Impl (..), St (..), setPlaying, withData)
-import Minipat.Live.Logger (LogAction, logError, logInfo)
-import Minipat.Live.Resources (RelVar, Timed (..), relVarAcquire, withTimeout)
-import Nanotime (TimeDelta, timeDeltaFromFracSecs)
+import Minipat.Live.Core (Backend (..), Callback (..), St (..), setPlaying, useCallback)
+import Minipat.Live.Logger (logError, logInfo)
+import Minipat.Live.Play (PlayMeta (..), WithPlayMeta (..), attrsConvert)
+import Minipat.Live.Resources (acquireAwait, relVarAcquire, withTimeout)
+import Minipat.Time (Arc (..))
+import Nanotime (PosixTime, TimeDelta, timeDeltaFromFracSecs)
 import Network.Socket qualified as NS
 
-data DirtEnv = DirtEnv
-  { deTargetHp :: !HostPort
-  , deListenHp :: !HostPort
-  , deOscTimeout :: !TimeDelta
+data OscConn = OscConn
+  { ocTargetAddr :: !NS.SockAddr
+  , ocListenConn :: !(Conn NS.SockAddr)
+  }
+
+sendPacket :: OscConn -> Packet -> IO ()
+sendPacket (OscConn targetAddr (Conn _ enc)) = runEncoder enc targetAddr
+
+recvPacket :: TimeDelta -> OscConn -> IO (Either SomeException Packet)
+recvPacket timeout (OscConn _ (Conn dec _)) =
+  withTimeout timeout (runDecoder dec >>= either throwIO pure . snd)
+
+data DirtBackend = DirtBackend
+  { dbTargetHp :: !HostPort
+  , dbListenHp :: !HostPort
+  , dbOscTimeout :: !TimeDelta
   }
   deriving stock (Eq, Ord, Show)
 
-defaultDirtEnv :: DirtEnv
-defaultDirtEnv =
-  DirtEnv
-    { deTargetHp = HostPort (Just "127.0.0.1") 57120
-    , deListenHp = HostPort (Just "127.0.0.1") 57129
-    , deOscTimeout = timeDeltaFromFracSecs @Double 0.1
+defaultDirtBackend :: DirtBackend
+defaultDirtBackend =
+  DirtBackend
+    { dbTargetHp = HostPort (Just "127.0.0.1") 57120
+    , dbListenHp = HostPort (Just "127.0.0.1") 57129
+    , dbOscTimeout = timeDeltaFromFracSecs @Double 0.1
     }
 
-data OscConn = OscConn
-  { ocTargetAddr :: !NS.SockAddr
-  , ocListenConn :: !(Conn NS.SockAddr)
+type DirtSt = St DirtBackend
+
+data DirtData = DirtData
+  { ddOscConn :: !OscConn
+  , ddEventQueue :: !(TQueue (WithPlayMeta Attrs))
+  , ddSendTask :: !(Async ())
   }
 
-type DirtData = OscConn
+pwRealStart :: WithPlayMeta a -> PosixTime
+pwRealStart (WithPlayMeta pm _) = arcStart (pmRealArc pm)
 
-type DirtSt = St DirtEnv DirtData
+instance Backend DirtBackend where
+  type BackendData DirtBackend = DirtData
+  type BackendAttrs DirtBackend = Attrs
 
-dirtInit :: LogAction -> RelVar -> DirtEnv -> IO DirtData
-dirtInit _ rv (DirtEnv targetHp listenHp _) = do
-  targetAddr <- resolveAddr targetHp
-  relVarAcquire rv $ do
-    conn <- udpServerConn Nothing listenHp
-    pure (OscConn targetAddr conn)
+  backendInit (DirtBackend targetHp listenHp _) logger getPlayingSTM rv = do
+    targetAddr <- resolveAddr targetHp
+    let acqOscConn = fmap (OscConn targetAddr) (udpServerConn Nothing listenHp)
+    oscConn <- relVarAcquire rv acqOscConn
+    eventQueue <- liftIO newTQueueIO
+    let send pw = do
+          case attrsConvert dirtAliases pw of
+            Left err -> logError logger ("Failed to convert event: " <> err)
+            Right attrs -> sendPacket oscConn (playPacket attrs)
+        acqSendTask = acquireAwait pwRealStart getPlayingSTM eventQueue send
+    sendTask <- relVarAcquire rv acqSendTask
+    pure (DirtData oscConn eventQueue sendTask)
 
-dirtSend :: LogAction -> ((OscConn -> IO ()) -> IO ()) -> Timed Attrs -> IO ()
-dirtSend _ wd = sendPacket' wd . playPacket . timedVal
+  backendSend _ _ cb evs = runCallback cb (atomically . for_ evs . writeTQueue . ddEventQueue)
 
-dirtImpl :: Impl DirtEnv OscConn
-dirtImpl = Impl dirtInit dirtSend
+  backendClear _ _ cb = runCallback cb (atomically . void . flushTQueue . ddEventQueue)
 
-sendPacket' :: ((OscConn -> IO ()) -> IO ()) -> Packet -> IO ()
-sendPacket' wd packet = wd $ \(OscConn targetAddr (Conn _ enc)) ->
-  runEncoder enc targetAddr packet
+  -- TODO really check
+  backendCheck _ _ _ = pure True
 
-sendPacket :: DirtSt -> Packet -> IO ()
-sendPacket = sendPacket' . withData
+sendPacketSt :: DirtSt -> Packet -> IO ()
+sendPacketSt st p = useCallback st (\dd -> sendPacket (ddOscConn dd) p)
 
-recvPacket :: DirtSt -> IO (Either SomeException Packet)
-recvPacket st = withData st $ \(OscConn _ (Conn dec _)) ->
-  withTimeout (deOscTimeout (envImpl (stEnv st))) $
-    runDecoder dec >>= either throwIO pure . snd
+recvPacketSt :: DirtSt -> IO (Either SomeException Packet)
+recvPacketSt st = useCallback st (recvPacket (dbOscTimeout (stBackend st)) . ddOscConn)
 
 -- | Handshake with SuperDirt
 -- On success set playing true; on error false
@@ -82,8 +107,8 @@ handshake st = bracket acq rel (const (pure ()))
   logger = stLogger st
   acq = do
     logInfo logger "Handshaking ..."
-    sendPacket st handshakePacket
-    recvPacket st
+    sendPacketSt st handshakePacket
+    recvPacketSt st
   rel resp = do
     let ok = isRight resp
     if ok
@@ -107,3 +132,36 @@ handshakeAddr = "/dirt/handshake"
 
 handshakePacket :: Packet
 handshakePacket = PacketMsg (Msg handshakeAddr Empty)
+
+-- Useful params:
+-- sound - string, req - name of sound
+-- orbit - int, opt - index of orbit
+-- cps - float, given - current cps
+-- cycle - float, given - event start in cycle time
+-- delta - float, given - microsecond length of event
+-- TODO add more aliases for params
+dirtAliases :: [(Text, Text)]
+dirtAliases =
+  [ ("lpf", "cutoff")
+  , ("lpq", "resonance")
+  , ("hpf", "hcutoff")
+  , ("hpq", "hresonance")
+  , ("bpf", "bandf")
+  , ("bpq", "bandq")
+  , ("res", "resonance")
+  , ("midi", "midinote")
+  , ("n", "note")
+  , ("oct", "octave")
+  , ("accel", "accelerate")
+  , ("leg", "legato")
+  , ("delayt", "delaytime")
+  , ("delayfb", "delayfeedback")
+  , ("phasr", "phaserrate")
+  , ("phasdp", "phaserdepth")
+  , ("tremr", "tremolorate")
+  , ("tremdp", "tremolodepth")
+  , ("dist", "distort")
+  , ("o", "orbit")
+  , ("ts", "timescale")
+  , ("s", "sound")
+  ]

minipat-live/src/Minipat/Live/Attrs.hs

@@ -108,10 +108,10 @@ class (Semigroup q) => Squishy q a where
 squishMerge :: (Squishy q a, Squishy q b) => a -> b -> q
 squishMerge a b = squish a <> squish b
 
-instance (Semigroup q) => Squishy q q where
+instance {-# OVERLAPPABLE #-} (Semigroup q) => Squishy q q where
   squish = id
 
-instance (Monoid q, Squishy q a) => Squishy q (Maybe a) where
+instance {-# INCOHERENT #-} (Monoid q, Squishy q a) => Squishy q (Maybe a) where
   squish = maybe mempty squish
 
 instance (IsDatum a) => Squishy Attrs (Attr a) where

minipat-live/src/Minipat/Live/Boot.hs

@@ -2,14 +2,12 @@
 module Minipat.Live.Boot
   ( LiveSt (..)
   , dispose
-  , getDebug
   , getCps
   , getAhead
   , getPlaying
   , getStream
   , getCycle
   , getTempo
-  , setDebug
   , setCps
   , setPlaying
   , setCycle
@@ -39,25 +37,24 @@ where
 
 import Data.Kind (Type)
 import Minipat.EStream (EStream)
-import Minipat.Live.Attrs (Attrs, Squishy (..))
+import Minipat.Live.Attrs (Squishy (..))
 import Minipat.Live.Combinators
 import Minipat.Live.Core qualified as C
 import Minipat.Live.Params
+import Minipat.Live.Play (WithOrbit)
 import Minipat.Stream (Stream)
 import Nanotime (TimeDelta)
 import Prettyprinter (Pretty)
 
-class LiveSt where
-  type LiveEnv :: Type
-  type LiveData :: Type
-  liveSt :: C.St LiveEnv LiveData
+class (C.Backend LiveBackend) => LiveSt where
+  type LiveBackend :: Type
+  liveSt :: C.St LiveBackend
+
+type LiveAttrs = C.BackendAttrs LiveBackend
 
 dispose :: (LiveSt) => IO ()
 dispose = C.disposeSt liveSt
 
-getDebug :: (LiveSt) => IO Bool
-getDebug = C.getDebug liveSt
-
 getCps :: (LiveSt) => IO Rational
 getCps = C.getCps liveSt
 
@@ -67,7 +64,7 @@ getAhead = C.getAhead liveSt
 getPlaying :: (LiveSt) => IO Bool
 getPlaying = C.getPlaying liveSt
 
-getStream :: (LiveSt) => IO (Stream Attrs)
+getStream :: (LiveSt) => IO (Stream (WithOrbit LiveAttrs))
 getStream = C.getStream liveSt
 
 getCycle :: (LiveSt) => IO Integer
@@ -76,9 +73,6 @@ getCycle = C.getCycle liveSt
 getTempo :: (LiveSt) => IO Rational
 getTempo = C.getTempo liveSt
 
-setDebug :: (LiveSt) => Bool -> IO ()
-setDebug = C.setDebug liveSt
-
 setCps :: (LiveSt) => Rational -> IO ()
 setCps = C.setCps liveSt
 
@@ -91,7 +85,7 @@ setCycle = C.setCycle liveSt
 setTempo :: (LiveSt) => Rational -> IO ()
 setTempo = C.setTempo liveSt
 
-setOrbit :: (LiveSt, Squishy Attrs a) => Integer -> EStream a -> IO ()
+setOrbit :: (LiveSt, Squishy LiveAttrs a) => Integer -> EStream a -> IO ()
 setOrbit = C.setOrbit liveSt
 
 clearOrbit :: (LiveSt) => Integer -> IO ()
@@ -119,10 +113,10 @@ checkTasks = C.checkTasks liveSt
 peek :: (LiveSt, Pretty a) => EStream a -> IO ()
 peek = C.peek liveSt
 
-d :: (LiveSt, Squishy Attrs a) => Integer -> EStream a -> IO ()
+d :: (LiveSt, Squishy LiveAttrs a) => Integer -> EStream a -> IO ()
 d = setOrbit
 
-d0, d1, d2, d3, d4, d5, d6, d7 :: (LiveSt, Squishy Attrs a) => EStream a -> IO ()
+d0, d1, d2, d3, d4, d5, d6, d7 :: (LiveSt, Squishy LiveAttrs a) => EStream a -> IO ()
 d0 = d 0
 d1 = d 1
 d2 = d 2