Commit 5c340354 authored by Guerric Chupin's avatar Guerric Chupin

Rework on instruments.

parent bb152b14
......@@ -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)
......
{-# 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 ()
......@@ -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)
......
......@@ -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
......
......@@ -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 ->
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment