Commit ee7c94ce authored by Guerric Chupin's avatar Guerric Chupin

Code cleaning and seg fault tracking.

parent ca010006
......@@ -47,7 +47,12 @@ executable RMCA
hs-source-dirs: src
build-tools: hsc2hs
default-language: Haskell2010
ghc-options: -O2 -threaded -W
ghc-options: -O2
-threaded
-Wall
-fno-warn-name-shadowing
-fno-warn-unused-do-bind
-debug
executable RMCA.prof
main-is: RMCA/Main.hs
......@@ -81,8 +86,13 @@ executable RMCA.prof
default-language: Haskell2010
ghc-options: -O2
-threaded
-W
-fprof-auto
-prof
-auto-all
"-with-rtsopts=-p -s -h -i0.1"
-Wall
-fno-warn-name-shadowing
-fno-warn-unused-do-bind
--fprof-auto
--prof
--auto-all
-eventlog
-debug
--"-with-rtsopts=-P -S -T -h -i0.1 -xt"
"-with-rtsopts=-ls"
\ No newline at end of file
......@@ -41,6 +41,10 @@ eventToMaybe :: Event a -> Maybe a
eventToMaybe NoEvent = Nothing
eventToMaybe (Event x) = Just x
eventToList :: Event [a] -> [a]
eventToList NoEvent = []
eventToList (Event x) = x
--------------------------------------------------------------------------------
-- FRP
--------------------------------------------------------------------------------
......
......@@ -96,7 +96,7 @@ layerSettings boardQueue = do
-}
layPitchRV <- newCBMVarRW 1
let layTempoRV = floatConv $ scaleValueReactive layTempoScale
strengthRV = floatConv $ scaleValueReactive layStrengthScale
strengthRV = floatConv $ scaleValueReactive layStrengthScale
bpbRV = spinButtonValueIntReactive bpbButton
layVolumeRV = liftRW (bijection (floor, fromIntegral)) $
scaleValueReactive layVolumeScale
......@@ -121,7 +121,7 @@ layerSettings boardQueue = do
layerMCBMVar <- newMCBMVar =<< reactiveValueRead (liftR5 f2 layTempoRV layPitchRV strengthRV bpbRV layVolumeRV)
reactiveValueOnCanRead layerMCBMVar $ do
reactiveValueOnCanRead layerMCBMVar $ postGUIAsync $ do
nLayer <- reactiveValueRead layerMCBMVar
reactiveValueWriteOnNotEq layTempoRV $ relTempo nLayer
reactiveValueWriteOnNotEq layPitchRV $ relPitch nLayer
......
......@@ -102,7 +102,7 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
containerAdd boardCont centerBoard
fstP <- notebookAppendPage n boardCont "Lol first"
notebookPageNumber <- newCBMVarRW 1
notebookPageNumber <- newCBMVarRW (1 :: Int)
initBoardRV guiBoard >>=
\(boardRV, pieceArrRV, phRV) -> reactiveValueRead chanMapRV >>=
......
......@@ -195,12 +195,15 @@ noteSettingsBox = do
Absorb -> hideNa
_ -> showNa
reactiveValueOnCanRead setRV $ do
reactiveValueOnCanRead setRV $ postGUIAsync $ 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
{-
......
......@@ -11,7 +11,7 @@ import RMCA.Auxiliary
import RMCA.Layer.Layer
import RMCA.Semantics
data BoardRun = BoardStart | BoardStop deriving Eq
data BoardRun = BoardStart | BoardStop deriving (Eq, Show)
singleBoard :: [PlayHead]
-> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
......@@ -34,16 +34,17 @@ boardSwitch rPh = dSwitch (singleBoard rPh *** (identity >>> notYet)) fnSwitch
where fnSwitch (BoardStart, iPh) = boardSwitch iPh
fnSwitch (BoardStop, _) = boardSwitch []
--------------------------------------------------------------------------------
-- Machinery to make parallel boards run
--------------------------------------------------------------------------------
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
lengthChange iSig = edgeBy diffSig ik <<^ M.keys <<^ fst
where ik = M.keys iSig
-- Old elements removed in nL are on the left, new elements added to
-- nL are on the right.
......@@ -56,8 +57,10 @@ 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
boardRun' iSF = boardRun'' iSF (lengthChange iSF)
where boardRun'' iSF swSF = pSwitch routeBoard iSF swSF contSwitch
contSwitch contSig (oldSig, newSig) = boardRun'' newSF
(lengthChange newSF >>> notYet)
where newSF = foldr (\k m -> M.insert k boardSF m)
(foldr M.delete contSig oldSig) newSig
......
......@@ -90,7 +90,7 @@ main = do
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
noteMap = M.map (eventToList . snd . splitE) out
sequence_ $ M.mapWithKey writePh $
M.map (fst . fromEvent) $ M.filter isEvent out
......
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