src/RMCA/GUI/Settings.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 module RMCA.GUI.Settings where
   4
   5 import Control.Monad
   6 import Data.Array
   7 import Data.Maybe
   8 import Data.ReactiveValue
   9 import Data.String
  10 import Data.Tuple
  11 import Graphics.UI.Gtk
  12 import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  13 import Graphics.UI.Gtk.Reactive
  14 import RMCA.Auxiliary.RV
  15 import RMCA.GUI.Board
  16 import RMCA.Semantics
  17
  18 comboBoxIndexRV :: (ComboBoxClass box) =>
  19                    box -> ReactiveFieldReadWrite IO Int
  20 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
  21   where getter = comboBoxGetActive box
  22         setter = comboBoxSetActive box
  23         notifier = void . on box changed
  24
  25 pieceButtons :: Array Pos (ReactiveFieldWrite IO GUICell)
  26              -> IOBoard
  27              -> VBox
  28              -> IO VBox
  29 pieceButtons rvArray board pieceBox = do
  30   naBox <- vBoxNew False 10
  31
  32   -- Articulation box
  33   artCombo <- comboBoxNewText
  34   artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
  35                                     (fromString $ show art)
  36                                return (art,i)) [NoAccent ..]
  37   comboBoxSetActive artCombo 0
  38   boxPackStart naBox artCombo PackNatural 10
  39   let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex
  40       artToIndex a = fromMaybe (-1) $ lookup a artIndex
  41       artComboRV = liftRW (bijection (indexToArt,artToIndex)) $
  42                    comboBoxIndexRV artCombo
  43
  44   -- Slide box
  45   slideCombo <- comboBoxNewText
  46   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  47                                       (fromString $ show sli)
  48                                  return (sli,i)) [NoSlide ..]
  49   comboBoxSetActive slideCombo 0
  50   boxPackStart naBox slideCombo PackNatural 10
  51   let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
  52       slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
  53       slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $
  54                      comboBoxIndexRV slideCombo
  55
  56   let displayPieceInfo :: (Int,Int) -> IO ()
  57       displayPieceInfo i = do
  58         print i
  59         when (i `elem` validArea) $ do
  60           let pieceRV = rvArray ! i
  61           piece <- boardGetPiece i board
  62           when (isJust piece) $ do
  63             setRV <- newCBMVarRW $ snd $ fromJust piece
  64             setRV =:> pieceRV
  65             reactiveValueOnCanRead setRV $ updateNaBox $ snd $ fromJust piece
  66       hideNa :: IO ()
  67       hideNa = widgetHide slideCombo >> widgetHide artCombo
  68       showNa :: IO ()
  69       showNa = widgetShow slideCombo >> widgetShow artCombo
  70       updateNaBox :: GUICell -> IO ()
  71       updateNaBox GUICell { cellAction = act } = case act of
  72         Inert -> hideNa
  73         Absorb -> hideNa
  74         _ -> showNa
  75
  76   boardOnClick board displayPieceInfo
  77   boxPackStart pieceBox naBox PackNatural 10
  78   print "Coucou !"
  79   return pieceBox