Commit 03c5ca02 authored by Guerric Chupin's avatar Guerric Chupin

Basic configuration write/read.

parent da6a9d05
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
module RMCA.Configuration where
import Data.Array
import qualified Data.Bifunctor as BF
import Data.ReactiveValue
import RMCA.Layer.Layer
import RMCA.Semantics
import Text.Read
type InstrumentNo = Int
data BoardConf = BoardConf { confLayer :: (Layer,InstrumentNo)
, confBoard :: BoardInit
, confTempo :: Tempo
} deriving(Read,Show)
newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
mkInit :: Board -> BoardInit
mkInit = BoardInit . filter (uncurry (&&) . BF.bimap onBoard notDef) . assocs
where notDef (Inert,1) = False
notDef _ = True
boardInit :: BoardInit -> Board
boardInit = makeBoard . toList
saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
, ReactiveValueRead layer Layer IO
, ReactiveValueRead board Board IO
, ReactiveValueRead instr InstrumentNo IO) =>
FilePath -> tempo -> layer -> board -> instr -> IO ()
saveConfiguration fp t l b i = do
tempo <- reactiveValueRead t
layer <- reactiveValueRead l
board <- reactiveValueRead b
instr <- reactiveValueRead i
let bc = BoardConf { confLayer = (layer,instr)
, confTempo = tempo
, confBoard = mkInit board
}
writeFile fp $ show bc
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
errorLoad :: IO ()
errorLoad = undefined
......@@ -212,7 +212,7 @@ clickHandling pieceArrRV board pieceBox = do
boardOnRelease board
(\fPos -> do
button <- eventButton
liftIO $ do
liftIO $
postGUIAsync $ do
mp <- boardGetPiece fPos board
mstate <- tryTakeMVar state
......
......@@ -14,7 +14,7 @@ data Layer = Layer { relTempo :: Double
, strength :: Strength
, beatsPerBar :: BeatsPerBar
, volume :: Int
} deriving (Show)
} deriving (Show,Read)
layerTempo :: SF (Tempo, Layer) LTempo
layerTempo = proc (t, Layer { relTempo = r }) ->
......@@ -43,10 +43,12 @@ layerRV mvar = ReactiveFieldReadWrite setter getter notifier
notifier = installCallbackCBMVar mvar
getDefaultLayerRV :: IO (ReactiveFieldReadWrite IO Layer)
getDefaultLayerRV = layerRV <$> newCBMVar dl
where dl = Layer { relTempo = 1
, relPitch = 0
, strength = 1
, beatsPerBar = 4
, volume = 127
}
getDefaultLayerRV = layerRV <$> newCBMVar defaultLayer
defaultLayer :: Layer
defaultLayer = Layer { relTempo = 1
, relPitch = 0
, strength = 1
, beatsPerBar = 4
, volume = 127
}
......@@ -10,6 +10,7 @@ import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Hails.Yampa
import RMCA.Auxiliary.RV
import RMCA.Configuration
import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.LayerSettings
......
......@@ -138,7 +138,7 @@ type MIDICV = Int
-- MIDICVRnd gives the option to pick a control value at random.
-- (Handled through subsequent translation to low-level MIDI events.)
data MIDICVRnd = MIDICV MIDICV | MIDICVRnd deriving (Eq, Show)
data MIDICVRnd = MIDICV MIDICV | MIDICVRnd deriving (Eq, Show, Read)
--
------------------------------------------------------------------------------
......@@ -185,7 +185,7 @@ data Articulation = NoAccent
| Accent13
| Accent14
| Accent24
deriving (Eq, Show, Enum)
deriving (Eq, Show, Read, Enum)
accentStrength :: Strength
accentStrength = 1.2
......@@ -237,9 +237,9 @@ data Ornaments = Ornaments {
ornPC :: Maybe MIDIPN,
ornCC :: [(MIDICN, MIDICVRnd)],
ornSlide :: SlideType
} deriving Show
} deriving (Show,Read)
data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show, Enum)
data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show, Enum, Read)
noOrn :: Ornaments
noOrn = Ornaments { ornPC = Nothing
......@@ -257,7 +257,7 @@ data NoteAttr = NoteAttr {
naArt :: Articulation,
naDur :: Duration,
naOrn :: Ornaments
} deriving Show
} deriving (Show,Read)
-- High level note representation emitted form a layer
......@@ -287,7 +287,7 @@ data Note = Note {
-- Angle measured in multiples of 60 degrees.
type Angle = Int
data Dir = N | NE | SE | S | SW | NW deriving (Enum, Bounded, Eq, Show)
data Dir = N | NE | SE | S | SW | NW deriving (Enum, Bounded, Eq, Show, Read)
predDir :: Dir -> Dir
predDir d | d == minBound = maxBound
......@@ -332,7 +332,7 @@ data Action = Inert -- No action, play heads move through.
| Stop NoteAttr -- Play note then remove play head.
| ChDir Bool NoteAttr Dir -- Play note then change direction.
| Split NoteAttr -- Play note then split head into five.
deriving (Show)
deriving (Show,Read)
-- Cells
......
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