From d54f059b9ba93c239cea04362dee6729fccd3f49 Mon Sep 17 00:00:00 2001
From: Guerric Chupin <guerric.chupin@gmail.com>
Date: Wed, 29 Jun 2016 15:05:55 +0100
Subject: [PATCH] Unstable and non working setting display.

---
 src/RMCA/Auxiliary/RV.hs |  7 ++++
 src/RMCA/GUI/Board.hs    | 27 +++++++++++---
 src/RMCA/GUI/GUI.hs      |  1 -
 src/RMCA/GUI/Settings.hs | 79 ++++++++++++++++++++++++++++++++++++++++
 src/RMCA/Main.hs         | 66 ++++++++++++++++++---------------
 src/RMCA/Semantics.hs    |  6 +--
 6 files changed, 146 insertions(+), 40 deletions(-)
 delete mode 100644 src/RMCA/GUI/GUI.hs
 create mode 100644 src/RMCA/GUI/Settings.hs

diff --git a/src/RMCA/Auxiliary/RV.hs b/src/RMCA/Auxiliary/RV.hs
index 79095d7..c5acdab 100644
--- a/src/RMCA/Auxiliary/RV.hs
+++ b/src/RMCA/Auxiliary/RV.hs
@@ -35,6 +35,13 @@ onTick notif rv = ReactiveFieldRead getter notifier
         notifier cb = do
           reactiveValueOnCanRead notif cb
           reactiveValueOnCanRead rv cb
+
+addHandlerR :: (ReactiveValueRead a b m) =>
+                  a
+               -> (m () -> m())
+               -> ReactiveFieldRead m b
+addHandlerR x h = ReactiveFieldRead (reactiveValueRead x)
+                  (\p -> reactiveValueOnCanRead x p >> h p)
 {-
 notif ^:> rv =
   reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ()))
diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs
index b7a5817..b75cd67 100644
--- a/src/RMCA/GUI/Board.hs
+++ b/src/RMCA/GUI/Board.hs
@@ -35,6 +35,8 @@ rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
 
 newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
 
+type IOBoard = BIO.Board Int Tile (Player,GUICell)
+
 data Tile = Tile
 data Player = Player deriving(Show)
 
@@ -115,6 +117,12 @@ na = NoteAttr {
           naOrn = Ornaments Nothing [] NoSlide
       }
 
+inertCell :: GUICell
+inertCell = GUICell { cellAction = Inert
+                    , repeatCount = 1
+                    , asPh = False
+                    }
+
 initGUIBoard :: GUIBoard
 initGUIBoard = GUIBoard GameState
   { curPlayer'   = Player
@@ -158,9 +166,6 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where
                                                  , asPh = ph
                                                  }
             | otherwise = inertCell
-            where inertCell = GUICell { cellAction = Inert
-                                      , repeatCount = 1
-                                      , asPh = False}
 
   applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
     GUIBoard $ game { boardPieces' = bp' }
@@ -199,14 +204,15 @@ initGame = do
 -- for the playheads. Also installs some handlers for pieces modification.
 initBoardRV :: BIO.Board Int Tile (Player,GUICell)
             -> IO ( ReactiveFieldRead IO Board
+                  , Array Pos (ReactiveFieldWrite IO GUICell)
                   , ReactiveFieldReadWrite IO [PlayHead])
-initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
+initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do
   -- RV creation
   phMVar <- newCBMVar []
   notBMVar <- mkClockRV 100
   let getterB :: IO Board
       getterB = do
