{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}

module FRP.Yampa.Canvas (reactimateSFinContext) where

import FRP.Yampa

import Data.Time.Clock
import Data.IORef
import Control.Concurrent.STM

import Graphics.Blank hiding (Event)
import qualified Graphics.Blank as Blank

-------------------------------------------------------------------

-- | Redraw the entire canvas.
renderCanvas ::  DeviceContext -> Canvas () -> IO ()
renderCanvas :: DeviceContext -> Canvas () -> IO ()
renderCanvas DeviceContext
context Canvas ()
drawAction = DeviceContext -> Canvas () -> IO ()
forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
context Canvas ()
canvas
  where
    canvas :: Canvas ()
    canvas :: Canvas ()
canvas = do Canvas ()
clearCanvas
                () -> Canvas ()
beginPath ()
                Canvas () -> Canvas ()
forall a. Canvas a -> Canvas a
saveRestore Canvas ()
drawAction

-------------------------------------------------------------------

type Clock = IORef UTCTime

-- | A specialisation of 'FRP.Yampa.reactimate' to Blank Canvas.
--   The arguments are: the Canvas action to get input, the Canvas action to emit output, the signal function to be run, and the device context to use.
reactimateSFinContext
      :: forall a b.
        (Blank.Event -> Canvas (Event a))
     -> (b -> Canvas ())
     -> SF (Event a) b
     -> DeviceContext -> IO ()
reactimateSFinContext :: forall a b.
(Event -> Canvas (Event a))
-> (b -> Canvas ()) -> SF (Event a) b -> DeviceContext -> IO ()
reactimateSFinContext Event -> Canvas (Event a)
interpEvent b -> Canvas ()
putCanvasOutput SF (Event a) b
sf DeviceContext
context =
  do Clock
clock <- IO Clock
newClock

     let getInput :: Bool -> IO (DTime,Maybe (Event a))
         getInput :: Bool -> IO (DTime, Maybe (Event a))
getInput Bool
canBlock =
            do let opt_block :: STM (Maybe a) -> STM (Maybe a)
opt_block STM (Maybe a)
m =
                            if Bool
canBlock
                            then STM (Maybe a)
m
                            else STM (Maybe a)
m STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
`orElse` Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

               Maybe Event
opt_e <- STM (Maybe Event) -> IO (Maybe Event)
forall a. STM a -> IO a
atomically (STM (Maybe Event) -> IO (Maybe Event))
-> STM (Maybe Event) -> IO (Maybe Event)
forall a b. (a -> b) -> a -> b
$ STM (Maybe Event) -> STM (Maybe Event)
forall {a}. STM (Maybe a) -> STM (Maybe a)
opt_block (STM (Maybe Event) -> STM (Maybe Event))
-> STM (Maybe Event) -> STM (Maybe Event)
forall a b. (a -> b) -> a -> b
$ (Event -> Maybe Event) -> STM Event -> STM (Maybe Event)
forall a b. (a -> b) -> STM a -> STM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Event -> Maybe Event
forall a. a -> Maybe a
Just (STM Event -> STM (Maybe Event)) -> STM Event -> STM (Maybe Event)
forall a b. (a -> b) -> a -> b
$ TChan Event -> STM Event
forall a. TChan a -> STM a
readTChan (DeviceContext -> TChan Event
eventQueue DeviceContext
context)
               Event a
ev <- case Maybe Event
opt_e of
                       Maybe Event
Nothing -> Event a -> IO (Event a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Event a
forall a. Event a
NoEvent
                       Just Event
e  -> DeviceContext -> Canvas (Event a) -> IO (Event a)
forall a. DeviceContext -> Canvas a -> IO a
send DeviceContext
context (Event -> Canvas (Event a)
interpEvent Event
e)

               DTime
t <- Clock -> IO DTime
clockTick Clock
clock
               (DTime, Maybe (Event a)) -> IO (DTime, Maybe (Event a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DTime
t, Event a -> Maybe (Event a)
forall a. a -> Maybe a
Just Event a
ev)

         putOutput :: Bool -> b -> IO Bool
         putOutput :: Bool -> b -> IO Bool
putOutput Bool
changed b
b = if Bool
changed
                                 then DeviceContext -> Canvas () -> IO ()
renderCanvas DeviceContext
context (b -> Canvas ()
putCanvasOutput b
b) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                                 else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

     IO (Event a)
-> (Bool -> IO (DTime, Maybe (Event a)))
-> (Bool -> b -> IO Bool)
-> SF (Event a) b
-> IO ()
forall (m :: * -> *) a b.
Monad m =>
m a
-> (Bool -> m (DTime, Maybe a))
-> (Bool -> b -> m Bool)
-> SF a b
-> m ()
reactimate (Event a -> IO (Event a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Event a
forall a. Event a
NoEvent) Bool -> IO (DTime, Maybe (Event a))
getInput Bool -> b -> IO Bool
putOutput SF (Event a) b
sf

-- | Start a new clock.
newClock :: IO Clock
newClock :: IO Clock
newClock = IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO Clock) -> IO Clock
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UTCTime -> IO Clock
forall a. a -> IO (IORef a)
newIORef

-- | Compute the time delta since the last clock tick.
clockTick :: Clock -> IO DTime
clockTick :: Clock -> IO DTime
clockTick Clock
x =
    do UTCTime
t0 <- Clock -> IO UTCTime
forall a. IORef a -> IO a
readIORef Clock
x
       UTCTime
t1 <- IO UTCTime
getCurrentTime
       Clock -> UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef Clock
x UTCTime
t1
       DTime -> IO DTime
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (NominalDiffTime -> DTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t0))

-------------------------------------------------------------------