Commit 948d6fea authored by Guerric Chupin's avatar Guerric Chupin

Playheads all correct.

parent 811a6382
......@@ -28,19 +28,21 @@ emptyRW rv = do
emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
emptyW rv = reactiveValueWrite rv mempty
(^:>) :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
a -> c -> m ()
{-
notif ^:> rv = reactiveValueOnCanRead notif resync
where resync = reactiveValueRead rv >>= reactiveValueWrite rv
-}
onTick :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
a -> c -> ReactiveFieldRead m d
onTick notif rv = ReactiveFieldRead getter notifier
where getter = reactiveValueRead rv
notifier cb = do
reactiveValueOnCanRead notif cb
reactiveValueOnCanRead rv cb
{-
notif ^:> rv =
reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ()))
-}
-- Update when the value is an Event. It would be nice to have that
-- even for Maybe as well.
(>:>) :: (ReactiveValueRead a (Event b) m, ReactiveValueWrite c b m) =>
a -> c -> m ()
(>:>) :: (ReactiveValueRead a (Event b) IO, ReactiveValueWrite c b IO) =>
a -> c -> IO ()
eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
where syncOnEvent = do
erv <- reactiveValueRead eventRV
......@@ -115,10 +117,11 @@ liftR4 f a b c d = ReactiveFieldRead getter notifier
x3 <- reactiveValueRead c
x4 <- reactiveValueRead d
return $ f (x1, x2, x3, x4)
notifier p = reactiveValueOnCanRead a p >>
reactiveValueOnCanRead b p >>
reactiveValueOnCanRead c p >>
reactiveValueOnCanRead d p
notifier p = do
reactiveValueOnCanRead a p
reactiveValueOnCanRead b p
reactiveValueOnCanRead c p
reactiveValueOnCanRead d p
liftW4 :: ( Monad m
, ReactiveValueWrite a b m
......
......@@ -18,12 +18,13 @@ import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
import RMCA.Global.Clock
import RMCA.Semantics
data GUICell = GUICell { cellAction :: Action
, repeatCount :: Int
, asPh :: Bool
}
} deriving(Show)
newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
......@@ -88,7 +89,9 @@ initGUIBoard = GUIBoard GameState
{ curPlayer' = Player
, boardPos = boardToTile
, boardPieces' = boardToPiece [] $
makeBoard [((0,5), mkCell (ChDir True na NE))]
makeBoard [((0,0), mkCell (ChDir True na NE)),
((2,1), mkCellRpt (ChDir False na NW) 3),
((0,2), mkCell (ChDir False na S))]
}
instance PlayableGame GUIBoard Int Tile Player GUICell where
......@@ -159,8 +162,10 @@ initGame = do
initBoardRV :: BIO.Board Int Tile (Player,GUICell)
-> IO ( ReactiveFieldRead IO Board
, ReactiveFieldReadWrite IO [PlayHead])
initBoardRV BIO.Board { boardPieces = GameBoard array } = do
initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
phMVar <- newCBMVar []
oldphMVar <- newCBMVar []
notBMVar <- mkClockRV 100
let getterB :: IO Board
getterB = do
(boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
......@@ -172,21 +177,35 @@ initBoardRV BIO.Board { boardPieces = GameBoard array } = do
return board
notifierB :: IO () -> IO ()
notifierB _ = return ()
notifierB = reactiveValueOnCanRead notBMVar
getterP :: IO [PlayHead]
getterP = readCBMVar phMVar
setterP :: [PlayHead] -> IO ()
setterP lph = do
let phPosS = map phPos lph
readCBMVar phMVar >>= writeCBMVar oldphMVar
oph <- readCBMVar oldphMVar
writeCBMVar phMVar lph
boardArray <- getAssocs array
let phPosS = map (toGUICoords . phPos) lph
updatePh :: ((Int,Int),Maybe (Player,GUICell)) -> IO ()
updatePh (i,c) = when (isJust c) $ do
let (_,c') = fromJust c
writeArray array i (Just (Player,c' { asPh = i `elem` phPosS }))
mapM_ updatePh boardArray
let offPh :: PlayHead -> IO ()
offPh ph = do
let pos = toGUICoords $ phPos ph
piece <- boardGetPiece pos board
when (isJust piece) $ do
let (_,c) = fromJust piece
boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board
onPh :: PlayHead -> IO ()
onPh ph = do
let pos = toGUICoords $ phPos ph
piece <- boardGetPiece pos board
when (isJust piece) $ do
let (_,c) = fromJust piece
boardSetPiece pos (Player, c { asPh = True }) board
mapM_ offPh oph
print oph
mapM_ onPh lph
print lph
notifierP :: IO () -> IO ()
notifierP = installCallbackCBMVar phMVar
......@@ -200,15 +219,15 @@ fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
( return f'
, pixbufNewFromFile f' >>=
\p -> pixbufScaleSimple p hexW hexW InterpBilinear ))
(["hexOn.png","stop.svg","split.svg"] ++
(["hexOn.png","hexOff.png","stop.svg","split.svg"] ++
concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
| d <- [N .. NW]])
actionToFile :: GUICell -> FilePath
actionToFile GUICell { cellAction = a
, asPh = bool
, asPh = ph
} =
case (a,bool) of
case (a,ph) of
(Inert,True) -> "img/hexOn.png"
(Inert,False) -> "img/hexOff.png"
(Absorb,_) -> "img/stop.svg"
......
......@@ -27,6 +27,7 @@ import Data.Array.MArray
import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
import Data.Array.IO
import Control.Monad
import Data.Ratio
......@@ -34,7 +35,7 @@ floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
a -> ReactiveFieldReadWrite m c
floatConv = liftRW $ bijection (realToFrac, realToFrac)
{-
boardRVIO = newCBMVarRW $
makeBoard [((0,0), mkCell (ChDir True na1 NE)),
((1,1), mkCellRpt (ChDir False na1 NW) 3),
......@@ -68,9 +69,7 @@ na3 = NoteAttr {
bpb :: Int
bpb = 4
newTempoRV :: IO (ReactiveFieldReadWrite IO Tempo)
newTempoRV = newCBMVarRW 200
-}
main :: IO ()
main = do
......@@ -152,10 +151,10 @@ main = do
layerRV =
liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
buttonBox <- hBoxNew True 10
boxPackEnd settingsBox buttonBox PackNatural 0
buttonPlay <- buttonNewFromStock gtkMediaPlay
let playRV = buttonActivateField buttonPlay
boxPackStart buttonBox buttonPlay PackRepel 0
buttonPause <- buttonNewFromStock gtkMediaPause
boxPackStart buttonBox buttonPause PackRepel 0
......@@ -179,21 +178,26 @@ main = do
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(boardRV, phRV) <- initBoardRV guiBoard
reactiveValueOnCanRead playRV
(reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
board <- reactiveValueRead boardRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, [], tempo) boardSF
(splitE >>> fst) `liftR` outBoard >:> phRV
ph <- reactiveValueRead phRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
(splitE >>> fst) <^> outBoard >:> phRV
--reactiveValueOnCanRead phRV $ boardRefresh guiBoard
let inRV = liftR4 id
boardRV layerRV phRV tempoRV
clock <- mkClockRV 100
clock ^:> inRV
--let inRV = onTick clock inRV
inRV =:> inBoard
--reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
reactiveValueOnCanRead outBoard $ do
bq <- reactiveValueRead boardQueue
ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
reactiveValueWrite boardQueue (bq ++ ob)
-- /!\ To be removed.
--reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . \(_,_,ph,_) -> ph)
--reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
reactiveValueOnCanRead phRV (reactiveValueRead phRV >>= print)
putStrLn "Board started."
-- Jack setup
forkIO $ jackSetup tempoRV (constR 0) boardQueue
......
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