From 5c34035400efff6c3c83ae75e66559d808335728 Mon Sep 17 00:00:00 2001
From: Guerric Chupin <guerric.chupin@gmail.com>
Date: Wed, 31 Aug 2016 17:57:16 +0100
Subject: [PATCH] Rework on instruments.
---
src/RMCA/Auxiliary.hs | 13 ++++-
src/RMCA/Configuration.hs | 96 ++++++++++++++++++++++---------------
src/RMCA/GUI/MultiBoard.hs | 27 +++++------
src/RMCA/Main.hs | 8 ++--
src/RMCA/Translator/Jack.hs | 14 +++++-
5 files changed, 99 insertions(+), 59 deletions(-)
diff --git a/src/RMCA/Auxiliary.hs b/src/RMCA/Auxiliary.hs
index 0d1e77c..250dc45 100644
--- a/src/RMCA/Auxiliary.hs
+++ b/src/RMCA/Auxiliary.hs
@@ -96,9 +96,20 @@ onChange' = proc x -> do
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
+-- | Integrates some variable modulo something.
+integralMod :: (Real a, VectorSpace a s) => a -> SF a a
+integralMod x = intMod' 0
+ where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
+ intMod'' x0 = proc t -> do
+ it <- (+ x0) ^<< integral -< t
+ es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it
+ returnA -< (it,es)
+
+
+
-- | Generates a sine function whose period is given as a varying input.
varFreqSine :: SF DTime Double
-varFreqSine = sin ^<< (2*pi*) ^<< integral <<^ (1/)
+varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
-- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
repeatedlyS :: a -> SF DTime (Event a)
diff --git a/src/RMCA/Configuration.hs b/src/RMCA/Configuration.hs
index eade689..67b70ae 100644
--- a/src/RMCA/Configuration.hs
+++ b/src/RMCA/Configuration.hs
@@ -1,30 +1,33 @@
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, PartialTypeSignatures,
+ ScopedTypeVariables #-}
module RMCA.Configuration where
+import Control.Arrow
import Control.Exception
import Data.Array
-import qualified Data.Bifunctor as BF
+import qualified Data.IntMap as M
+import Data.List
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
import RMCA.Auxiliary
import RMCA.GUI.Board
+import RMCA.GUI.MultiBoard
import RMCA.Layer.Layer
import RMCA.Semantics
import Text.Read
type InstrumentNo = Int
-data BoardConf = BoardConf { confLayer :: (Layer,InstrumentNo)
- , confBoard :: BoardInit
- , confTempo :: Tempo
+data BoardConf = BoardConf { confLayers :: [(BoardInit,Layer,InstrumentNo)]
+ , confTempo :: Tempo
} deriving(Read,Show)
newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
mkInit :: Board -> BoardInit
-mkInit = BoardInit . filter (uncurry (&&) . BF.bimap onBoard notDef) . assocs
+mkInit = BoardInit . filter (uncurry (&&) . (onBoard *** notDef)) . assocs
where notDef (Inert,1) = False
notDef _ = True
@@ -32,43 +35,54 @@ boardInit :: BoardInit -> Board
boardInit = makeBoard . toList
saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
- , ReactiveValueRead layer Layer IO
- , ReactiveValueRead board Board IO
- , ReactiveValueRead instr InstrumentNo IO) =>
+ , ReactiveValueRead layer (M.IntMap Layer) IO
+ , ReactiveValueRead board (M.IntMap Board) IO
+ , ReactiveValueRead instr (M.IntMap InstrumentNo) IO) =>
FilePath -> tempo -> layer -> board -> instr -> IO ()
saveConfiguration fp t l b i = do
- tempo <- reactiveValueRead t
- layer <- reactiveValueRead l
- board <- reactiveValueRead b
- instr <- reactiveValueRead i
- let bc = BoardConf { confLayer = (layer,instr)
+ tempo <- reactiveValueRead t
+ layers <- M.elems <$> reactiveValueRead l
+ boards <- map mkInit <$> M.elems <$> reactiveValueRead b
+ instrs <- M.elems <$> reactiveValueRead i
+ let bc = BoardConf { confLayers = zip3 boards layers instrs
, confTempo = tempo
- , confBoard = mkInit board
}
catch (writeFile fp $ show bc) (\(_ :: IOError) -> errorSave)
+-- Current solution to delete all existing layers is to write to the
+-- rm button, which is not that nice.
loadConfiguration :: ( ReactiveValueWrite tempo Tempo IO
- , ReactiveValueWrite layer Layer IO
+ , ReactiveValueWrite layer (M.IntMap Layer) IO
, ReactiveValueWrite cell GUICell IO
- , ReactiveValueWrite instr InstrumentNo IO) =>
+ , ReactiveValueWrite instr (M.IntMap InstrumentNo) IO
+ , ReactiveValueWrite addLayer () IO
+ , ReactiveValueWrite rmLayer () IO
+ , ReactiveValueRead boards (M.IntMap (Array Pos cell)) IO) =>
FilePath -> tempo -> layer
- -> Array Pos cell -> instr -> IO ()
-loadConfiguration fp t l arr i = do
+ -> boards -> instr -> addLayer -> rmLayer -> IO ()
+loadConfiguration fp t l arrs i addLayer rmLayer = do
conf <- readMaybe <$> readFile fp
if isNothing conf then errorLoad else
- do let BoardConf { confLayer = (layer,instr)
+ do let BoardConf { confLayers = cl
, confTempo = tempo
- , confBoard = (BoardInit board)
} = fromJust conf
+ (boards,layers,instrs) = unzip3 cl
+ layNum = length cl
+ sequence_ $ replicate maxLayers $ reactiveValueWrite rmLayer ()
+ sequence_ $ replicate layNum $ reactiveValueWrite addLayer ()
reactiveValueWrite t tempo
- reactiveValueWrite l layer
- mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
- (\(_ :: ErrorCall) -> return ())) $ elems arr
- mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! toGUICoords p) $
- inertCell { cellAction = a
- , repeatCount = r
- }) board
- reactiveValueWrite i instr
+ reactiveValueWrite l $ M.fromList $ zip [1..] layers
+ reactiveValueWrite i $ M.fromList $ zip [1..] instrs
+ cellArrs <- reactiveValueRead arrs
+ mapM_ (\(arr,board) ->
+ do mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
+ (\(_ :: ErrorCall) -> return ())) $ elems arr
+ mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! toGUICoords p) $
+ inertCell { cellAction = a
+ , repeatCount = r
+ }) board
+ ) $ M.intersectionWith (,) cellArrs
+ $ M.fromList $ zip [1..] $ map (\(BoardInit b) -> b) boards
errorLoad :: IO ()
errorLoad = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
@@ -78,16 +92,20 @@ errorSave :: IO ()
errorSave = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
"Error saving the configuration file!" >>= widgetShow
-handleSaveLoad :: ( ReactiveValueRead save () IO
+handleSaveLoad :: ( ReactiveValueReadWrite tempo Tempo IO
+ , ReactiveValueReadWrite layer (M.IntMap Layer) IO
+ , ReactiveValueWrite cell GUICell IO
+ , ReactiveValueReadWrite instr (M.IntMap InstrumentNo) IO
+ , ReactiveValueWrite addLayer () IO
+ , ReactiveValueWrite rmLayer () IO
+ , ReactiveValueRead boards (M.IntMap (Array Pos cell)) IO
, ReactiveValueRead load () IO
- , ReactiveValueReadWrite instr InstrumentNo IO
- , ReactiveValueReadWrite layer Layer IO
- , ReactiveValueRead board Board IO
- , ReactiveValueReadWrite tempo Tempo IO
- , ReactiveValueWrite cell GUICell IO) =>
+ , ReactiveValueRead save () IO
+ , ReactiveValueRead board (M.IntMap Board) IO) =>
tempo -> board -> layer -> instr
- -> Array Pos cell -> save -> load -> IO ()
-handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV = do
+ -> boards -> addLayer -> rmLayer -> save -> load -> IO ()
+--handleSaveLoad :: _
+handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV addLayerRV rmLayerRV confSaveRV confLoadRV = do
fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
reactFilt <- fileFilterNew
@@ -113,8 +131,10 @@ handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
widgetShowAll fcl
let respHandle ResponseOk =
fileChooserGetFilename fcl >>= fromMaybeM_ .
- fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
+ fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV
+ addLayerRV rmLayerRV )
respHandle _ = return ()
onResponse fcl (\r -> respHandle r >> widgetHide fcl)
+
return ()
diff --git a/src/RMCA/GUI/MultiBoard.hs b/src/RMCA/GUI/MultiBoard.hs
index 7fc455b..e7c26cf 100644
--- a/src/RMCA/GUI/MultiBoard.hs
+++ b/src/RMCA/GUI/MultiBoard.hs
@@ -21,6 +21,9 @@ import RMCA.Layer.Layer
import RMCA.MCBMVar
import RMCA.Semantics
+maxLayers :: Int
+maxLayers = 16
+
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
) =>
@@ -28,6 +31,7 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
-> addLayer
-> rmLayer
-> MCBMVar Layer
+ -> MCBMVar InstrumentNo
-> MCBMVar GUICell
-> IO ( Notebook
, ReactiveFieldRead IO (M.IntMap Board)
@@ -35,7 +39,7 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveFieldRead IO
(M.IntMap (ReactiveFieldWrite IO [PlayHead]))
)
-createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
+createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar = do
n <- notebookNew
let curPageRV = ReactiveFieldReadWrite setter getter notifier
where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
@@ -103,7 +107,7 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
- fstP <- notebookAppendPage n boardCont "Lol first"
+ fstP <- notebookAppendPage n boardCont ""
notebookPageNumber <- newCBMVarRW (1 :: Int)
initBoardRV tc guiBoard >>=
@@ -120,9 +124,12 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
reactiveValueWrite layerMapRV . M.insert cp nLayer
layerHidMVar <- newEmptyMVar
+ instrHidMVar <- newEmptyMVar
installCallbackMCBMVar layerMCBMVar
(reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
+ installCallbackMCBMVar instrMCBMVar
+ (reactiveValueRead curChanRV >>= updateInstr) >>= putMVar instrHidMVar
------------------------------------------------------------------------------
-- Following boards
@@ -130,7 +137,7 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
np <- reactiveValueRead notebookPageNumber
- unless (np >= 16) $ do
+ unless (np >= maxLayers) $ do
reactiveValueWrite notebookPageNumber (np + 1)
nBoardCont <- backgroundContainerNew
@@ -183,6 +190,7 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
cp <- reactiveValueRead curChanRV
when (cp >= 0) $ do
takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
+ takeMVar instrHidMVar >>= removeCallbackMCBMVar instrMCBMVar
layerMap <- reactiveValueRead layerMapRV
let mSelLayer = M.lookup cp layerMap
when (isNothing mSelLayer) $ error "Not found selected layer!"
@@ -205,18 +213,7 @@ createNotebook tc addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
------------------------------------------------------------------------------
-- Flatten maps
------------------------------------------------------------------------------
- let {-phMapRV :: ReactiveFieldWrite IO (M.IntMap [PlayHead])
- phMapRV = ReactiveFieldWrite setter
- where setter phM = sequence_ $ M.mapWithKey writePhs phM
- writePhs :: Int -> [PlayHead] -> IO ()
- writePhs k phs = do chanMap <- reactiveValueRead chanMapRV
- let mselChan = M.lookup k chanMap
- when (isNothing mselChan) $
- error "Can't find layer!"
- let (_,_,phsRV) = fromJust mselChan
- reactiveValueWrite phsRV phs
--}
- phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
+ let phMapRV :: ReactiveFieldRead IO (M.IntMap (ReactiveFieldWrite IO [PlayHead]))
phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs
index b55022f..0375b48 100644
--- a/src/RMCA/Main.hs
+++ b/src/RMCA/Main.hs
@@ -60,12 +60,12 @@ main = do
(noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
tc <- newTickableClock
- (boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook tc
- addLayerRV rmLayerRV
- layerMCBMVar guiCellMCBMVar
+ (boardCont, boardMapRV, layerMapRV, instrMapRV, phRVMapRV) <-
+ createNotebook tc addLayerRV rmLayerRV layerMCBMVar instrMCBMVar guiCellMCBMVar
boxPackStart mainBox boardCont PackNatural 0
- --handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
+ handleSaveLoad tempoRV boardMapRV layerMapRV instrMapRV phRVMapRV
+ addLayerRV rmLayerRV confSaveRV confLoadRV
boardRunRV <- newCBMVarRW BoardStop
reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
diff --git a/src/RMCA/Translator/Jack.hs b/src/RMCA/Translator/Jack.hs
index 858aa7c..76f9de7 100644
--- a/src/RMCA/Translator/Jack.hs
+++ b/src/RMCA/Translator/Jack.hs
@@ -13,6 +13,7 @@ import Data.Foldable
import qualified Data.IntMap as M
import Data.ReactiveValue
import qualified Foreign.C.Error as E
+import Graphics.UI.Gtk
import RMCA.Auxiliary
import RMCA.Global.Clock
import RMCA.Semantics
@@ -20,6 +21,7 @@ import RMCA.Translator.Message
import RMCA.Translator.RV
import RMCA.Translator.Translator
import qualified Sound.JACK as Jack
+import qualified Sound.JACK.Exception as JackExc
import qualified Sound.JACK.MIDI as JMIDI
rmcaName :: String
@@ -31,6 +33,16 @@ inPortName = "input"
outPortName :: String
outPortName = "output"
+handleErrorJack :: JackExc.All -> IO ()
+handleErrorJack _ = postGUIAsync $ do
+ diag <- messageDialogNewWithMarkup
+ Nothing [] MessageError ButtonsClose
+ "No running instance of Jack could be found!"
+ widgetShow diag
+ resp <- dialogRun diag
+ print resp
+ mainQuit
+
-- Starts a default client with an input and an output port. Doesn't
-- do anything as such.
jackSetup :: (ReactiveValueReadWrite board
@@ -40,7 +52,7 @@ jackSetup :: (ReactiveValueReadWrite board
-> board
-> tempo
-> IO ()
-jackSetup tc boardQueue tempoRV = Jack.handleExceptions $ do
+jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
toProcessRV <- Trans.lift $ newCBMVarRW []
Jack.withClientDefault rmcaName $ \client ->
Jack.withPort client outPortName $ \output ->
--
2.47.2