]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/Settings.hs
Revert Auxiliary.hs
[tmp/julm/arpeggigon.git] / src / RMCA / GUI / Settings.hs
1 {-# LANGUAGE ScopedTypeVariables, TupleSections #-}
2
3 module RMCA.GUI.Settings where
4
5 import Control.Concurrent.MVar
6 import Control.Monad
7 import Control.Monad.IO.Class
8 import Data.Array
9 import qualified Data.Bifunctor as BF
10 import Data.Maybe
11 import Data.ReactiveValue
12 import Data.String
13 import Data.Tuple
14 import Graphics.UI.Gtk hiding (Action)
15 import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
16 import RMCA.Auxiliary.RV
17 import RMCA.GUI.Board
18 import RMCA.Semantics
19
20 setNAttr :: NoteAttr -> Action -> Action
21 setNAttr _ Inert = Inert
22 setNAttr _ Absorb = Absorb
23 setNAttr na (Stop _) = Stop na
24 setNAttr na (ChDir b _ dir) = ChDir b na dir
25 setNAttr na (Split _) = Split na
26
27 getNAttr :: Action -> Maybe NoteAttr
28 getNAttr Inert = Nothing
29 getNAttr Absorb = Nothing
30 getNAttr (Stop na) = Just na
31 getNAttr (ChDir _ na _) = Just na
32 getNAttr (Split na) = Just na
33
34 comboBoxIndexRV :: (ComboBoxClass box) =>
35 box -> ReactiveFieldReadWrite IO Int
36 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
37 where getter = comboBoxGetActive box
38 setter = comboBoxSetActive box
39 notifier = void . on box changed
40
41 clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell)
42 -> IOBoard -> VBox -> IO VBox
43 clickHandling pieceArrRV board pieceBox = do
44 naBox <- vBoxNew False 10
45 boxPackStart pieceBox naBox PackNatural 10
46
47 -- Articulation box
48 artCombo <- comboBoxNewText
49 artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
50 (fromString $ show art)
51 return (art,i)) [NoAccent ..]
52 comboBoxSetActive artCombo 0
53 boxPackStart naBox artCombo PackNatural 10
54 let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex
55 artToIndex a = fromMaybe (-1) $ lookup a artIndex
56 artComboRV = liftRW (bijection (indexToArt,artToIndex)) $
57 comboBoxIndexRV artCombo
58
59 -- Slide box
60 slideCombo <- comboBoxNewText
61 slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
62 (fromString $ show sli)
63 return (sli,i)) [NoSlide ..]
64 comboBoxSetActive slideCombo 0
65 boxPackStart naBox slideCombo PackNatural 10
66 let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
67 slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
68 slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $
69 comboBoxIndexRV slideCombo
70
71
72 state <- newEmptyMVar
73
74 -- Side RV
75 setRV <- newCBMVarRW ((0,0),inertCell)
76
77 reactiveValueOnCanRead slideComboRV $ do
78 nSlide <- reactiveValueRead slideComboRV
79 (i,oCell) <- reactiveValueRead setRV
80 let nCa :: Maybe NoteAttr
81 nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
82 (getNAttr $ cellAction oCell)
83 nCell :: GUICell
84 nCell = if (isJust nCa)
85 then oCell { cellAction =
86 setNAttr (fromJust nCa) (cellAction oCell)
87 }
88 else oCell
89 reactiveValueWrite setRV (i,nCell)
90
91 reactiveValueOnCanRead artComboRV $ do
92 nArt <- reactiveValueRead artComboRV
93 (i,oCell) <- reactiveValueRead setRV
94 let nCa :: Maybe NoteAttr
95 nCa = getNAttr $ cellAction oCell
96 nCell :: GUICell
97 nCell = if (isJust nCa)
98 then oCell { cellAction =
99 setNAttr (fromJust nCa) (cellAction oCell) }
100 else oCell
101 reactiveValueWrite setRV (i,nCell)
102
103 let hideNa :: IO ()
104 hideNa = widgetHide slideCombo >> widgetHide artCombo
105 showNa :: IO ()
106 showNa = widgetShow slideCombo >> widgetShow artCombo
107 updateNaBox :: GUICell -> IO ()
108 updateNaBox GUICell { cellAction = act } = case act of
109 Inert -> hideNa
110 Absorb -> hideNa
111 _ -> showNa
112
113 boardOnPress board
114 (\iPos -> liftIO $ do
115 postGUIAsync $ void $ tryPutMVar state iPos
116 return True
117 )
118 boardOnRelease board
119 (\fPos -> liftIO $ do
120 postGUIAsync $ do
121 mp <- boardGetPiece fPos board
122 mstate <- tryTakeMVar state
123 when (fPos `elem` validArea && isJust mp) $ do
124 let piece = snd $ fromJust mp
125 when (maybe False (== fPos) mstate) $ do
126 boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
127 nmp <- boardGetPiece fPos board
128 when (isJust nmp) $ reactiveValueWrite setRV $ (fPos,snd $ fromJust nmp)
129 return True
130 )
131
132 reactiveValueOnCanRead setRV $ do
133 (i,c) <- reactiveValueRead setRV
134 reactiveValueWrite (pieceArrRV ! i) c
135 updateNaBox c
136 widgetShow pieceBox >> widgetShow naBox
137 return pieceBox