{-# LANGUAGE DeriveGeneric #-}
module Control.Timer.Tick (
creaTimer,
creaBoolTimer,
creaTimerLoop,
creaBoolTimerLoop,
Timed,
creaTimedRes,
Loop(..),
ExpBehaviour(..),
tick,
ticks,
reset,
isLive,
isExpired,
fetchFrame,
getFrames
)
where
import GHC.Generics (Generic)
data Timed a = TimedRes {
tSteps :: [TimerStep a],
tLoop :: Loop,
tOrigLoop :: Loop,
tLoopTicks :: Integer,
tExpireTicks :: Maybe Integer,
tCurrTick :: Integer,
tExpired :: Bool
}
deriving (Show, Eq, Generic)
type TimerStep a = (Integer, a)
data Loop =
AlwaysLoop
| Times Integer ExpBehaviour
deriving (Show, Eq, Generic)
data ExpBehaviour =
Reach
| Elapse
deriving (Show, Eq, Generic)
instance Functor Timed where
fmap f t = t { tSteps = fmap (\(i, a) -> (i, f a))
(tSteps t) }
creaTimer :: a -> a -> Integer -> Timed a
creaTimer off on i = creaTimedRes (Times 1 Reach) [(i, off), (1, on)]
creaTimerLoop :: a -> a -> Integer -> Timed a
creaTimerLoop off on i = creaTimedRes AlwaysLoop [(i, off), (1, on)]
creaBoolTimer :: Integer -> Timed Bool
creaBoolTimer i = creaTimer False True i
creaBoolTimerLoop :: Integer -> Timed Bool
creaBoolTimerLoop i = creaTimerLoop False True i
creaTimedRes :: Loop -> [(Integer, a)] -> Timed a
creaTimedRes _ [] = error "Cannot create an empty TimedRes"
creaTimedRes l ss = TimedRes ss l l
loopTicks expTicks
0 False
where
loopTicks = sum . map fst $ ss
expTicks = case l of
AlwaysLoop -> Nothing
Times _ Reach -> Just $ sum . map fst $ init ss
Times _ Elapse -> Just $ loopTicks
tick :: Timed a -> Timed a
tick t | isExpired t = t
| willExpire = expire t'
| willLoop = loop t'
| otherwise = t'
where
newTicks = tCurrTick t + 1
t' = t { tCurrTick = newTicks }
willExpire = case tLoop t of
Times 1 _ -> Just newTicks == tExpireTicks t
_ -> False
willLoop = not willExpire &&
newTicks == tLoopTicks t
loop :: Timed a -> Timed a
loop tm = case tLoop tm of
AlwaysLoop -> tm { tCurrTick = 0 }
Times n eb -> tm { tLoop = Times (n-1) eb,
tCurrTick = 0 }
expire :: Timed a -> Timed a
expire tm =
if isElB (tLoop tm)
then expx { tCurrTick = tCurrTick tm - 1 }
else expx
where
expx = case tLoop tm of
Times 1 eb -> tm { tLoop = Times 0 eb,
tExpired = True }
_ -> error "non 1 Times in `expire`"
isElB (Times _ Elapse) = True
isElB _ = False
ticks :: Integer -> Timed a -> Timed a
ticks 1 t = tick t
ticks n t | n < 1 = error "negative number passed to `ticks`"
| otherwise = ticks (n-1) (tick t)
isLive :: Timed a -> Bool
isLive t = not $ tExpired t
isExpired :: Timed a -> Bool
isExpired t = tExpired t
fetchFrame :: Timed a -> a
fetchFrame t = bl !! (fromIntegral $ tCurrTick t)
where
bl = concatMap (\(c, a) -> replicate (fromIntegral c) a) $ tSteps t
getFrames :: Timed a -> [(Integer, a)]
getFrames t = tSteps t
reset :: Timed a -> Timed a
reset t = t { tCurrTick = 0,
tExpired = False,
tLoop = tOrigLoop t }