Commit 2cf508e9 by Guerric Chupin

Save supported, load is buggy.

parent 03c5ca02
BoardConf {confLayer = (Layer {relTempo = 1.0, relPitch = 1, strength = 0.800000011920929, beatsPerBar = 4, volume = 100},0), confBoard = BoardInit {toList = [((-5,1),(ChDir True (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) N,1)),((-5,3),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) S,1)),((-2,1),(ChDir True (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) NE,1)),((1,3),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) SW,1)),((1,4),(ChDir True (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) SE,1)),((1,5),(ChDir True (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) SE,1)),((1,6),(ChDir True (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) SE,1)),((4,2),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) NW,1)),((5,3),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) NW,1)),((7,3),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) NW,1))]}, confTempo = 120}
\ No newline at end of file
BoardConf {confLayer = (Layer {relTempo = 1.0, relPitch = 1, strength = 0.800000011920929, beatsPerBar = 4, volume = 100},0), confBoard = BoardInit {toList = []}, confTempo = 120}
\ No newline at end of file
BoardConf {confLayer = (Layer {relTempo = 1.0, relPitch = 1, strength = 0.800000011920929, beatsPerBar = 4, volume = 100},0), confBoard = BoardInit {toList = [((1,0),(ChDir True (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) N,1)),((1,3),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) SE,1)),((4,1),(ChDir False (NoteAttr {naArt = NoAccent, naDur = 1 % 4, naOrn = Ornaments {ornPC = Nothing, ornCC = [], ornSlide = NoSlide}}) SW,1))]}, confTempo = 120}
\ No newline at end of file
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-}
module RMCA.Configuration where
import Control.Exception
import Data.Array
import qualified Data.Bifunctor as BF
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
import RMCA.GUI.Board
import RMCA.Layer.Layer
import RMCA.Semantics
import Text.Read
......@@ -40,24 +44,35 @@ saveConfiguration fp t l b i = do
, confTempo = tempo
, confBoard = mkInit board
}
writeFile fp $ show bc
catch (writeFile fp $ show bc) (\(_ :: IOError) -> errorSave)
loadConfiguration :: ( ReactiveValueRead tempo Tempo IO
, ReactiveValueRead layer Layer IO
, ReactiveValueRead board Board IO
, ReactiveValueRead instr InstrumentNo IO) =>
FilePath -> tempo -> layer -> board -> instr -> IO ()
loadConfiguration fp t l b i = do
conf <- readMaybe <$> readFile
if isNothing conf then errorLoad else $ do
let BoardConf { confLayer = (layer,instr)
, confTempo = tempo
, confBoard = board
} = fromJust conf
reactiveValueWrite t tempo
reactiveValueWrite l layer
reactiveValueWrite b $ boardInit board
reactiveValueWrite i instr
loadConfiguration :: ( ReactiveValueWrite tempo Tempo IO
, ReactiveValueWrite layer Layer IO
, ReactiveValueWrite cell GUICell IO
, ReactiveValueWrite instr InstrumentNo IO) =>
FilePath -> tempo -> layer
-> Array Pos cell -> instr -> IO ()
loadConfiguration fp t l arr i = do
conf <- readMaybe <$> readFile fp
if isNothing conf then errorLoad else
do let BoardConf { confLayer = (layer,instr)
, confTempo = tempo
, confBoard = (BoardInit board)
} = fromJust conf
reactiveValueWrite t tempo
reactiveValueWrite l layer
mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
(\(_ :: ErrorCall) -> return ())) $ elems arr
mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! (toGUICoords p)) $
inertCell { cellAction = a
, repeatCount = r
}) board
reactiveValueWrite i instr
errorLoad :: IO ()
errorLoad = undefined
errorLoad = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
"Error loading the configuration file!" >>= widgetShow
errorSave :: IO ()
errorSave = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
"Error saving the configuration file!" >>= widgetShow
......@@ -19,6 +19,24 @@ gtkMediaPause = stringToGlib "gtk-media-pause"
gtkMediaRecord :: DefaultGlibString
gtkMediaRecord = stringToGlib "gtk-media-record"
gtkMediaSave :: DefaultGlibString
gtkMediaSave = stringToGlib "gtk-save"
gtkMediaOpen :: DefaultGlibString
gtkMediaOpen = stringToGlib "gtk-open"
buttonNewFromStockWithLabel :: StockId -> String -> IO Button
buttonNewFromStockWithLabel s l = do
button <- buttonNew
buttonBox <- hBoxNew False 0
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
toggleButtonNewFromStock :: StockId -> IO ToggleButton
toggleButtonNewFromStock s = do
button <- toggleButtonNew
......@@ -28,37 +46,56 @@ toggleButtonNewFromStock s = do
buttonLabel <- labelNew (siLabel <$> stockTxt)
labelSetUseUnderline buttonLabel True
containerAdd button buttonBox
boxPackStart buttonBox buttonImg PackNatural 0
boxPackStart buttonBox buttonLabel PackNatural 0
boxPackStart buttonBox buttonImg PackRepel 0
boxPackStart buttonBox buttonLabel PackRepel 0
return button
getButtons :: IO ( HBox
getButtons :: IO ( VBox
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
)
getButtons = do
buttonBox <- hBoxNew True 10
buttonBox <- vBoxNew False 10
buttonBoxTop <- hBoxNew True 10
boxPackStart buttonBox buttonBoxTop PackNatural 0
buttonSave <- buttonNewFromStockWithLabel gtkMediaSave "_Save configuration"
let confSaveRV = buttonActivateField buttonSave
boxPackStart buttonBoxTop buttonSave PackGrow 0
buttonLoad <- buttonNewFromStockWithLabel gtkMediaOpen "_Load configuration"
let confLoadRV = buttonActivateField buttonLoad
boxPackStart buttonBoxTop buttonLoad PackGrow 0
buttonBoxBot <- hBoxNew True 10
boxPackStart buttonBox buttonBoxBot PackNatural 0
buttonPlay <- buttonNewFromStock gtkMediaPlay
let playRV = buttonActivateField buttonPlay
boxPackStart buttonBox buttonPlay PackRepel 0
boxPackStart buttonBoxBot buttonPlay PackRepel 0
buttonPause <- toggleButtonNewFromStock gtkMediaPause
let pauseRV = readOnly $ toggleButtonActiveReactive buttonPause
boxPackStart buttonBox buttonPause PackRepel 0
boxPackStart buttonBoxBot buttonPause PackRepel 0
buttonStop <- buttonNewFromStock gtkMediaStop
let stopRV = buttonActivateField buttonStop
boxPackStart buttonBox buttonStop PackRepel 0
boxPackStart buttonBoxBot buttonStop PackRepel 0
buttonRecord <- toggleButtonNewFromStock gtkMediaRecord
let recordRV = readOnly $ toggleButtonActiveReactive buttonRecord
boxPackStart buttonBox buttonRecord PackRepel 0
boxPackStart buttonBoxBot buttonRecord PackRepel 0
return ( buttonBox
, playRV
, stopRV
, pauseRV
, recordRV
, confSaveRV
, confLoadRV
)
......@@ -32,7 +32,11 @@ mkVScale s adj = do
layerSettings :: ( ReactiveValueReadWrite board ([Note],[Message]) IO
, ReactiveValueRead chan Int IO) =>
chan -> board -> IO (VBox, ReactiveFieldReadWrite IO Layer)
chan -> board
-> IO ( VBox
, ReactiveFieldReadWrite IO Layer
, ReactiveFieldReadWrite IO Int
)
layerSettings chanRV boardQueue = do
layerSettingsVBox <- vBoxNew False 10
layerSettingsBox <- hBoxNew True 10
......@@ -110,4 +114,4 @@ layerSettings chanRV boardQueue = do
chan <- reactiveValueRead chanRV
let vol' = floor ((fromIntegral vol / 100) * 127)
reactiveValueAppend boardQueue ([],[Volume (mkChannel chan) vol'])
return (layerSettingsVBox, layerRV)
return (layerSettingsVBox, layerRV, instrumentComboRV)
......@@ -43,12 +43,12 @@ main = do
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 0
(layerSettingsVBox, layerRV) <- layerSettings chanRV boardQueue
(layerSettingsVBox, layerRV, instrRV) <- layerSettings chanRV boardQueue
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
boxPackStart settingsBox laySep PackNatural 0
(buttonBox, playRV, stopRV, pauseRV, recordRV) <- getButtons
(buttonBox, playRV, stopRV, pauseRV, recordRV, confSaveRV, confLoadRV) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
-- Board
......@@ -65,6 +65,42 @@ main = do
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
--fcsw <- windowNew
fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
--containerAdd fcsw fcs
reactFilt <- fileFilterNew
fileFilterAddPattern reactFilt "*.react"
fileFilterSetName reactFilt "RMCA conf files."
fileChooserAddFilter fcs reactFilt
--fclw <- windowNew
fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
--containerAdd fclw fcl
fileChooserAddFilter fcl reactFilt
reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
widgetShowAll fcs
let respHandle ResponseOk =
fileChooserGetFilename fcs >>= fromMaybeM_ .
fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
respHandle _ = return ()
onResponse fcs (\r -> respHandle r >> widgetHide fcs)
return ()
reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
widgetShowAll fcl
let respHandle ResponseOk =
fileChooserGetFilename fcl >>= fromMaybeM_ .
fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
respHandle _ = return ()
onResponse fcl (\r -> respHandle r >> widgetHide fcl)
return ()
reactiveValueOnCanRead playRV
(reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
......
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