src/RMCA/Configuration.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 module RMCA.Configuration where
   4
   5 import           Data.Array
   6 import qualified Data.Bifunctor     as BF
   7 import           Data.ReactiveValue
   8 import           RMCA.Layer.Layer
   9 import           RMCA.Semantics
  10 import           Text.Read
  11
  12 type InstrumentNo = Int
  13
  14 data BoardConf = BoardConf { confLayer :: (Layer,InstrumentNo)
  15                            , confBoard :: BoardInit
  16                            , confTempo :: Tempo
  17                            } deriving(Read,Show)
  18
  19 newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
  20
  21 mkInit :: Board -> BoardInit
  22 mkInit = BoardInit . filter (uncurry (&&) . BF.bimap onBoard notDef) . assocs
  23   where notDef (Inert,1) = False
  24         notDef _ = True
  25
  26 boardInit :: BoardInit -> Board
  27 boardInit = makeBoard . toList
  28
  29 saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
  30                      , ReactiveValueRead layer Layer IO
  31                      , ReactiveValueRead board Board IO
  32                      , ReactiveValueRead instr InstrumentNo IO) =>
  33                      FilePath -> tempo -> layer -> board -> instr -> IO ()
  34 saveConfiguration fp t l b i = do
  35   tempo <- reactiveValueRead t
  36   layer <- reactiveValueRead l
  37   board <- reactiveValueRead b
  38   instr <- reactiveValueRead i
  39   let bc = BoardConf { confLayer = (layer,instr)
  40                      , confTempo = tempo
  41                      , confBoard = mkInit board
  42                      }
  43   writeFile fp $ show bc
  44
  45 loadConfiguration :: ( ReactiveValueRead tempo Tempo IO
  46                      , ReactiveValueRead layer Layer IO
  47                      , ReactiveValueRead board Board IO
  48                      , ReactiveValueRead instr InstrumentNo IO) =>
  49                      FilePath -> tempo -> layer -> board -> instr -> IO ()
  50 loadConfiguration fp t l b i = do
  51   conf <- readMaybe <$> readFile
  52   if isNothing conf then errorLoad else $ do
  53     let BoardConf { confLayer = (layer,instr)
  54                   , confTempo = tempo
  55                   , confBoard = board
  56                   } = fromJust conf
  57     reactiveValueWrite t tempo
  58     reactiveValueWrite l layer
  59     reactiveValueWrite b $ boardInit board
  60     reactiveValueWrite i instr
  61
  62 errorLoad :: IO ()
  63 errorLoad = undefined