-        (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
+        (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray
         let board = makeBoard $
               map (BF.first fromGUICoords .
                    BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
@@ -247,7 +253,16 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
 
       b = ReactiveFieldRead getterB notifierB
       ph = ReactiveFieldReadWrite setterP getterP notifierP
-  return (b,ph)
+
+      setterW :: (Int,Int) -> GUICell -> IO ()
+      setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board
+
+      arrW :: Array Pos (ReactiveFieldWrite IO GUICell)
+      arrW = array (minimum validArea, maximum validArea)
+             [(i, ReactiveFieldWrite (setterW i))
+             | i <- (validArea :: [(Int,Int)])]
+
+  return (b,arrW,ph)
 
 clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO ()
 clickHandling board = do
diff --git a/src/RMCA/GUI/GUI.hs b/src/RMCA/GUI/GUI.hs
deleted file mode 100644
index df71d6c..0000000
--- a/src/RMCA/GUI/GUI.hs
+++ /dev/null
@@ -1 +0,0 @@
-module RMCA.GUI.GUI where
diff --git a/src/RMCA/GUI/Settings.hs b/src/RMCA/GUI/Settings.hs
new file mode 100644
index 0000000..9e613f5
--- /dev/null
+++ b/src/RMCA/GUI/Settings.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module RMCA.GUI.Settings where
+
+import Control.Monad
+import Data.Array
+import Data.Maybe
+import Data.ReactiveValue
+import Data.String
+import Data.Tuple
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
+import Graphics.UI.Gtk.Reactive
+import RMCA.Auxiliary.RV
+import RMCA.GUI.Board
+import RMCA.Semantics
+
+comboBoxIndexRV :: (ComboBoxClass box) =>
+                   box -> ReactiveFieldReadWrite IO Int
+comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
+  where getter = comboBoxGetActive box
+        setter = comboBoxSetActive box
+        notifier = void . on box changed
+
+pieceButtons :: Array Pos (ReactiveFieldWrite IO GUICell)
+             -> IOBoard
+             -> VBox
+             -> IO VBox
+pieceButtons rvArray board pieceBox = do
+  naBox <- vBoxNew False 10
+
+  -- Articulation box
+  artCombo <- comboBoxNewText
+  artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
+                                    (fromString $ show art)
+                               return (art,i)) [NoAccent ..]
+  comboBoxSetActive artCombo 0
+  boxPackStart naBox artCombo PackNatural 10
+  let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex
+      artToIndex a = fromMaybe (-1) $ lookup a artIndex
+      artComboRV = liftRW (bijection (indexToArt,artToIndex)) $
+                   comboBoxIndexRV artCombo
+
+  -- Slide box
+  slideCombo <- comboBoxNewText
+  slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
+                                      (fromString $ show sli)
+                                 return (sli,i)) [NoSlide ..]
+  comboBoxSetActive slideCombo 0
+  boxPackStart naBox slideCombo PackNatural 10
+  let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
+      slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
+      slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $
+                     comboBoxIndexRV slideCombo
+
+  let displayPieceInfo :: (Int,Int) -> IO ()
+      displayPieceInfo i = do
+        print i
+        when (i `elem` validArea) $ do
+          let pieceRV = rvArray ! i
+          piece <- boardGetPiece i board
+          when (isJust piece) $ do
+            setRV <- newCBMVarRW $ snd $ fromJust piece
+            setRV =:> pieceRV
+            reactiveValueOnCanRead setRV $ updateNaBox $ snd $ fromJust piece
+      hideNa :: IO ()
+      hideNa = widgetHide slideCombo >> widgetHide artCombo
+      showNa :: IO ()
+      showNa = widgetShow slideCombo >> widgetShow artCombo
+      updateNaBox :: GUICell -> IO ()
+      updateNaBox GUICell { cellAction = act } = case act of
+        Inert -> hideNa
+        Absorb -> hideNa
+        _ -> showNa
+
+  boardOnClick board displayPieceInfo
+  boxPackStart pieceBox naBox PackNatural 10
+  print "Coucou !"
+  return pieceBox
diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs
index b349037..92f8cf4 100644
--- a/src/RMCA/Main.hs
+++ b/src/RMCA/Main.hs
@@ -2,34 +2,36 @@
 
 module Main where
 
-import           Control.Concurrent
-import           Data.Array.IO
-import           Data.Array.MArray
-import           Data.ReactiveValue
-import           FRP.Yampa
-import           Game.Board.BasicTurnGame
-import           Graphics.UI.Gtk
-import           Graphics.UI.Gtk.Board.BoardLink
-import           Graphics.UI.Gtk.Board.TiledBoard
-import qualified Graphics.UI.Gtk.Board.TiledBoard           as BIO
-import           Graphics.UI.Gtk.Layout.BackgroundContainer
-import           Graphics.UI.Gtk.Reactive
-import           Hails.Yampa
-import           RMCA.Auxiliary.Concurrent
-import           RMCA.Auxiliary.RV
-import           RMCA.Global.Clock
-import           RMCA.GUI.Board
-import           RMCA.GUI.Buttons
-import           RMCA.Layer.Board
-import           RMCA.Layer.Layer
-import           RMCA.Semantics
-import           RMCA.Translator.Jack
-import           RMCA.Translator.Message
-import           RMCA.Translator.Translator
-
-
-import           Control.Monad
-import           Data.Ratio
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Array
+import Data.Array.IO
+import Data.Array.MArray
+import Data.Maybe
+import Data.ReactiveValue
+import Data.String
+import Data.Tuple
+import FRP.Yampa
+import Game.Board.BasicTurnGame
+import Graphics.UI.Gtk
+import Graphics.UI.Gtk.Board.BoardLink
+import Graphics.UI.Gtk.Board.TiledBoard
+import Graphics.UI.Gtk.Layout.BackgroundContainer
+import Graphics.UI.Gtk.Reactive
+import Hails.Yampa
+import RMCA.Auxiliary.Concurrent
+import RMCA.Auxiliary.RV
+import RMCA.Global.Clock
+import RMCA.GUI.Board
+import RMCA.GUI.Buttons
+import RMCA.GUI.Settings
+import RMCA.Layer.Board
+import RMCA.Layer.Layer
+import RMCA.Semantics
+import RMCA.Translator.Jack
+import RMCA.Translator.Message
+import RMCA.Translator.Translator
 
 floatConv :: (ReactiveValueReadWrite a b m,
               Real c, Real b, Fractional c, Fractional b) =>
@@ -178,7 +180,7 @@ main = do
   -- Board setup
   layer <- reactiveValueRead layerRV
   tempo <- reactiveValueRead tempoRV
-  (boardRV, phRV) <- initBoardRV guiBoard
+  (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
   clickHandling guiBoard
   reactiveValueOnCanRead playRV
     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
@@ -203,6 +205,10 @@ main = do
   -- Jack setup
   forkIO $ jackSetup tempoRV (constR 0) boardQueue
   widgetShowAll window
+  -- Piece characteristic
+  --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10
+  ------------------------------------------------------------
+
+  boxPackStart settingsBox pieceBox PackNatural 10
   onDestroy window mainQuit
   mainGUI
-  --return ()
diff --git a/src/RMCA/Semantics.hs b/src/RMCA/Semantics.hs
index 08c42a6..4deb830 100644
--- a/src/RMCA/Semantics.hs
+++ b/src/RMCA/Semantics.hs
@@ -186,7 +186,7 @@ data Articulation = NoAccent
                   | Accent13
                   | Accent14
                   | Accent24
-                  deriving (Eq, Show)
+                  deriving (Eq, Show, Enum)
 
 accentStrength = 1.2
 
@@ -239,7 +239,7 @@ data Ornaments = Ornaments {
     ornSlide :: SlideType
 } deriving Show
 
-data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show)
+data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show, Enum)
 
 noOrn :: Ornaments
 noOrn = Ornaments { ornPC = Nothing
@@ -332,7 +332,7 @@ data Action = Inert                   -- No action, play heads move through.
             | Stop  NoteAttr          -- Play note then remove play head.
             | ChDir Bool NoteAttr Dir -- Play note then change direction.
             | Split NoteAttr          -- Play note then split head into five.
-            deriving Show
+            deriving (Show)
 
 
 -- Cells
-- 
2.47.2