Commit 257f5996 authored by Guerric Chupin's avatar Guerric Chupin

Added a few calls to postGUIAsync.

parent 5a2a23d7
cloc|https://github.com/AlDanial/cloc v 1.66 T=0.06 s (404.7 files/s, 32964.5 lines/s)
cloc|https://github.com/AlDanial/cloc v 1.66 T=0.09 s (299.7 files/s, 25153.0 lines/s)
--- | ---
Language|files|blank|comment|code
:-------|-------:|-------:|-------:|-------:
Haskell|26|335|430|1353
Haskell|26|341|439|1402
--------|--------|--------|--------|--------
SUM:|26|335|430|1353
SUM:|26|341|439|1402
......@@ -138,7 +138,7 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where
where fPos'
| (xf `mod` 2 == 0 && yf `mod` 2 == 0)
|| (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf)
| otherwise = (xf,yf)-- (xf,yf+signum' (yf-yi))
| otherwise = (xf,yf+signum' (yf-yi))
signum' x
| x == 0 = 1
| otherwise = signum x
......@@ -194,7 +194,6 @@ initBoardRV :: BIO.Board Int Tile (Player,GUICell)
initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
-- RV creation
phMVar <- newCBMVar []
oldphMVar <- newCBMVar []
notBMVar <- mkClockRV 100
let getterB :: IO Board
getterB = do
......@@ -214,9 +213,7 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
setterP :: [PlayHead] -> IO ()
setterP lph = do
readCBMVar phMVar >>= writeCBMVar oldphMVar
writeCBMVar phMVar lph
oph <- readCBMVar oldphMVar
oph <- readCBMVar phMVar
let phPosS = map phPos lph
offPh :: PlayHead -> IO ()
offPh ph = do
......@@ -224,7 +221,7 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
piece <- boardGetPiece pos board
when (isJust piece) $ do
let (_,c) = fromJust piece
boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board
boardSetPiece pos (Player, c { asPh = False }) board
onPh :: PlayHead -> IO ()
onPh ph = do
let pos = toGUICoords $ phPos ph
......@@ -232,8 +229,9 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do
when (isJust piece) $ do
let (_,c) = fromJust piece
boardSetPiece pos (Player, c { asPh = True }) board
mapM_ offPh oph
mapM_ onPh lph
postGUIAsync $ mapM_ offPh oph
postGUIAsync $ mapM_ onPh lph
writeCBMVar phMVar lph
notifierP :: IO () -> IO ()
notifierP = installCallbackCBMVar phMVar
......@@ -247,17 +245,18 @@ clickHandling board = do
state <- newEmptyMVar
boardOnPress board
(\iPos -> liftIO $ do
tryPutMVar state iPos
postGUIAsync $ void $ tryPutMVar state iPos
return True
)
boardOnRelease board
(\fPos -> liftIO $ do
mp <- boardGetPiece fPos board
mstate <- tryTakeMVar state
when (fPos `elem` validArea && isJust mp &&
maybe False (== fPos) mstate) $ do
boardSetPiece fPos (BF.second rotateGUICell $
fromJust mp) board
postGUIAsync $ do
mp <- boardGetPiece fPos board
mstate <- tryTakeMVar state
when (fPos `elem` validArea && isJust mp &&
maybe False (== fPos) mstate) $ do
boardSetPiece fPos (BF.second rotateGUICell $
fromJust mp) board
return True
)
......
......@@ -14,17 +14,17 @@ tempo = constant
-- The initial value is arbitrary but never appears because the switch
-- is immediate.
metronome :: SF Tempo (Event Beat)
metronome = switch (repeatedly (tempoToDTime 60) ()
metronome = switch (repeatedly (tempoToQNoteIvl 120) ()
&&&
onChange') metronome'
where metronome' :: Tempo -> SF Tempo (Event Beat)
metronome' t = switch (repeatedly (4 * tempoToDTime t) ()
metronome' t = switch (repeatedly (tempoToQNoteIvl t) ()
&&&
onChange) metronome'
-- Tempo is the number of whole notes per minute.
tempoToDTime :: Tempo -> DTime
tempoToDTime = (15/) . fromIntegral
-- Tempo is the number of quarter notes per minute.
tempoToQNoteIvl :: Tempo -> DTime
tempoToQNoteIvl = (15/) . fromIntegral
type TickingClock = (CBMVar (), ThreadId)
......
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
module Main where
import Control.Concurrent
import Data.ReactiveValue
import FRP.Yampa
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import Hails.Yampa
import RMCA.Auxiliary.Concurrent
import RMCA.Auxiliary.RV
import RMCA.Global.Clock
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 Graphics.UI.Gtk.Layout.BackgroundContainer
import RMCA.GUI.Board
import Graphics.UI.Gtk.Board.BoardLink
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.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
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
floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
......
......@@ -29,7 +29,7 @@ noteToMessages layTempo sr chan =
, noteDur = d
}) -> do
nm <- noteOnToMessage chan -< n
let dt = fromRational (d * toRational (tempoToDTime layTempo))
let dt = fromRational (d * toRational (tempoToQNoteIvl layTempo))
dn = floor $ dt * fromIntegral sr
returnA -< [(t,nm),(t + dn,switchOnOff nm)]
......
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