]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Configuration.hs
Merge branch 'master' of gitlab.com:chupin/reactogon
[tmp/julm/arpeggigon.git] / src / RMCA / Configuration.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, PartialTypeSignatures,
2 ScopedTypeVariables #-}
3
4 module RMCA.Configuration where
5
6 import Control.Arrow
7 import Control.Exception
8 import Data.Array
9 import qualified Data.IntMap as M
10 import Data.List
11 import Data.Maybe
12 import Data.ReactiveValue
13 import Graphics.UI.Gtk
14 import RMCA.Auxiliary
15 import RMCA.GUI.Board
16 import RMCA.GUI.MultiBoard
17 import RMCA.Layer.Layer
18 import RMCA.Semantics
19 import Text.Read
20
21 type InstrumentNo = Int
22
23 data BoardConf = BoardConf { confLayers :: [(BoardInit,Layer,InstrumentNo)]
24 , confTempo :: Tempo
25 } deriving(Read,Show)
26
27 newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
28
29 mkInit :: Board -> BoardInit
30 mkInit = BoardInit . filter (uncurry (&&) . (onBoard *** notDef)) . assocs
31 where notDef (Inert,1) = False
32 notDef _ = True
33
34 boardInit :: BoardInit -> Board
35 boardInit = makeBoard . toList
36
37 saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
38 , ReactiveValueRead layer (M.IntMap Layer) IO
39 , ReactiveValueRead board (M.IntMap Board) IO
40 , ReactiveValueRead instr (M.IntMap InstrumentNo) IO) =>
41 FilePath -> tempo -> layer -> board -> instr -> IO ()
42 saveConfiguration fp t l b i = do
43 tempo <- reactiveValueRead t
44 layers <- M.elems <$> reactiveValueRead l
45 boards <- map mkInit <$> M.elems <$> reactiveValueRead b
46 instrs <- M.elems <$> reactiveValueRead i
47 let bc = BoardConf { confLayers = zip3 boards layers instrs
48 , confTempo = tempo
49 }
50 catch (writeFile fp $ show bc) (\(_ :: IOError) -> errorSave)
51
52 -- Current solution to delete all existing layers is to write to the
53 -- rm button, which is not that nice.
54 loadConfiguration :: ( ReactiveValueWrite tempo Tempo IO
55 , ReactiveValueWrite layer (M.IntMap Layer) IO
56 , ReactiveValueWrite cell GUICell IO
57 , ReactiveValueWrite instr (M.IntMap InstrumentNo) IO
58 , ReactiveValueWrite addLayer () IO
59 , ReactiveValueWrite rmLayer () IO
60 , ReactiveValueRead boards (M.IntMap (Array Pos cell)) IO) =>
61 FilePath -> tempo -> layer
62 -> boards -> instr -> addLayer -> rmLayer -> IO ()
63 loadConfiguration fp t l arrs i addLayer rmLayer = do
64 conf <- readMaybe <$> readFile fp
65 if isNothing conf then errorLoad else
66 do let BoardConf { confLayers = cl
67 , confTempo = tempo
68 } = fromJust conf
69 (boards,layers,instrs) = unzip3 cl
70 layNum = length cl
71 sequence_ $ replicate maxLayers $ reactiveValueWrite rmLayer ()
72 sequence_ $ replicate layNum $ reactiveValueWrite addLayer ()
73 reactiveValueWrite t tempo
74 reactiveValueWrite l $ M.fromList $ zip [1..] layers
75 reactiveValueWrite i $ M.fromList $ zip [1..] instrs
76 cellArrs <- reactiveValueRead arrs
77 mapM_ (\(arr,board) ->
78 do mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
79 (\(_ :: ErrorCall) -> return ())) $ elems arr
80 mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! toGUICoords p) $
81 inertCell { cellAction = a
82 , repeatCount = r
83 }) board
84 ) $ M.intersectionWith (,) cellArrs
85 $ M.fromList $ zip [1..] $ map (\(BoardInit b) -> b) boards
86
87 errorLoad :: IO ()
88 errorLoad = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
89 "Error loading the configuration file!" >>= widgetShow
90
91 errorSave :: IO ()
92 errorSave = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
93 "Error saving the configuration file!" >>= widgetShow
94
95 handleSaveLoad :: ( ReactiveValueReadWrite tempo Tempo IO
96 , ReactiveValueReadWrite layer (M.IntMap Layer) IO
97 , ReactiveValueWrite cell GUICell IO
98 , ReactiveValueReadWrite instr (M.IntMap InstrumentNo) IO
99 , ReactiveValueWrite addLayer () IO
100 , ReactiveValueWrite rmLayer () IO
101 , ReactiveValueRead boards (M.IntMap (Array Pos cell)) IO
102 , ReactiveValueRead load () IO
103 , ReactiveValueRead save () IO
104 , ReactiveValueRead board (M.IntMap Board) IO) =>
105 tempo -> board -> layer -> instr
106 -> boards -> addLayer -> rmLayer -> save -> load -> IO ()
107 --handleSaveLoad :: _
108 handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV addLayerRV rmLayerRV confSaveRV confLoadRV = do
109 fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
110 FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
111 reactFilt <- fileFilterNew
112 fileFilterAddPattern reactFilt "*.react"
113 fileFilterSetName reactFilt "RMCA conf files."
114 fileChooserAddFilter fcs reactFilt
115
116 fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
117 FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
118 fileChooserAddFilter fcl reactFilt
119
120 reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
121 widgetShowAll fcs
122 let respHandle ResponseOk =
123 fileChooserGetFilename fcs >>= fromMaybeM_ .
124 fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
125 respHandle _ = return ()
126
127 onResponse fcs (\r -> respHandle r >> widgetHide fcs)
128 return ()
129
130 reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
131 widgetShowAll fcl
132 let respHandle ResponseOk =
133 fileChooserGetFilename fcl >>= fromMaybeM_ .
134 fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV
135 addLayerRV rmLayerRV )
136 respHandle _ = return ()
137
138 onResponse fcl (\r -> respHandle r >> widgetHide fcl)
139
140 return ()