Commit d0e5fb29 authored by Guerric Chupin's avatar Guerric Chupin

Multiple layer internals done. Translator not finished.

parent de3a2400
......@@ -13,6 +13,9 @@ import FRP.Yampa
-- General functions
--------------------------------------------------------------------------------
($>) :: (Functor f) => f a -> b -> f b
($>) = flip (<$)
bound :: (Ord a) => (a, a) -> a -> a
bound (min, max) x
| x < min = min
......
{-# LANGUAGE OverloadedStrings #-}
module RMCA.GUI.Buttons where
module RMCA.GUI.Buttons ( buttonNewFromStockWithLabel
, toggleButtonNewFromStock
, getButtons
) where
import Data.ReactiveValue
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.GUI.StockId
packButton :: (BoxClass a, ButtonClass b, ImageClass i, LabelClass l) =>
b -> a -> l -> i -> IO b
packButton button buttonBox buttonLabel buttonImg = do
containerAdd button buttonBox
boxPackStart buttonBox buttonImg PackRepel 0
boxPackStart buttonBox buttonLabel PackRepel 0
return button
buttonNewFromStockWithLabel :: StockId -> String -> IO Button
buttonNewFromStockWithLabel s l = do
button <- buttonNew
......@@ -14,10 +25,7 @@ buttonNewFromStockWithLabel s l = do
buttonImg <- imageNewFromStock s IconSizeButton
buttonLabel <- labelNew (Just l)
labelSetUseUnderline buttonLabel True
containerAdd button buttonBox
boxPackStart buttonBox buttonImg PackRepel 0
boxPackStart buttonBox buttonLabel PackRepel 0
return button
packButton button buttonBox buttonLabel buttonImg
toggleButtonNewFromStock :: StockId -> IO ToggleButton
toggleButtonNewFromStock s = do
......@@ -27,10 +35,7 @@ toggleButtonNewFromStock s = do
stockTxt <- stockLookupItem s
buttonLabel <- labelNew (siLabel <$> stockTxt)
labelSetUseUnderline buttonLabel True
containerAdd button buttonBox
boxPackStart buttonBox buttonImg PackRepel 0
boxPackStart buttonBox buttonLabel PackRepel 0
return button
packButton button buttonBox buttonLabel buttonImg
getButtons :: IO ( VBox
, ReactiveFieldRead IO ()
......
......@@ -6,8 +6,8 @@ import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
import qualified Data.IntMap as M
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
......@@ -21,9 +21,6 @@ import RMCA.Layer.Layer
import RMCA.MCBMVar
import RMCA.Semantics
-- In GTk, a “thing with tabs” has the, I think, very confusing name
-- Notebook.
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
) =>
......@@ -32,12 +29,10 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
-> MCBMVar Layer
-> MCBMVar GUICell
-> IO ( Notebook
, ReactiveFieldReadWrite IO
(M.Map Int ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldWrite IO [PlayHead]
))
, ReactiveFieldReadWrite IO Int
, ReactiveFieldRead IO (M.IntMap Board)
, ReactiveFieldReadWrite IO (M.IntMap Layer)
, ReactiveFieldRead IO
(M.IntMap (ReactiveFieldWrite IO [PlayHead]))
)
createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
n <- notebookNew
......@@ -51,7 +46,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
pageChanRV <- newCBMVarRW []
let foundHole = let foundHole' [] = 0
foundHole' (x:[]) = x + 1
foundHole' [x] = x + 1
foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
in foundHole' . sort
......@@ -86,8 +81,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
when (button == LeftButton && isJust nmp) $ do
let nCell = snd $ fromJust nmp
mOHid <- tryTakeMVar guiCellHidMVar
when (isJust mOHid) $
removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
reactiveValueWrite guiCellMCBMVar nCell
nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
cp <- reactiveValueRead curChanRV
......@@ -207,6 +201,27 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
reactiveValueWrite guiCellMCBMVar inertCell
------------------------------------------------------------------------------
-- For good measure
-- Flatten maps
------------------------------------------------------------------------------
return (n, chanMapRV, curPageRV)
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]))
phMapRV = liftR (M.map (\(_,_,b) -> b)) chanMapRV
boardMapRV :: ReactiveFieldRead IO (M.IntMap Board)
boardMapRV = ReactiveFieldRead getter notifier
where notifier = reactiveValueOnCanRead chanMapRV
getter = do
chanMap <- reactiveValueRead chanMapRV
sequence (M.map (reactiveValueRead . \(b,_,_) -> b) chanMap)
return (n, boardMapRV, layerMapRV, phMapRV)
......@@ -197,10 +197,10 @@ noteSettingsBox = do
reactiveValueOnCanRead setRV $ do
nCell <- reactiveValueRead setRV
fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV <$> naArt <$> getNAttr (cellAction nCell))
fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV <$> ornSlide <$> naOrn <$> getNAttr (cellAction nCell))
fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$> getNAttr (cellAction nCell))
fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nCell))
reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV <$> naDur <$> getNAttr (cellAction nCell))
fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$> getNAttr (cellAction nCell))
updateNaBox nCell
{-
......
{-# LANGUAGE Arrows #-}
module RMCA.Layer.Board where
module RMCA.Layer.Board ( boardRun
, BoardRun (..)
) where
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Layer.Layer
import RMCA.Semantics
import qualified Data.IntMap as M
import Data.List ((\\))
import FRP.Yampa
import RMCA.Auxiliary
import RMCA.Layer.Layer
import RMCA.Semantics
data BoardRun = BoardStart | BoardStop deriving Eq
......@@ -29,3 +33,35 @@ boardSwitch :: [PlayHead]
boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
where fnSwitch (BoardStart, iPh) = boardSwitch iPh
fnSwitch (BoardStop, _) = boardSwitch []
routeBoard :: M.IntMap a -> M.IntMap sf -> M.IntMap (a,sf)
routeBoard = M.intersectionWith (,)
-- On the left are the disappearing signals, on the right the
-- appearing one.
lengthChange :: M.IntMap b -> SF (M.IntMap a, M.IntMap sf) (Event ([Int],[Int]))
lengthChange iSig = proc (mapSig, _) -> do
kSig <- arr M.keys -< mapSig
--kSF <- arr M.keys -< mapSF
edgeBy diffSig ik -< kSig
where ik = M.keys iSig
-- Old elements removed in nL are on the left, new elements added to
-- nL are on the right.
diffSig :: [Int] -> [Int] -> Maybe ([Int],[Int])
diffSig oL nL
| oL == nL = Nothing
| otherwise = Just (oL \\ nL, nL \\ oL)
boardRun' :: M.IntMap (SF (Board,Layer,Tempo,BoardRun)
(Event ([PlayHead],[Note])))
-> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
(M.IntMap (Event ([PlayHead],[Note])))
boardRun' iSF = pSwitch routeBoard iSF (lengthChange iSF) contSwitch
where contSwitch contSig (newSig, oldSig) = boardRun' newSF
where newSF = foldr (\k m -> M.insert k boardSF m)
(foldr M.delete contSig oldSig) newSig
boardRun :: M.IntMap (Board,Layer,Tempo,BoardRun)
-> SF (M.IntMap (Board,Layer,Tempo,BoardRun))
(M.IntMap (Event ([PlayHead],[Note])))
boardRun iSig = boardRun' (iSig $> boardSF)
......@@ -2,23 +2,27 @@
module Main where
import Control.Concurrent
import Data.ReactiveValue
import FRP.Yampa
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary
import RMCA.Configuration
import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.LayerSettings
import RMCA.GUI.MainSettings
import RMCA.GUI.MultiBoard
import RMCA.GUI.NoteSettings
import RMCA.Layer.Board
import RMCA.Translator.Jack
import Control.Concurrent
import qualified Data.IntMap as M
import Data.ReactiveValue
import FRP.Yampa
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary
import RMCA.Auxiliary
import RMCA.Configuration
import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.LayerSettings
import RMCA.GUI.MainSettings
import RMCA.GUI.MultiBoard
import RMCA.GUI.NoteSettings
import RMCA.Layer.Board
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Jack
main :: IO ()
main = do
......@@ -42,10 +46,10 @@ main = do
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 0
( buttonBox
, playRV, stopRV, pauseRV, recordRV
, confSaveRV, confLoadRV
, addLayerRV, rmLayerRV ) <- getButtons
(buttonBox,
playRV,stopRV,pauseRV,recordRV,
confSaveRV,confLoadRV,
addLayerRV,rmLayerRV) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
boardQueue <- newCBMVarRW mempty
......@@ -55,34 +59,52 @@ main = do
boxPackStart settingsBox laySep PackNatural 0
(noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
(boardCont, chanMapRV, _{-curPageRV-}) <- createNotebook addLayerRV rmLayerRV
layerMCBMVar guiCellMCBMVar
(boardCont, boardMapRV, layerMapRV, phRVMapRV) <- createNotebook
addLayerRV rmLayerRV
layerMCBMVar guiCellMCBMVar
boxPackStart mainBox boardCont PackNatural 0
--handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
{-
boardRunRV <- newCBMVarRW BoardStop
reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
board <- reactiveValueRead boardRV
layer <- reactiveValueRead layerRV
boardMap <- reactiveValueRead boardMapRV
layerMap <- reactiveValueRead layerMapRV
tempo <- reactiveValueRead tempoRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
inRV = liftR4 (,,,)
boardRV layerRV tempoRV' boardRunRV
inRV :: ReactiveFieldRead IO (M.IntMap (Board,Layer,Tempo,BoardRun))
inRV = liftR4 (\bm lm t br -> M.map (\(b,l) -> (b,l,t,br)) $
M.intersectionWith (,) bm lm)
boardMapRV layerMapRV tempoRV' boardRunRV
initSF <- reactiveValueRead inRV
(inBoard, outBoard) <- yampaReactiveDual initSF (boardRun initSF)
inRV =:> inBoard
reactiveValueOnCanRead outBoard $
reactiveValueOnCanRead outBoard $ do
out <- reactiveValueRead outBoard
phRVMap <- reactiveValueRead phRVMapRV
let eventsMap = M.filter isEvent out
writePh chan val =
fromMaybeM_ $ fmap (\ph -> reactiveValueWrite ph val) $
M.lookup chan phRVMap
noteMap = M.map ((\ev -> if isEvent ev then fromEvent ev else []) . snd . splitE) out
sequence_ $ M.mapWithKey writePh $
M.map (fst . fromEvent) $ M.filter isEvent out
--reactiveValueAppend boardQueue $ M.map (,[]) noteMap
{-
reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
reactiveValueAppend boardQueue
reactiveValueAppend boardQueue-}
-- This needs to be set last otherwise phRV is written to, so
-- inBoard is written to and the notes don't get played. There
-- supposedly is no guaranty of order but apparently there is…
fmap fst <^> outBoard >:> phRV
putStrLn "Board started."
-- Jack setup
forkIO $ jackSetup tempoRV chanRV boardQueue
-}
--forkIO $ jackSetup tempoRV boardQueue
widgetShowAll window
------------------------------------------------------------
......
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