Commit e94934e9 authored by Guerric Chupin's avatar Guerric Chupin

Multiple layers correctly implemented graphically.

parent abc8af65
......@@ -49,39 +49,40 @@ executable RMCA
default-language: Haskell2010
ghc-options: -O2 -threaded -W
-- executable RMCA.prof
-- main-is: RMCA/Main.hs
-- other-modules: Paths_RMCA
-- other-extensions: MultiParamTypeClasses
-- , ScopedTypeVariables
-- , Arrows
-- , FlexibleInstances
-- , TypeSynonymInstances
-- , FlexibleContexts
-- , GeneralizedNewtypeDeriving
-- build-depends: base >=4.8 && <4.10
-- , array >=0.5 && <0.6
-- , cairo >=0.13 && <0.14
-- , keera-hails-reactivevalues >=0.2 && <0.3
-- , Yampa >=0.10 && <0.11
-- , gtk-helpers >=0.0 && <0.1
-- , gtk >=0.14 && <0.15
-- , keera-hails-reactive-gtk >=0.3 && <0.4
-- , keera-hails-reactive-yampa >=0.0 && <0.1
-- , containers >=0.5 && <0.6
-- , jack >=0.7 && <0.8
-- , midi >=0.2 && <0.3
-- , explicit-exception >=0.1 && <0.2
-- , transformers >=0.4 && <0.6
-- , event-list >=0.1 && <0.2
-- , keera-callbacks >=0.1 && <0.2
-- , glib >=0.13 && <0.14
-- hs-source-dirs: src
-- build-tools: hsc2hs
-- default-language: Haskell2010
-- ghc-options: -O2
-- -threaded
-- -W
-- -fprof-auto
-- -prof
-- "-with-rtsopts=-p -s -h -i0.1"
executable RMCA.prof
main-is: RMCA/Main.hs
other-modules: Paths_RMCA
other-extensions: MultiParamTypeClasses
, ScopedTypeVariables
, Arrows
, FlexibleInstances
, TypeSynonymInstances
, FlexibleContexts
, GeneralizedNewtypeDeriving
build-depends: base >=4.8 && <4.10
, array >=0.5 && <0.6
, cairo >=0.13 && <0.14
, keera-hails-reactivevalues >=0.2 && <0.3
, Yampa >=0.10 && <0.11
, gtk-helpers >=0.0 && <0.1
, gtk >=0.14 && <0.15
, keera-hails-reactive-gtk >=0.3 && <0.4
, keera-hails-reactive-yampa >=0.0 && <0.1
, containers >=0.5 && <0.6
, jack >=0.7 && <0.8
, midi >=0.2 && <0.3
, explicit-exception >=0.1 && <0.2
, transformers >=0.4 && <0.6
, event-list >=0.1 && <0.2
, keera-callbacks >=0.1 && <0.2
, glib >=0.13 && <0.14
hs-source-dirs: src
build-tools: hsc2hs
default-language: Haskell2010
ghc-options: -O2
-threaded
-W
-fprof-auto
-prof
-auto-all
"-with-rtsopts=-p -s -h -i0.1"
......@@ -87,6 +87,9 @@ onChange' = proc x -> do
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
updateRV :: (ReactiveValueReadWrite a b m) => a -> m ()
updateRV rv = reactiveValueRead rv >>= reactiveValueWrite rv
--------------------------------------------------------------------------------
-- Reactive Values
--------------------------------------------------------------------------------
......@@ -104,6 +107,13 @@ reactiveValueAppend :: (Monoid b, ReactiveValueReadWrite a b m) =>
reactiveValueAppend rv v = do ov <- reactiveValueRead rv
reactiveValueWrite rv (ov `mappend` v)
reactiveValueWriteOnNotEq :: ( Eq b
, ReactiveValueReadWrite a b m) =>
a -> b -> m ()
reactiveValueWriteOnNotEq rv nv = do
ov <- reactiveValueRead rv
when (ov /= nv) $ reactiveValueWrite rv nv
emptyRW :: (Monoid b, ReactiveValueReadWrite a b m) => a -> m b
emptyRW rv = do
val <- reactiveValueRead rv
......@@ -119,6 +129,14 @@ eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
erv <- reactiveValueRead eventRV
when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
syncRightOnLeftWithBoth :: ( ReactiveValueRead a b m
, ReactiveValueReadWrite c d m
) => (b -> d -> d) -> a -> c -> m ()
syncRightOnLeftWithBoth f l r = reactiveValueOnCanRead l $ do
nl <- reactiveValueRead l
or <- reactiveValueRead r
reactiveValueWrite r (f nl or)
liftW3 :: ( Monad m
, ReactiveValueWrite a b m
, ReactiveValueWrite c d m
......
......@@ -85,6 +85,7 @@ layerSettings boardQueue = do
instrumentComboRV = bijection (indexToInstr, instrToIndex) `liftRW`
comboBoxIndexRV instrumentCombo
instrMCBMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
{-
ins <- reactiveValueRead instrumentComboRV
chan <- reactiveValueRead chanRV
......@@ -99,33 +100,41 @@ layerSettings boardQueue = do
bpbRV = spinButtonValueIntReactive bpbButton
layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
scaleValueReactive layVolumeScale
{-
f1 Layer { relTempo = d
, relPitch = p
, strength = s
, 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
}
} = (d,p,s,bpb,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
-}
layerMCBMVar <- newMCBMVar =<< reactiveValueRead (liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
reactiveValueOnCanRead layerMCBMVar $ do
nLayer <- reactiveValueRead layerMCBMVar
reactiveValueWriteOnNotEq layTempoRV $ relTempo nLayer
reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer
reactiveValueWriteOnNotEq strengthRV $ strength nLayer
reactiveValueWriteOnNotEq bpbRV $ beatsPerBar nLayer
reactiveValueWriteOnNotEq layVolumeRV $ volume nLayer
layerMMVar <- newMCBMVar =<< reactiveValueRead layerRV
reactiveValueOnCanRead layerRV $
reactiveValueRead layerRV >>= writeMCBMVar layerMMVar
installCallbackMCBMVar layerMMVar $
readMCBMVar layerMMVar >>= reactiveValueWrite layerRV
syncRightOnLeftWithBoth (\nt ol -> ol { relTempo = nt }) layTempoRV layerMCBMVar
syncRightOnLeftWithBoth (\np ol -> ol { relPitch = np }) layPitchRV layerMCBMVar
syncRightOnLeftWithBoth (\ns ol -> ol { strength = ns }) strengthRV layerMCBMVar
syncRightOnLeftWithBoth (\nb ol -> ol { beatsPerBar = nb}) bpbRV layerMCBMVar
syncRightOnLeftWithBoth (\nv ol -> ol { volume = nv }) layVolumeRV layerMCBMVar
instrMMVar <- newMCBMVar =<< reactiveValueRead instrumentComboRV
reactiveValueOnCanRead instrumentComboRV $
reactiveValueRead instrumentComboRV >>= writeMCBMVar instrMMVar
installCallbackMCBMVar instrMMVar $
readMCBMVar instrMMVar >>= reactiveValueWrite instrumentComboRV
{-
reactiveValueOnCanRead layVolumeRV $ do
vol <- reactiveValueRead layVolumeRV
......@@ -133,4 +142,4 @@ layerSettings boardQueue = do
let vol' = floor ((fromIntegral vol / 100) * 127)
reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
-}
return (layerSettingsVBox, layerMMVar, instrMMVar)
return (layerSettingsVBox, layerMCBMVar, instrMCBMVar)
......@@ -7,6 +7,7 @@ import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.ReactiveValue
......@@ -21,7 +22,7 @@ import RMCA.Layer.Layer
import RMCA.MCBMVar
import RMCA.Semantics
-- In GTk, a “thing with tabs” has the I think very confusing name
-- In GTk, a “thing with tabs” has the, I think, very confusing name
-- Notebook.
createNotebook :: ( ReactiveValueRead addLayer () IO
......@@ -35,15 +36,28 @@ createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveFieldReadWrite IO
(M.Map Int ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldWrite IO [PlayHead])
)
, ReactiveFieldWrite IO [PlayHead]
))
, ReactiveFieldReadWrite IO Int
)
createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
n <- notebookNew
let curPageRV = ReactiveFieldReadWrite setter getter notifier
(ReactiveFieldRead getter notifier) = notebookGetCurrentPagePassive n
(ReactiveFieldWrite setter) = notebookSetCurrentPageReactive n
where (ReactiveFieldRead getter _) = notebookGetCurrentPagePassive n
-- afterSwitchPage is deprecated but switchPage gets us
-- the old page number and not the new one and using
-- afterSwitchPage doesn't trigger a warning.
setter = postGUIAsync . notebookSetCurrentPage n
notifier io = void $ afterSwitchPage n (const io)
pageChanRV <- newCBMVarRW []
let foundHole = let foundHole' [] = 0
foundHole' (x:[]) = x + 1
foundHole' (x:y:xs) = if x + 1 /= y then x + 1 else foundHole (y:xs)
in foundHole' . sort
let curChanRV = liftR2 (!!) pageChanRV curPageRV
------------------------------------------------------------------------------
-- First board
------------------------------------------------------------------------------
......@@ -75,7 +89,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
when (isJust mOHid) $
removeCallbackMCBMVar guiCellMCBMVar $ fromJust mOHid
nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
cp <- reactiveValueRead curPageRV
cp <- reactiveValueRead curChanRV
guiVal <- reactiveValueRead guiCellMCBMVar
mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
when (isNothing mChanRV) $ error "Can't get piece array!"
......@@ -92,13 +106,15 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
fstP <- notebookPrependPage n boardCont "Lol first"
fstP <- notebookAppendPage n boardCont "Lol first"
notebookPageNumber <- newCBMVarRW 1
initBoardRV guiBoard >>=
\(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert fstP (boardRV,pieceArrRV,phRV)
reactiveValueRead pageChanRV >>=
reactiveValueWrite pageChanRV . (\pc -> pc ++ [foundHole pc])
layerMapRV <- newCBMVarRW $ M.insert fstP defaultLayer M.empty
let updateLayer cp = do
......@@ -109,7 +125,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
layerHidMVar <- newEmptyMVar
installCallbackMCBMVar layerMCBMVar
(reactiveValueRead curPageRV >>= updateLayer) >>= putMVar layerHidMVar
(reactiveValueRead curChanRV >>= updateLayer) >>= putMVar layerHidMVar
------------------------------------------------------------------------------
-- Following boards
......@@ -123,47 +139,65 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
nGuiBoard <- attachGameRules =<< initGame
clickHandler nGuiBoard
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard nGuiBoard
containerAdd nBoardCont centerBoard
newP <- notebookAppendPage n boardCont "sdlkfhd"
nCenterBoard <- alignmentNew 0.5 0.5 0 0
containerAdd nCenterBoard nGuiBoard
containerAdd nBoardCont nCenterBoard
newP <- notebookAppendPage n nBoardCont $ show np
pChan <- reactiveValueRead pageChanRV
let newCP = foundHole pChan
print ("newP" ++ " " ++ show newP)
(nBoardRV, nPieceArrRV, nPhRV) <- initBoardRV nGuiBoard
reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.insert newP (nBoardRV,nPieceArrRV,nPhRV)
reactiveValueWrite curPageRV newP
reactiveValueWrite chanMapRV . M.insert newCP (nBoardRV,nPieceArrRV,nPhRV)
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.insert newCP defaultLayer
--reactiveValueWrite curPageRV newP
reactiveValueWrite pageChanRV (pChan ++ [newCP])
widgetShowAll n
reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
np <- reactiveValueRead notebookPageNumber
when (np > 1) $ do
cp <- notebookGetCurrentPage n
cp <- reactiveValueRead curPageRV
oldCP <- reactiveValueRead curChanRV
let rmIndex :: Int -> [a] -> [a]
rmIndex n l = take n l ++ drop (n + 1) l
notebookRemovePage n cp
reactiveValueRead pageChanRV >>=
reactiveValueWrite pageChanRV . rmIndex cp
reactiveValueRead notebookPageNumber >>=
reactiveValueWrite notebookPageNumber . subtract 1
reactiveValueRead chanMapRV >>=
reactiveValueWrite chanMapRV . M.delete cp
reactiveValueWrite chanMapRV . M.delete oldCP
reactiveValueRead layerMapRV >>=
reactiveValueWrite layerMapRV . M.delete cp
reactiveValueWrite layerMapRV . M.delete oldCP
--updateRV curPageRV
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 ()
reactiveValueOnCanRead curChanRV $ do
cp <- reactiveValueRead curChanRV
print cp
when (cp >= 0) $ do
reactiveValueRead pageChanRV >>= print
takeMVar layerHidMVar >>= removeCallbackMCBMVar layerMCBMVar
layerMap <- reactiveValueRead layerMapRV
--print $ M.keys layerMap
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
......
......@@ -14,7 +14,7 @@ data Layer = Layer { relTempo :: Double
, strength :: Strength
, beatsPerBar :: BeatsPerBar
, volume :: Int
} deriving (Show,Read)
} deriving (Show,Read, Eq)
layerTempo :: SF (Tempo, Layer) LTempo
layerTempo = proc (t, Layer { relTempo = r }) ->
......
......@@ -42,26 +42,25 @@ main = do
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 0
boardQueue <- newCBMVarRW mempty
chanRV <- newCBMVarRW 0
(layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
boxPackStart settingsBox laySep PackNatural 0
( buttonBox
, playRV, stopRV, pauseRV, recordRV
, confSaveRV, confLoadRV
, addLayerRV, rmLayerRV ) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
( boardCont, pieceBox
, boardRV, pieceArrRV, phRV) <- createNotebook addLayerRV rmLayerRV layerRV tempoRV
boxPackStart mainBox boardCont PackNatural 0
boardQueue <- newCBMVarRW mempty
(layerSettingsVBox, layerMCBMVar, instrMCBMVar) <- layerSettings boardQueue
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
boxPackStart settingsBox laySep PackNatural 0
handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
(noteSettingsBox, guiCellMCBMVar) <- noteSettingsBox
(boardCont, chanMapRV, _{-curPageRV-}) <- 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
......@@ -72,7 +71,6 @@ main = do
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
inRV = liftR4 (,,,)
boardRV layerRV tempoRV' boardRunRV
--let inRV = onTick clock inRV
inRV =:> inBoard
reactiveValueOnCanRead outBoard $
reactiveValueRead (liftR (event mempty (,[]) <<< snd <<< splitE) outBoard) >>=
......@@ -84,9 +82,10 @@ main = do
putStrLn "Board started."
-- Jack setup
forkIO $ jackSetup tempoRV chanRV boardQueue
-}
widgetShowAll window
------------------------------------------------------------
boxPackStart settingsBox pieceBox PackNatural 10
boxPackStart settingsBox noteSettingsBox PackNatural 10
onDestroy window mainQuit
mainGUI
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