src/RMCA/GUI/Settings.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   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
  15 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  16 import           Graphics.UI.Gtk.Reactive
  17 import           RMCA.Auxiliary.RV
  18 import           RMCA.GUI.Board
  19 import           RMCA.Semantics
  20
  21 comboBoxIndexRV :: (ComboBoxClass box) =>
  22                    box -> ReactiveFieldReadWrite IO Int
  23 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
  24   where getter = comboBoxGetActive box
  25         setter = comboBoxSetActive box
  26         notifier = void . on box changed
  27
  28 clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell)
  29               -> IOBoard -> VBox -> IO VBox
  30 clickHandling pieceArrRV board pieceBox = do
  31   naBox <- vBoxNew False 10
  32   boxPackStart pieceBox naBox PackNatural 10
  33
  34   -- Articulation box
  35   artCombo <- comboBoxNewText
  36   artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
  37                                     (fromString $ show art)
  38                                return (art,i)) [NoAccent ..]
  39   comboBoxSetActive artCombo 0
  40   boxPackStart naBox artCombo PackNatural 10
  41   let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex
  42       artToIndex a = fromMaybe (-1) $ lookup a artIndex
  43       artComboRV = liftRW (bijection (indexToArt,artToIndex)) $
  44                    comboBoxIndexRV artCombo
  45
  46   -- Slide box
  47   slideCombo <- comboBoxNewText
  48   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  49                                       (fromString $ show sli)
  50                                  return (sli,i)) [NoSlide ..]
  51   comboBoxSetActive slideCombo 0
  52   boxPackStart naBox slideCombo PackNatural 10
  53   let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
  54       slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
  55       slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $
  56                      comboBoxIndexRV slideCombo
  57
  58
  59   state <- newEmptyMVar
  60   boardOnPress board
  61     (\iPos -> liftIO $ do
  62         postGUIAsync $ void $ tryPutMVar state iPos
  63         return True
  64     )
  65   boardOnRelease board
  66     (\fPos -> liftIO $ do
  67         postGUIAsync $ do
  68           mp <- boardGetPiece fPos board
  69           mstate <- tryTakeMVar state
  70           when (fPos `elem` validArea && isJust mp) $ do
  71             when (maybe False (== fPos) mstate) $
  72               boardSetPiece fPos (BF.second rotateGUICell $
  73                                   fromJust mp) board
  74             let hideNa :: IO ()
  75                 hideNa = widgetHide slideCombo >> widgetHide artCombo
  76                 showNa :: IO ()
  77                 showNa = widgetShow slideCombo >> widgetShow artCombo
  78                 updateNaBox :: GUICell -> IO ()
  79                 updateNaBox GUICell { cellAction = act } = case act of
  80                   Inert -> hideNa
  81                   Absorb -> hideNa
  82                   _ -> print "Show!" >> showNa
  83                 pieceRV = pieceArrRV ! fPos
  84                 piece = snd $ fromJust mp
  85             updateNaBox piece
  86             setRV <- newCBMVarRW $ piece
  87             reactiveValueOnCanRead slideComboRV $ do
  88               nSlide <- reactiveValueWrite slideComboRV
  89               oCell <- reactiveValueRead setRV
  90               reactiveValueWrite setRV (setSlide oCell nSlide)
  91             setRV =:> pieceRV
  92             reactiveValueOnCanRead setRV $ updateNaBox $ piece
  93         return True
  94     )
  95   widgetShow pieceBox >> widgetShow naBox
  96   return pieceBox