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