etc

justfile

@@ -48,5 +48,5 @@ lint-apply:
 # Run a dirt session in ghci
 backend target:
   just build minipat-{{ target }}
-  bin/minipat-repl {{ target }}
+  bin/minipat {{ target }}
 

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

@@ -3,6 +3,7 @@
 -- provide full functionality.
 module Minipat.Live.Boot
   ( LiveSt (..)
+  , readLiveSt
   , allocate
   , initialize
   , reallocate

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

@@ -1,32 +1,33 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-{-|
- - We define an RPC-over-OSC protocol (like the one in SuperDirt):
- -
- - * Messages can be one-shot or request-response
- - * Replies should be send to the original OSC address with the
- -  additional suffix `/reply`
- -    * Example: `/dirt/handshake` to `/dirt/handshake/reply`
- - * Messages contain lists of key-value pairs (string datum, then
- -  any kind of datum, repeating).
- - * Attribute names starting with `!` are system level attributes and
- -  should be removed before further processing.
- -    * `!requestId` is one such attribute that should be carried
- -      over into a responses.
-   - * Errors can be signaled by the attribute `!error` mapping to a string.
- - * Type checking of requests and responses should be lenient -
- -  it's OK to have unrecognized attributes.
- -  datum containing a reason.
- - * Responses should carry the corresponding `!requestId`, but if they
- -  do not, they should be associated with the last request to the original
- -  address.
- -    * Clients may enforce that reply addresses are also correct.
- -    * `!requestId` values should be distinct.
- - * It is expected that requests or replies may be lost or reordered, so
- -  plan accordingly.
- -}
+-- |
+--  - We define an RPC-over-OSC protocol (like the one in SuperDirt):
+--  -
+--  - * Messages can be one-shot or request-response
+--  - * Replies should be send to the original OSC address with the
+--  -  additional suffix `/reply`
+--  -    * Example: `/dirt/handshake` to `/dirt/handshake/reply`
+--  - * Messages contain lists of key-value pairs (string datum, then
+--  -  any kind of datum, repeating).
+--  - * Attribute names starting with `!` are system level attributes and
+--  -  should be removed before further processing.
+--  -    * `!requestId` is one such attribute that should be carried
+--  -      over into a responses.
+--    - * Errors can be signaled by the attribute `!error` mapping to a string.
+--  - * Type checking of requests and responses should be lenient -
+--  -  it's OK to have unrecognized attributes.
+--  -  datum containing a reason.
+--  - * Responses should carry the corresponding `!requestId`, but if they
+--  -  do not, they should be associated with the last request to the original
+--  -  address.
+--  -    * Clients may enforce that reply addresses are also correct.
+--  -    * `!requestId` values should be distinct.
+--  - * It is expected that requests or replies may be lost or reordered, so
+--  -  plan accordingly.
 module Minipat.Live.OscRpc where
 
+import Control.Concurrent.STM.TMVar (TMVar)
+import Control.Concurrent.STM.TVar (TVar, newTVarIO)
 import Control.Exception (Exception)
 import Dahdit.Midi.Osc (Datum (..), DatumType (..), Msg (..))
 import Dahdit.Midi.OscAddr (RawAddrPat)
@@ -42,8 +43,6 @@ import Minipat.Live.Attrs (Attrs, IsAttrs (..), attrsSingleton, attrsToList)
 import Minipat.Live.Convert (ConvErr, ConvM, runConvM)
 import Minipat.Live.EnumString (EnumString, allEnumStrings)
 import Nanotime (PosixTime, TimeDelta)
-import Control.Concurrent.STM.TVar (TVar, newTVarIO)
-import Control.Concurrent.STM.TMVar (TMVar)
 
 -- * General classes and data types
 
@@ -91,16 +90,16 @@ instance IsAttrs RemoteErr where
   toAttrs (RemoteErr x) = attrsSingleton "!error" (DatumString x)
 
 data RpcErr
-  = RpcErrRemote !RemoteErr
-  -- ^ Remote side signaled an error
-  | RpcErrConv !ConvErr
-  -- ^ Response parsing failed
-  | RpcErrUnmatchedRep !RequestId !RawAddrPat
-  -- ^ No match for reply with id and address
-  | RpcErrAddrMismatch !RequestId !RawAddrPat !RawAddrPat
-  -- ^ Mismatch of reply (args: rid, actual, expected)
-  | RpcErrTimeoutRep !RequestId !RawAddrPat !PosixTime
-  -- ^ Timeout waiting for reply
+  = -- | Remote side signaled an error
+    RpcErrRemote !RemoteErr
+  | -- | Response parsing failed
+    RpcErrConv !ConvErr
+  | -- | No match for reply with id and address
+    RpcErrUnmatchedRep !RequestId !RawAddrPat
+  | -- | Mismatch of reply (args: rid, actual, expected)
+    RpcErrAddrMismatch !RequestId !RawAddrPat !RawAddrPat
+  | -- | Timeout waiting for reply
+    RpcErrTimeoutRep !RequestId !RawAddrPat !PosixTime
   deriving stock (Eq, Ord, Show)
 
 instance Exception RpcErr
@@ -170,4 +169,3 @@ newOscProtoEnvIO to rid = OscProtoEnv to <$> newTVarIO rid <*> newTVarIO Empty
 --
 -- sendMsg :: OscTaskEnv c a -> c r -> IO (WaitVar r)
 -- sendMsg = undefined
-

minipat-live/src/Minipat/Live/OscRpc/Dirt.hs

@@ -6,9 +6,9 @@ module Minipat.Live.OscRpc.Dirt where
 import Dahdit.Midi.OscAddr (RawAddrPat (..))
 import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
+import Minipat.Live.Attrs (Attrs)
 import Minipat.Live.EnumString (EnumString (..), deriveEnumString)
 import Minipat.Live.OscRpc (RpcCmd (..), RpcType (..))
-import Minipat.Live.Attrs (Attrs)
 
 -- * Dirt impl
 

minipat-live/src/Minipat/Live/OscRpc/Renoise.hs

@@ -50,13 +50,15 @@ instance RpcType ReType where
     ReTypeHandshake -> Just Map.empty
     ReTypeShow -> Nothing
     ReTypeNumTracks ->
-      Just $ Map.fromList
-        [ ("numTracks", (RequiredYes, AttrTypeDatum DatumTypeInt32))
-        ]
+      Just $
+        Map.fromList
+          [ ("numTracks", (RequiredYes, AttrTypeDatum DatumTypeInt32))
+          ]
     ReTypeTrackType ->
-      Just $ Map.fromList
-        [ ("trackType", (RequiredYes, atEnum (Proxy @TrackType)))
-        ]
+      Just $
+        Map.fromList
+          [ ("trackType", (RequiredYes, atEnum (Proxy @TrackType)))
+          ]
     ReTypeTrackOp -> Just Map.empty
 
 data ReCmd r where

minipat-midi/Repl.ghci

@@ -14,6 +14,7 @@ putStrLn "Show documentation with `:doc someFunctionName`"
 putStrLn "============================================================"
 
 import Minipat.Midi.Boot
+import Minipat.Midi.SC qualified as SC
 stRef <- allocate @MidiBackend
 instance LiveSt where { type LiveBackend = MidiBackend; liveStRef = stRef }
 initialize

minipat-midi/minipat-midi.cabal

@@ -27,6 +27,7 @@ library
       Minipat.Midi.Boot
       Minipat.Midi.Convert
       Minipat.Midi.Impl
+      Minipat.Midi.SC
   other-modules:
       Paths_minipat_midi
   hs-source-dirs:

minipat-midi/src/Minipat/Midi/Boot.hs

@@ -8,10 +8,13 @@ module Minipat.Midi.Boot
   , Vel
   , vel
   , v
+  , midi
   , module Minipat.Live.Boot
   )
 where
 
