Commit abc8af65 authored by Guerric Chupin's avatar Guerric Chupin

A sort of sensible multi layer GUI.

parent 316a8150
......@@ -11,6 +11,7 @@ import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.NoteSettings
import RMCA.Layer.Layer
import RMCA.MCBMVar
import RMCA.Semantics
import RMCA.Translator.Instruments
import RMCA.Translator.Message
......@@ -30,14 +31,15 @@ mkVScale s adj = do
boxPackStart hBox boxScale PackNatural 0
return (hBox,boxScale)
layerSettings :: ( ReactiveValueReadWrite board ([Note],[Message]) IO
, ReactiveValueRead chan Int IO) =>
chan -> board
-> IO ( VBox
, ReactiveFieldReadWrite IO Layer
, ReactiveFieldReadWrite IO Int
)
layerSettings chanRV boardQueue = do
layerSettings :: (ReactiveValueReadWrite board ([Note],[Message]) IO) =>
board -> IO ( VBox
, MCBMVar Layer
, MCBMVar Int
)
layerSettings boardQueue = do
------------------------------------------------------------------------------
-- GUI Boxes
------------------------------------------------------------------------------
layerSettingsVBox <- vBoxNew False 10
layerSettingsBox <- hBoxNew True 10
boxPackStart layerSettingsVBox layerSettingsBox PackNatural 0
......@@ -47,7 +49,6 @@ layerSettings chanRV boardQueue = do
boxPackStart layerSettingsBox layVolumeBox PackNatural 0
scaleSetDigits layVolumeScale 0
layTempoAdj <- adjustmentNew 1 0 2 0.1 0.1 1
(layTempoBox, layTempoScale) <- mkVScale "Layer tempo" layTempoAdj
boxPackStart layerSettingsBox layTempoBox PackNatural 0
......@@ -72,6 +73,10 @@ layerSettings chanRV boardQueue = do
return (i, ind)) instrumentList
comboBoxSetActive instrumentCombo 0
boxPackStart layerSettingsVBox instrumentCombo PackNatural 10
------------------------------------------------------------------------------
-- RVs
------------------------------------------------------------------------------
let indexToInstr i = fromMaybe (error "Can't get the selected instrument.") $
lookup i instrumentIndex
instrToIndex ins =
......@@ -80,14 +85,14 @@ layerSettings chanRV boardQueue = do
instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
comboBoxIndexRV instrumentCombo
changeInst = do
ins <- reactiveValueRead instrumentComboRV
chan <- reactiveValueRead chanRV
reactiveValueAppend boardQueue
([],[Instrument (mkChannel chan) (mkProgram ins)])
changeInst
reactiveValueOnCanRead instrumentComboRV changeInst
{-
ins <- reactiveValueRead instrumentComboRV
chan <- reactiveValueRead chanRV
reactiveValueAppend boardQueue ([],[Instrument (mkChannel chan)
(mkProgram ins)])
reactiveValueOnCanRead instrumentComboRV changeInst
-}
layPitchRV <- newCBMVarRW 1
let layTempoRV = floatConv $ scaleValueReactive layTempoScale
strengthRV = floatConv $ scaleValueReactive layStrengthScale
......@@ -100,18 +105,32 @@ layerSettings chanRV boardQueue = do
, beatsPerBar = bpb
, volume = v
} = (d,p,s,bpb,v)
f2 (d,p,s,bpb,v) = Layer { relTempo = d
, relPitch = p
, strength = s
, beatsPerBar = bpb
, volume = v
}
f2 (d,p,s,bpb,v) = Layer { relTempo = d
, relPitch = p
, strength = s
, beatsPerBar = bpb
, volume = v
}
layerRV = liftRW5 (bijection (f1,f2))
layTempoRV layPitchRV strengthRV bpbRV layVolumeRV
layerMMVar <- newMCBMVar =<< reactiveValueRead layerRV
reactiveValueOnCanRead layerRV $
reactiveValueRead layerRV >>= writeMCBMVar layerMMVar
installCallbackMCBMVar layerMMVar $
readMCBMVar layerMMVar >>= reactiveValueWrite layerRV
instrMMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
reactiveValueOnCanRead instrumentComboRV $
reactiveValueRead instrumentComboRV >>= writeMCBMVar instrMMVar
installCallbackMCBMVar instrMMVar $
readMCBMVar instrMMVar >>= reactiveValueWrite instrumentComboRV
{-
reactiveValueOnCanRead layVolumeRV $ do
vol <- reactiveValueRead layVolumeRV
chan <- reactiveValueRead chanRV
let vol' = floor ((fromIntegral vol / 100) * 127)
reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
return (layerSettingsVBox, layerRV, instrumentComboRV)
-}
return (layerSettingsVBox, layerMMVar, instrMMVar)
......@@ -2,83 +2,179 @@
module RMCA.GUI.MultiBoard where
import Control.Monad
import Data.Array
import Data.ReactiveValue
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.GUI.NoteSettings
import RMCA.Layer.Layer
import RMCA.Semantics
import Control.Arrow
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
import qualified Data.Map as M
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Graphics.UI.Gtk.Reactive.Gtk2
import RMCA.Auxiliary
import RMCA.GUI.Board
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
, ReactiveValueRead layer Layer IO
, ReactiveValueRead tempo Tempo IO
) => addLayer -> rmLayer -> layer -> tempo
) =>
addLayer
-> rmLayer
-> MCBMVar Layer
-> MCBMVar GUICell
-> IO ( Notebook
, VBox
, ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldWrite IO [PlayHead]
, ReactiveFieldReadWrite IO
(M.Map Int ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldWrite IO [PlayHead])
)
, ReactiveFieldReadWrite IO Int
)
createNotebook addLayerRV rmLayerRV layerRV tempoRV = do
createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
n <- notebookNew
--plusImg <- imageNewFromStock gtkMediaAdd IconSizeButton
--notebookAppendPageMenu n undefined plusImg undefined
let curPageRV = ReactiveFieldReadWrite setter getter notifier
(ReactiveFieldRead getter notifier) = notebookGetCurrentPagePassive n
(ReactiveFieldWrite setter) = notebookSetCurrentPageReactive n
------------------------------------------------------------------------------
-- First board
------------------------------------------------------------------------------
chanMapRV <- newCBMVarRW M.empty
guiCellHidMVar <- newEmptyMVar
let clickHandler ioBoard = do
state <- newEmptyMVar
boardOnPress ioBoard
(\iPos -> liftIO $ do
postGUIAsync $ void $ tryPutMVar state iPos
return True
)
boardOnRelease ioBoard
(\fPos -> do
button <- eventButton
liftIO $ postGUIAsync $ do
mp <- boardGetPiece fPos ioBoard
mstate <- tryTakeMVar state
when (fPos `elem` validArea && isJust mp) $ do
let piece = snd $ fromJust mp
when (button == RightButton && maybe False (== fPos) mstate) $
boardSetPiece fPos (second rotateGUICell (Player,piece)) ioBoard
nmp <- boardGetPiece fPos ioBoard
when (button == LeftButton && isJust nmp) $ do
let nCell = snd $ fromJust nmp
reactiveValueWrite guiCellMCBMVar nCell
mOHid <- tryTakeMVar guiCellHidMVar
when (isJust mOHid) $
removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
cp <- reactiveValueRead curPageRV
guiVal <- reactiveValueRead guiCellMCBMVar
mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
when (isNothing mChanRV) $ error "Can't get piece array!"
let (_,pieceArrRV,_) = fromJust mChanRV
reactiveValueWrite (pieceArrRV ! fPos) guiVal
putMVar guiCellHidMVar nHid
return True
)
boardCont <- backgroundContainerNew
guiBoard <- attachGameRules =<< initGame
clickHandler guiBoard
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
notebookPrependPage n boardCont "Lol first"
fstP <- notebookPrependPage n boardCont "Lol first"
notebookPageNumber <- newCBMVarRW 1
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
initBoardRV guiBoard >>=
\(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
let updateLayer cp = do
nLayer <- reactiveValueRead layerMCBMVar
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.insert cp nLayer
layerHidMVar <- newEmptyMVar
pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
installCallbackMCBMVar layerMCBMVar
(reactiveValueRead curPageRV >>= updateLayer) >>= putMVar layerHidMVar
------------------------------------------------------------------------------
-- Following boards
------------------------------------------------------------------------------
reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
reactiveValueRead notebookPageNumber
>>= reactiveValueWrite notebookPageNumber . (+1)
boardCont <- backgroundContainerNew
np <- reactiveValueRead notebookPageNumber
unless (np >= 16) $ do
reactiveValueWrite notebookPageNumber (np + 1)
nBoardCont <- backgroundContainerNew
nGuiBoard <- attachGameRules =<< initGame
clickHandler nGuiBoard
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard nGuiBoard
containerAdd nBoardCont centerBoard
newP <- notebookAppendPage n boardCont "sdlkfhd"
(nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert newP (nBoardRV,nPieceArrRV,nPhRV)
guiBoard <- attachGameRules =<< initGame
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
reactiveValueWrite curPageRV newP
notebookAppendPage n boardCont "sdlkfhd" >> widgetShowAll n
widgetShowAll n
reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
np <- reactiveValueRead notebookPageNumber
when (np > 1) $ do
notebookRemovePage n =<< notebookGetCurrentPage n
cp <- notebookGetCurrentPage n
notebookRemovePage n cp
reactiveValueRead notebookPageNumber
>>= reactiveValueWrite notebookPageNumber . (subtract 1)
reactiveValueRead notebookPageNumber >>=
reactiveValueWrite notebookPageNumber . subtract 1
reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.delete cp
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.delete cp
widgetShowAll n
return ()
reactiveValueOnCanRead curPageRV $ do
takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
cp <- reactiveValueRead curPageRV
layerMap <- reactiveValueRead layerMapRV
let mSelLayer = M.lookup cp layerMap
when (isNothing mSelLayer) $ error "Not found selected layer!"
let selLayer = fromJust mSelLayer
reactiveValueWrite layerMCBMVar selLayer
installCallbackMCBMVar layerMCBMVar (updateLayer cp) >>= putMVar layerHidMVar
return ()
------------------------------------------------------------------------------
-- Handle clicks
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- For good measure
------------------------------------------------------------------------------
return (n, pieceBox, boardRV, pieceArrRV, phRV)
return (n, chanMapRV, curPageRV)
--return ()
......@@ -3,24 +3,20 @@
module RMCA.GUI.NoteSettings where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
import qualified Data.Bifunctor as BF
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.Semantics
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.MCBMVar
import RMCA.Semantics
setNAttr :: NoteAttr -> Action -> Action
setNAttr _ Inert = Inert
......@@ -58,10 +54,9 @@ comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
setter = comboBoxSetActive box
notifier = void . on box changed
clickHandling :: (ReactiveValueWrite cell GUICell IO) =>
Array Pos cell
-> IOBoard -> VBox -> IO VBox
clickHandling pieceArrRV board pieceBox = do
noteSettingsBox :: IO (VBox, MCBMVar GUICell)
noteSettingsBox = do
pieceBox <- vBoxNew False 10
naBox <- vBoxNew False 10
boxPackStart pieceBox naBox PackNatural 10
......@@ -136,11 +131,11 @@ clickHandling pieceArrRV board pieceBox = do
-- Side RV
-- Carries the index of the tile to display and what to display.
setRV <- newCBMVarRW ((0,0),inertCell)
setRV <- newCBMVarRW inertCell
reactiveValueOnCanRead noteDurRV $ do
nDur <- reactiveValueRead noteDurRV
(i,oCell) <- reactiveValueRead setRV
oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
nCell :: GUICell
......@@ -148,21 +143,19 @@ clickHandling pieceArrRV board pieceBox = do
then oCell { cellAction =
setNAttr (fromJust nCa) (cellAction oCell) }
else oCell
reactiveValueWrite setRV (i,nCell)
reactiveValueWrite setRV nCell
fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
reactiveValueWrite (pieceArrRV ! i) nCell
reactiveValueOnCanRead rCountRV $ do
nRCount <- reactiveValueRead rCountRV
(i,oCell) <- reactiveValueRead setRV
oCell <- reactiveValueRead setRV
let nCell = oCell { repeatCount = nRCount }
reactiveValueWrite setRV (i,nCell)
reactiveValueWrite (pieceArrRV ! i) nCell
reactiveValueWrite setRV nCell
reactiveValueOnCanRead slideComboRV $ do
nSlide <- reactiveValueRead slideComboRV
(i,oCell) <- reactiveValueRead setRV
oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
getNAttr (cellAction oCell)
......@@ -172,12 +165,11 @@ clickHandling pieceArrRV board pieceBox = do
setNAttr (fromJust nCa) (cellAction oCell)
}
else oCell
reactiveValueWrite setRV (i,nCell)
reactiveValueWrite (pieceArrRV ! i) nCell
reactiveValueWrite setRV nCell
reactiveValueOnCanRead artComboRV $ do
nArt <- reactiveValueRead artComboRV
(i,oCell) <- reactiveValueRead setRV
oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell)
nCell :: GUICell
......@@ -185,8 +177,7 @@ clickHandling pieceArrRV board pieceBox = do
then oCell { cellAction =
setNAttr (fromJust nCa) (cellAction oCell) }
else oCell
reactiveValueWrite setRV (i,nCell)
reactiveValueWrite (pieceArrRV ! i) nCell
reactiveValueWrite setRV nCell
let hideNa :: IO ()
hideNa = do widgetHide slideCombo
......@@ -204,6 +195,8 @@ clickHandling pieceArrRV board pieceBox = do
Absorb -> hideNa
_ -> showNa
reactiveValueOnCanRead setRV $ reactiveValueRead setRV >>= updateNaBox
{-
state <- newEmptyMVar
boardOnPress board
(\iPos -> liftIO $ do
......@@ -222,7 +215,6 @@ clickHandling pieceArrRV board pieceBox = do
when (button == RightButton && maybe False (== fPos) mstate) $
boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
nmp <- boardGetPiece fPos board
--print nmp
when (button == LeftButton && isJust nmp) $ do
let nC = snd $ fromJust nmp
reactiveValueWrite setRV (fPos,nC)
......@@ -240,4 +232,8 @@ clickHandling pieceArrRV board pieceBox = do
widgetShow pieceBox
widgetShow naBox
return pieceBox
-}
setMCBMVar <- newMCBMVar =<< reactiveValueRead setRV
setMCBMVar =:= setRV
return (pieceBox,setMCBMVar)
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