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           Graphics.UI.Gtk.Reactive
  17 import           RMCA.Auxiliary.RV
  18 import           RMCA.GUI.Board
  19 import           RMCA.Semantics
  20
  21 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
  22 fromMaybeM_ = fromMaybe (return ())
  23
  24 setNAttr :: NoteAttr -> Action -> Action
  25 setNAttr _ Inert = Inert
  26 setNAttr _ Absorb = Absorb
  27 setNAttr na (Stop _) = Stop na
  28 setNAttr na (ChDir b _ dir) = ChDir b na dir
  29 setNAttr na (Split _) = Split na
  30
  31 getNAttr :: Action -> Maybe NoteAttr
  32 getNAttr Inert = Nothing
  33 getNAttr Absorb = Nothing
  34 getNAttr (Stop na) = Just na
  35 getNAttr (ChDir _ na _) = Just na
  36 getNAttr (Split na) = Just na
  37
  38 comboBoxIndexRV :: (ComboBoxClass box) =>
  39                    box -> ReactiveFieldReadWrite IO Int
  40 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
  41   where getter = comboBoxGetActive box
  42         setter = comboBoxSetActive box
  43         notifier = void . on box changed
  44
  45 clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell)
  46               -> IOBoard -> VBox -> IO VBox
  47 clickHandling pieceArrRV board pieceBox = do
  48   naBox <- vBoxNew False 10
  49   boxPackStart pieceBox naBox PackNatural 10
  50
  51   -- Articulation box
  52   artCombo <- comboBoxNewText
  53   artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
  54                                     (fromString $ show art)
  55                                return (art,i)) [NoAccent ..]
  56   comboBoxSetActive artCombo 0
  57   boxPackStart naBox artCombo PackNatural 10
  58   let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex
  59       artToIndex a = fromMaybe (-1) $ lookup a artIndex
  60       artComboRV = liftRW (bijection (indexToArt,artToIndex)) $
  61                    comboBoxIndexRV artCombo
  62
  63   -- Slide box
  64   slideCombo <- comboBoxNewText
  65   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  66                                       (fromString $ show sli)
  67                                  return (sli,i)) [NoSlide ..]
  68   comboBoxSetActive slideCombo 0
  69   boxPackStart naBox slideCombo PackNatural 10
  70   let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
  71       slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
  72       slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $
  73                      comboBoxIndexRV slideCombo
  74
  75   -- Repeat count box
  76   rCountAdj <- adjustmentNew 1 0 10 1 1 0
  77   rCount <- spinButtonNew rCountAdj 1 0
  78   boxPackStart pieceBox rCount PackNatural 10
  79   let rCountRV = spinButtonValueIntReactive rCount
  80
  81   -- Side RV
  82   -- Carries the index of the tile to display and what to display.
  83   setRV <- newCBMVarRW ((0,0),inertCell)
  84
  85   reactiveValueOnCanRead rCountRV $ do
  86     nRCount <- reactiveValueRead rCountRV
  87     (i,oCell) <- reactiveValueRead setRV
  88     let nCell = oCell { repeatCount = nRCount }
  89     reactiveValueWrite setRV (i,nCell)
  90     reactiveValueWrite (pieceArrRV ! i) nCell
  91
  92   reactiveValueOnCanRead slideComboRV $ do
  93     nSlide <- reactiveValueRead slideComboRV
  94     (i,oCell) <- reactiveValueRead setRV
  95     let nCa :: Maybe NoteAttr
  96         nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
  97               (getNAttr $ cellAction oCell)
  98         nCell :: GUICell
  99         nCell = if (isJust nCa)
 100                 then oCell { cellAction =
 101                              setNAttr (fromJust nCa) (cellAction oCell)
 102                            }
 103                 else oCell
 104     reactiveValueWrite setRV (i,nCell)
 105     reactiveValueWrite (pieceArrRV ! i) nCell
 106
 107   reactiveValueOnCanRead artComboRV $ do
 108     --nArt <- reactiveValueRead artComboRV
 109     (i,oCell) <- reactiveValueRead setRV
 110     let nCa :: Maybe NoteAttr
 111         nCa = getNAttr $ cellAction oCell
 112         nCell :: GUICell
 113         nCell = if (isJust nCa)
 114                 then oCell { cellAction =
 115                              setNAttr (fromJust nCa) (cellAction oCell) }
 116                 else oCell
 117     reactiveValueWrite setRV (i,nCell)
 118     reactiveValueWrite (pieceArrRV ! i) nCell
 119
 120   let hideNa :: IO ()
 121       hideNa = do widgetHide slideCombo
 122                   widgetHide artCombo
 123                   widgetShow rCount
 124       showNa :: IO ()
 125       showNa = do widgetShow slideCombo
 126                   widgetShow artCombo
 127                   widgetShow rCount
 128       updateNaBox :: GUICell -> IO ()
 129       updateNaBox GUICell { cellAction = act } = case act of
 130         Inert -> hideNa
 131         Absorb -> hideNa
 132         _ -> showNa
 133
 134   state <- newEmptyMVar
 135   boardOnPress board
 136     (\iPos -> liftIO $ do
 137         postGUIAsync $ void $ tryPutMVar state iPos
 138         return True
 139     )
 140   boardOnRelease board
 141     (\fPos -> liftIO $ do
 142         postGUIAsync $ do
 143           mp <- boardGetPiece fPos board
 144           mstate <- tryTakeMVar state
 145           when (fPos `elem` validArea && isJust mp) $ do
 146             let piece = snd $ fromJust mp
 147             when (maybe False (== fPos) mstate) $ do
 148               boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
 149             nmp <- boardGetPiece fPos board
 150             print nmp
 151             when (isJust nmp) $ do
 152               let nC = snd $ fromJust nmp
 153               reactiveValueWrite setRV (fPos,nC)
 154               fromMaybeM_ $ reactiveValueWrite artComboRV <$>
 155                 naArt <$> getNAttr (cellAction nC)
 156               fromMaybeM_ $ reactiveValueWrite slideComboRV <$>
 157                 ornSlide <$> naOrn <$> getNAttr (cellAction nC)
 158               reactiveValueWrite rCountRV $ repeatCount nC
 159         return True
 160     )
 161
 162   reactiveValueOnCanRead setRV (reactiveValueRead setRV >>=  updateNaBox . snd)
 163
 164   widgetShow pieceBox
 165   widgetShow naBox
 166   return pieceBox