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