Commit 811a6382 authored by Guerric Chupin's avatar Guerric Chupin

Compiles but crashes.

parent 9d0446fe
......@@ -6,6 +6,7 @@ import Data.CBMVar
import Data.ReactiveValue
import FRP.Yampa
import Control.Monad
import RMCA.Auxiliary.Curry
newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
newCBMVarRW val = do
......@@ -27,10 +28,14 @@ emptyRW rv = do
emptyW :: (Monoid b, ReactiveValueWrite a b m) => a -> m ()
emptyW rv = reactiveValueWrite rv mempty
(^:>) :: (ReactiveValueRead a b m, ReactiveValueReadWrite c d m) =>
(^:>) :: (ReactiveValueRead a b m, ReactiveValueRead c d m) =>
a -> c -> m ()
{-
notif ^:> rv = reactiveValueOnCanRead notif resync
where resync = reactiveValueRead rv >>= reactiveValueWrite rv
-}
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.
......@@ -40,7 +45,7 @@ eventRV >:> rv = reactiveValueOnCanRead eventRV syncOnEvent
where syncOnEvent = do
erv <- reactiveValueRead eventRV
when (isEvent erv) $ reactiveValueWrite rv $ fromEvent erv
{-
liftR3 :: ( Monad m
, ReactiveValueRead a b m
, ReactiveValueRead c d m
......@@ -59,6 +64,7 @@ liftR3 f a b c = ReactiveFieldRead getter notifier
notifier p = reactiveValueOnCanRead a p >>
reactiveValueOnCanRead b p >>
reactiveValueOnCanRead c p
-}
liftW3 :: ( Monad m
, ReactiveValueWrite a b m
......@@ -76,6 +82,21 @@ liftW3 f a b c = ReactiveFieldWrite setter
reactiveValueWrite b x2
reactiveValueWrite c x3
liftRW3 :: ( Monad m
, ReactiveValueReadWrite a b m
, ReactiveValueReadWrite c d m
, ReactiveValueReadWrite e f m) =>
BijectiveFunc i (b,d,f)
-> a
-> c
-> e
-> ReactiveFieldReadWrite m i
liftRW3 bij a b c =
ReactiveFieldReadWrite setter getter notifier
where ReactiveFieldRead getter notifier = liftR3 (curry3 f2) a b c
ReactiveFieldWrite setter = liftW3 f1 a b c
(f1, f2) = (direct bij, inverse bij)
liftR4 :: ( Monad m
, ReactiveValueRead a b m
, ReactiveValueRead c d m
......
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables,
TypeSynonymInstances #-}
module RMCA.GUI.Board where
import Control.Monad
import Data.Array
import qualified Data.Bifunctor as BF
import Data.Array.MArray
import qualified Data.Bifunctor as BF
import Data.Board.GameBoardIO
import Data.CBMVar
import Data.Maybe
import Data.Ratio
import Data.ReactiveValue
import Debug.Trace
import Game.Board.BasicTurnGame
import Graphics.UI.Gtk hiding (Action)
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.Semantics
import Debug.Trace
data GUICell = GUICell { cellAction :: Action
, repeatCount :: Int
, asPh :: Bool
}
newtype GUIBoard = GUIBoard { toGS :: (GameState Int Tile Player Action) }
newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell }
data Tile = Tile
data Player = Player deriving(Show)
-- Takes a GUI coordinate and give the corresponding coordinate on the
-- internal board
fromGUICoords :: (Int,Int) -> (Int,Int)
fromGUICoords (x,y) = (x,(x `mod` 2 - y) `quot` 2)
-- Takes coordinates from the point of view of the internal board and
-- translates them to GUI board coordinates.
toGUICoords :: (Int,Int) -> (Int,Int)
toGUICoords (x,y) = (x,2*(-y) + x `mod` 2)
tileW :: Int
tileW = 40
......@@ -40,11 +61,21 @@ boardToTile :: [(Int,Int,Tile)]
boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin)
, (xMax+1,yMax+1))]
boardToPiece :: Board -> [(Int,Int,Player,Action)]
boardToPiece = map placePiece . filter (onBoard . fst) . assocs
where placePiece :: (Pos,Cell) -> (Int,Int,Player,Action)
placePiece ((x,y),(a,_)) = let y' = 2*(-y) + x `mod` 2 in
(x,y',Player,a)
boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)]
boardToPiece ph = map placePiece . filter (onBoard . fst) . assocs
where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell)
placePiece ((x,y),(a,n)) = let y' = 2*(-y) + x `mod` 2
c = GUICell { cellAction = a
, repeatCount = n
, asPh = (x,y) `elem` phPosS
}
in (x,y',Player,c)
phPosS = map phPos ph
validArea :: Board -> [(Int,Int)]
validArea = map (\(x,y,_,_) -> (x,y)) . boardToPiece []
na = NoteAttr {
naArt = Accent13,
......@@ -53,27 +84,28 @@ na = NoteAttr {
}
initGUIBoard :: GUIBoard
initGUIBoard = GUIBoard $ GameState
initGUIBoard = GUIBoard GameState
{ curPlayer' = Player
, boardPos = boardToTile
, boardPieces' = boardToPiece $ makeBoard [((0,5), mkCell (ChDir True na NE))]
, boardPieces' = boardToPiece [] $
makeBoard [((0,5), mkCell (ChDir True na NE))]
}
instance PlayableGame GUIBoard Int Tile Player Action where
instance PlayableGame GUIBoard Int Tile Player GUICell where
curPlayer _ = Player
allPos (GUIBoard game) = boardPos game
allPieces (GUIBoard game) = boardPieces' game
moveEnabled _ = True
canMove (GUIBoard game) _ (x,y)
| Just (_,p) <- getPieceAt game (x,y)
, Inert <- p = False
, GUICell { cellAction = Inert } <- p = False
| otherwise = True
canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea
where validArea = map (\(x',y',_,_) -> (x',y')) $ boardToPiece $ makeBoard []
where validArea = map (\(x',y',_,_) -> (x',y')) $ boardToPiece [] $
makeBoard []
move _ _ iPos@(_,yi) (xf,yf) = [ MovePiece iPos fPos'
, AddPiece iPos Player Inert]
move (GUIBoard game) _ iPos@(_,yi) (xf,yf) = [ MovePiece iPos fPos'
, AddPiece iPos Player nCell]
where fPos'
| (xf `mod` 2 == 0 && yf `mod` 2 == 0)
|| (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
......@@ -81,16 +113,24 @@ instance PlayableGame GUIBoard Int Tile Player Action where
signum' x
| x == 0 = 1
| otherwise = signum x
nCell
| Just (_,GUICell { asPh = ph, repeatCount = n }) <-
getPieceAt game iPos = inertCell { repeatCount = n
, 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' }
where bp' = (x,y,Player,piece):(boardPieces' game)
where bp' = (x,y,Player,piece):boardPieces' game
applyChange (GUIBoard game) (RemovePiece (x,y)) = GUIBoard $
game { boardPieces' = bp' }
where bp' = [p | p@(x',y',_,_) <- boardPieces' game
, (x /= x' || y /= y')]
, x /= x' || y /= y']
applyChange guiBoard@(GUIBoard game) (MovePiece iPos fPos)
| Just (_,p) <- getPieceAt game iPos
......@@ -99,12 +139,12 @@ instance PlayableGame GUIBoard Int Tile Player Action where
, AddPiece fPos Player p]
| otherwise = guiBoard
initGame :: IO (Game GUIBoard Int Tile Player Action)
initGame :: IO (Game GUIBoard Int Tile Player GUICell)
initGame = do
pixbufs <- fileToPixbuf
tilePixbuf <- pixbufNew ColorspaceRgb False 8 tileW tileH
pixbufFill tilePixbuf 50 50 50 0
let pixPiece :: (Player,Action) -> Pixbuf
let pixPiece :: (Player,GUICell) -> Pixbuf
pixPiece (_,a) = fromJust $ lookup (actionToFile a) pixbufs
pixTile :: Tile -> Pixbuf
pixTile _ = tilePixbuf
......@@ -116,21 +156,63 @@ initGame = do
return $ Game visualA initGUIBoard
initBoardRV :: BIO.Board Int Tile (Player,GUICell)
-> IO ( ReactiveFieldRead IO Board
, ReactiveFieldReadWrite IO [PlayHead])
initBoardRV BIO.Board { boardPieces = GameBoard array } = do
phMVar <- newCBMVar []
let getterB :: IO Board
getterB = do
(boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array
let board = makeBoard $
map (BF.first fromGUICoords .
BF.second ((\(_,c) -> (cellAction c,repeatCount c)) .
fromJust)) $
filter (isJust . snd) boardArray
return board
notifierB :: IO () -> IO ()
notifierB _ = return ()
getterP :: IO [PlayHead]
getterP = readCBMVar phMVar
setterP :: [PlayHead] -> IO ()
setterP lph = do
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
notifierP :: IO () -> IO ()
notifierP = installCallbackCBMVar phMVar
b = ReactiveFieldRead getterB notifierB
ph = ReactiveFieldReadWrite setterP getterP notifierP
return (b,ph)
fileToPixbuf :: IO [(FilePath,Pixbuf)]
fileToPixbuf = sequence $
map (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,))
( return f'
, pixbufNewFromFile f' >>=
\p -> pixbufScaleSimple p hexW hexW InterpBilinear )) $
["hexOn.png","stop.svg","split.svg"] ++
concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
| d <- [N .. NW]]
actionToFile :: Action -> FilePath
actionToFile a = case a of
Inert -> "img/hexOn.png"
Absorb -> "img/stop.svg"
Stop _ -> "img/stop.svg"
ChDir True _ d -> "img/start" ++ show d ++ ".svg"
ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
Split _ -> "img/split.svg"
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"] ++
concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"]
| d <- [N .. NW]])
actionToFile :: GUICell -> FilePath
actionToFile GUICell { cellAction = a
, asPh = bool
} =
case (a,bool) of
(Inert,True) -> "img/hexOn.png"
(Inert,False) -> "img/hexOff.png"
(Absorb,_) -> "img/stop.svg"
(Stop _,_) -> "img/stop.svg"
(ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg"
(ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg"
(Split _,_) -> "img/split.svg"
......@@ -19,26 +19,21 @@ import Debug.Trace
-- The state of the board is described by the list of the playheads
-- and the different actions onto the board.
boardAction :: [PlayHead]
-> SF ((Board, Layer), Event BeatNo) (Event ([PlayHead], [Note]))
boardAction ph = proc ((board, Layer { relPitch = rp
, strength = s
, beatsPerBar = bpb
}), ebno) ->
boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo) (Event ([PlayHead], [Note]))
boardAction = proc ((board, Layer { relPitch = rp
, strength = s
, beatsPerBar = bpb
},ph), ebno) ->
arr $ fmap (uncurry5 advanceHeads)
-< ebno `tag` (board, fromEvent ebno, rp, s, ph)
--returnA -< traceShow e e
{-
boardSF :: SF (Board, Layer, Tempo) (Event [Note])
boardSF = proc (board, l, t) -> do
boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
boardSF = proc (board, l, ph, t) -> do
ebno <- layerMetronome -< (t, l)
iph <- startHeads -< board
boardSF' iph -< (board, l, ebno)
where boardSF' :: [PlayHead] -> SF (Board, Layer, Event BeatNo) (Event [Note])
boardSF' ph = switch (swap ^<< splitE ^<< boardAction ph)
boardSF'
-}
boardAction -< ((board, l, ph), ebno)
{-
-- We need the list of initial playheads
boardSF :: [PlayHead] -> SF (Board, Layer, Tempo) (Event [Note])
boardSF iph = proc (board, l@Layer { relPitch = rp
......@@ -73,3 +68,4 @@ boardSetup board tempoRV layerRV outBoardRV = do
takeMVar n
return ()
-}
-}
......@@ -23,6 +23,9 @@ import RMCA.GUI.Board
import Graphics.UI.Gtk.Board.BoardLink
import Game.Board.BasicTurnGame
import Graphics.UI.Gtk.Board.TiledBoard
import Data.Array.MArray
import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO
import Data.Array.IO
import Control.Monad
import Data.Ratio
......@@ -164,13 +167,9 @@ main = do
-- Board
boardCont <- backgroundContainerNew
game <- initGame
board <- attachGameRules game
forkIO $ forever $ do
threadDelay (10^6)
p <- boardGetPiece (0,-10) board
print p
guiBoard <- attachGameRules game
--centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd boardCont board
containerAdd boardCont guiBoard
--containerAdd boardCont centerBoard
boxPackStart mainBox boardCont PackNatural 0
--boxPackStart mainBox boardCont PackNatural 0
......@@ -179,19 +178,19 @@ main = do
-- Board setup
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
boardRV <- boardRVIO
(boardRV, phRV) <- initBoardRV guiBoard
board <- reactiveValueRead boardRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
(boardSF $ startHeads board)
let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
boardRV $ pairRW layerRV tempoRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, [], tempo) boardSF
(splitE >>> fst) `liftR` outBoard >:> phRV
let inRV = liftR4 id
boardRV layerRV phRV tempoRV
clock <- mkClockRV 100
clock ^:> inRV
inRV =:> inBoard
--reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
reactiveValueOnCanRead outBoard $ do
bq <- reactiveValueRead boardQueue
ob <- reactiveValueRead $ liftR (event [] id) outBoard
ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
reactiveValueWrite boardQueue (bq ++ ob)
-- /!\ To be removed.
--reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
......
* Lots of things in IO actions (Jack.hs, Main.hs, etc.) should be
written as separate functions (especially on RVs).
* Able to move an inert piece in some unknown conditions. Which
shouldn't happend.
img/hexOff.png

722 Bytes | W: | H:

img/hexOff.png

4.85 KB | W: | H:

img/hexOff.png
img/hexOff.png
img/hexOff.png
img/hexOff.png
  • 2-up
  • Swipe
  • Onion skin
img/hexOn.png

5.16 KB | W: | H:

img/hexOn.png

4.54 KB | W: | H:

img/hexOn.png
img/hexOn.png
img/hexOn.png
img/hexOn.png
  • 2-up
  • Swipe
  • Onion skin
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