-- 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
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
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 ()
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
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
) =>
-> 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
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
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
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)
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
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)
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
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
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
------------------------------------------------------------
sourcephile / git / tmp / julm / arpeggigon.git / commitdiff