src/RMCA/GUI/MultiBoard.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   2
   3 module RMCA.GUI.MultiBoard where
   4
   5 import Control.Monad
   6 import Data.Array
   7 import Data.ReactiveValue
   8 import Graphics.UI.Gtk
   9 import Graphics.UI.Gtk.Board.BoardLink
  10 import Graphics.UI.Gtk.Layout.BackgroundContainer
  11 import RMCA.Auxiliary
  12 import RMCA.GUI.Board
  13 import RMCA.GUI.NoteSettings
  14 import RMCA.Layer.Layer
  15 import RMCA.Semantics
  16
  17 -- In GTk, a “thing with tabs” has the I think very confusing name
  18 -- Notebook.
  19
  20 createNotebook :: ( ReactiveValueRead addLayer () IO
  21                   , ReactiveValueRead rmLayer () IO
  22                   , ReactiveValueRead layer Layer IO
  23                   , ReactiveValueRead tempo Tempo IO
  24                   ) => addLayer -> rmLayer -> layer -> tempo
  25                -> IO ( Notebook
  26                      , VBox
  27                      , ReactiveFieldRead IO Board
  28                      , Array Pos (ReactiveFieldWrite IO GUICell)
  29                      , ReactiveFieldWrite IO [PlayHead]
  30                      )
  31 createNotebook addLayerRV rmLayerRV layerRV tempoRV = do
  32   n <- notebookNew
  33   --plusImg <- imageNewFromStock gtkMediaAdd IconSizeButton
  34   --notebookAppendPageMenu n undefined plusImg undefined
  35   ------------------------------------------------------------------------------
  36   -- First board
  37   ------------------------------------------------------------------------------
  38   boardCont <- backgroundContainerNew
  39   guiBoard <- attachGameRules =<< initGame
  40   centerBoard <- alignmentNew 0.5 0.5 0 0
  41   containerAdd centerBoard guiBoard
  42   containerAdd boardCont centerBoard
  43
  44   notebookPrependPage n boardCont "Lol first"
  45   notebookPageNumber <- newCBMVarRW 1
  46
  47   layer <- reactiveValueRead layerRV
  48   tempo <- reactiveValueRead tempoRV
  49   (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
  50
  51   pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
  52
  53   ------------------------------------------------------------------------------
  54   -- Following boards
  55   ------------------------------------------------------------------------------
  56
  57   reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
  58     reactiveValueRead notebookPageNumber
  59       >>= reactiveValueWrite notebookPageNumber . (+1)
  60     boardCont <- backgroundContainerNew
  61
  62     guiBoard <- attachGameRules =<< initGame
  63     centerBoard <- alignmentNew 0.5 0.5 0 0
  64     containerAdd centerBoard guiBoard
  65     containerAdd boardCont centerBoard
  66
  67     notebookAppendPage n boardCont "sdlkfhd" >> widgetShowAll n
  68
  69   reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
  70     np <- reactiveValueRead notebookPageNumber
  71     when (np > 1) $ do
  72       notebookRemovePage n =<< notebookGetCurrentPage n
  73
  74       reactiveValueRead notebookPageNumber
  75         >>= reactiveValueWrite notebookPageNumber . (subtract 1)
  76
  77     widgetShowAll n
  78     return ()
  79
  80
  81   ------------------------------------------------------------------------------
  82   -- For good measure
  83   ------------------------------------------------------------------------------
  84   return (n, pieceBox, boardRV, pieceArrRV, phRV)