+import Dahdit.Midi.Midi (ShortMsg)
+import Data.Sequence (Seq)
 import Data.Text (Text)
 import Minipat.Live.Boot
 import Minipat.Live.Datum (DatumProxy (..))
@@ -31,3 +34,6 @@ midinote = parseMidiNote
 vel, v :: Text -> S Vel
 vel = fmap Vel . parseDatum DatumProxyInt32
 v = vel
+
+midi :: (MidiLiveSt) => Seq ShortMsg -> IO ()
+midi ms = readLiveSt >>= \st -> I.sendMsgs st ms

minipat-midi/src/Minipat/Midi/Convert.hs

@@ -37,6 +37,6 @@ rootM =
       ( "note"
       , Branch DatumProxyInt32 $ \(fromIntegral -> note) -> do
           vel <- defaultM "vel" DatumProxyInt32 defVel <&> fromIntegral
-          pure (ChanDataVoice (ChanVoiceDataNoteOn note vel))
+          pure (ChanDataVoice (ChanVoiceDataNoteOn (note + 60) vel))
       )
     ]

minipat-midi/src/Minipat/Midi/Impl.hs

@@ -4,6 +4,7 @@
 module Minipat.Midi.Impl
   ( MidiBackend (..)
   , MidiSt
+  , sendMsgs
   )
 where
 
@@ -16,7 +17,7 @@ import Dahdit.Iface (mutEncode)
 import Dahdit.Midi.Midi (ChanData (..), ChanVoiceData (..), Channel, ShortMsg (..))
 import Data.Acquire (mkAcquire)
 import Data.Default (Default (..))
