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