Commit d54f059b authored by Guerric Chupin's avatar Guerric Chupin

Unstable and non working setting display.

parent 98a8180a
......@@ -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 ()))
......
......@@ -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
......
module RMCA.GUI.GUI where
{-# 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
......@@ -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 ()
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment