Commit 92e82a94 authored by Guerric Chupin's avatar Guerric Chupin

Little correction to tile rotation.

parent 45073a43
...@@ -33,4 +33,6 @@ html/ ...@@ -33,4 +33,6 @@ html/
*.aux *.aux
*.hp *.hp
*.prof *.prof
*.ps *.ps
\ No newline at end of file *.html
*.folded
\ No newline at end of file
...@@ -88,7 +88,7 @@ varFreqSine :: SF DTime Double ...@@ -88,7 +88,7 @@ varFreqSine :: SF DTime Double
varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/) varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/)
repeatedlyS :: a -> SF DTime (Event a) repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0 repeatedlyS x = edgeBy (\a b -> maybeIf (a * b > 0) $> x) 0
<<< varFreqSine <<^ (2*) <<< varFreqSine <<^ (2*)
-- Similar to onChange but contains its initial value in the first -- Similar to onChange but contains its initial value in the first
......
...@@ -11,6 +11,7 @@ module RMCA.GUI.Board ( GUICell (..) ...@@ -11,6 +11,7 @@ module RMCA.GUI.Board ( GUICell (..)
, fromGUICoords , fromGUICoords
, validArea , validArea
, Player(..) , Player(..)
, actualTile
) where ) where
import Control.Monad import Control.Monad
......
...@@ -60,36 +60,38 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do ...@@ -60,36 +60,38 @@ createNotebook addLayerRV rmLayerRV layerMCBMVar guiCellMCBMVar = do
let clickHandler ioBoard = do let clickHandler ioBoard = do
state <- newEmptyMVar state <- newEmptyMVar
boardOnPress ioBoard boardOnPress ioBoard
(\iPos -> liftIO $ do (\iPos' -> liftIO $ do
let iPos = actualTile iPos'
postGUIAsync $ void $ tryPutMVar state iPos postGUIAsync $ void $ tryPutMVar state iPos
return True return True
) )
boardOnRelease ioBoard boardOnRelease ioBoard
(\fPos -> do (\fPos' -> do
button <- eventButton let fPos = actualTile fPos'
liftIO $ postGUIAsync $ do button <- eventButton
mp <- boardGetPiece fPos ioBoard liftIO $ postGUIAsync $ do
mstate <- tryTakeMVar state mp <- boardGetPiece fPos ioBoard
when (fPos `elem` validArea && isJust mp) $ do mstate <- tryTakeMVar state
let piece = snd $ fromJust mp when (fPos `elem` validArea && isJust mp) $ do
when (button == RightButton && maybe False (== fPos) mstate) $ do let piece = snd $ fromJust mp
let nCell = rotateGUICell piece when (button == RightButton && maybe False (== fPos) mstate) $ do
boardSetPiece fPos (Player,nCell) ioBoard let nCell = rotateGUICell piece
nmp <- boardGetPiece fPos ioBoard boardSetPiece fPos (Player,nCell) ioBoard
when (button == LeftButton && isJust nmp) $ do nmp <- boardGetPiece fPos ioBoard
let nCell = snd $ fromJust nmp when (button == LeftButton && isJust nmp) $ do
mOHid <- tryTakeMVar guiCellHidMVar let nCell = snd $ fromJust nmp
forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar mOHid <- tryTakeMVar guiCellHidMVar
reactiveValueWrite guiCellMCBMVar nCell forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
nHid <- installCallbackMCBMVar guiCellMCBMVar $ do reactiveValueWrite guiCellMCBMVar nCell
cp <- reactiveValueRead curChanRV nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
guiVal <- reactiveValueRead guiCellMCBMVar cp <- reactiveValueRead curChanRV
mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV guiVal <- reactiveValueRead guiCellMCBMVar
when (isNothing mChanRV) $ error "Can't get piece array!" mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
let (_,pieceArrRV,_) = fromJust mChanRV when (isNothing mChanRV) $ error "Can't get piece array!"
reactiveValueWrite (pieceArrRV ! fPos) guiVal let (_,pieceArrRV,_) = fromJust mChanRV
putMVar guiCellHidMVar nHid reactiveValueWrite (pieceArrRV ! fPos) guiVal
return True putMVar guiCellHidMVar nHid
return True
) )
boardCont <- backgroundContainerNew boardCont <- backgroundContainerNew
......
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