-import Data.Foldable (foldl')
+import Data.Foldable (foldl', traverse_)
 import Data.Heap (Heap)
 import Data.Heap qualified as H
 import Data.Maybe (fromMaybe)
@@ -25,7 +26,7 @@ import Data.Sequence qualified as Seq
 import Data.Text qualified as T
 import Data.Vector.Storable.Mutable qualified as VSM
 import Minipat.Live.Backend (Backend (..), Callback (..), PlayMeta (..), WithPlayMeta (..))
-import Minipat.Live.Core (St, logAsyncState)
+import Minipat.Live.Core (St, logAsyncState, useCallback)
 import Minipat.Live.Logger (logInfo)
 import Minipat.Live.Resources (acquireAwait, qhHeap)
 import Minipat.Midi.Convert (convertMidiAttrs)
@@ -34,6 +35,7 @@ import Nanotime (PosixTime)
 import Sound.RtMidi (OutputDevice)
 import Sound.RtMidi qualified as R
 
+-- TODO add max msg length
 newtype MidiBackend = MidiBackend
   { mbPortSel :: String -> Bool
   }
@@ -88,7 +90,7 @@ mkNoteOff c = \case
 mkTimedMsgs :: WithPlayMeta ChanData -> Seq TimedMsg
 mkTimedMsgs (WithPlayMeta pm cd) =
   let Arc t1 t2 = pmRealArc pm
-      c = fromInteger (pmOrbit pm)
+      c = fromInteger (pmOrbit pm - 1)
       m1 = ShortMsgChan c cd
       s1 = Seq.singleton (TimedMsg t1 (SortedMsg m1))
   in  case mkNoteOff c cd of
@@ -101,6 +103,17 @@ data MidiData = MidiData
   , mdSendTask :: !(Async ())
   }
 
+sendShortMsgs :: (Foldable f) => f ShortMsg -> OutputDevice -> IO ()
+sendShortMsgs ms device = do
+  buf <- liftIO (VSM.new 4)
+  let send m = do
+        len <- fmap fromIntegral (mutEncode m buf)
+        VSM.unsafeWith buf (\ptr -> R.sendUnsafeMessage device ptr len)
+  traverse_ send ms
+
+sendMsgs :: (Foldable f) => St MidiBackend -> f ShortMsg -> IO ()
+sendMsgs st ms = useCallback st (sendShortMsgs ms . mdDevice)
+
 instance Backend MidiBackend where
   type BackendData MidiBackend = MidiData
 

minipat-midi/src/Minipat/Midi/SC.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedLists #-}
+
+-- | Midi message makers for SC-88 and the like
+module Minipat.Midi.SC where
+
+import Dahdit.Midi.Midi (ChanData (..), ChanVoiceData (..), ShortMsg (..))
+import Data.Sequence (Seq)
+import Data.Sequence qualified as Seq
+
+setControl :: Int -> Int -> Int -> Seq ShortMsg
+setControl part control value =
+  Seq.singleton
+    ( ShortMsgChan
+        (fromIntegral part)
+        ( ChanDataVoice
+            ( ChanVoiceControlChange
+                (fromIntegral control)
+                (fromIntegral value)
+            )
+        )
+    )
+
+setProgram :: Int -> Int -> Seq ShortMsg
+setProgram part program =
+  Seq.singleton
+    ( ShortMsgChan
+        (fromIntegral part)
+        ( ChanDataVoice
+            ( ChanVoiceProgramChange
+                (fromIntegral program)
+            )
+        )
+    )
+
+setSound :: Int -> Int -> Int -> Seq ShortMsg
+setSound part inst var =
+  mconcat
+    [ setControl part 0 (var * 8)
+    , setControl part 32 0
+    , setProgram part inst
+    ]
+
+setLevel :: Int -> Int -> Seq ShortMsg
+setLevel = flip setControl 7
+
+setPan :: Int -> Int -> Seq ShortMsg
+setPan = flip setControl 10
+
+setReverb :: Int -> Int -> Seq ShortMsg
+setReverb = flip setControl 91
+
+setChorus :: Int -> Int -> Seq ShortMsg
+setChorus = flip setControl 93
+
+allSoundsOff :: Int -> Seq ShortMsg
+allSoundsOff part = setControl part 120 0
+
+-- Turn of non-sustained notes
+allNotesOff :: Int -> Seq ShortMsg
+allNotesOff part = setControl part 123 0
+
+reinit :: Int -> Seq ShortMsg
+reinit part =
+  mconcat
+    [ setSound part 0 0
+    , setLevel part 100
+    , setPan part 64
+    , setReverb part 40
+    , setChorus part 0
+    ]