{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeFamilies #-}
module Apecs.Util (
runGC, global,
EntityCounter(..), nextEntity, newEntity,
quantize, flatten, inbounds, region, flatten',
timeSystem, timeSystem_,
forkSys, atomically, sleep
) where
import qualified Control.Concurrent as C
import qualified Control.Concurrent.STM as C
import System.CPUTime
import Control.Applicative (liftA2)
import Control.Monad.Reader
import Data.Monoid
import Data.Semigroup
import System.Mem (performMajorGC)
import Apecs.Core
import Apecs.Stores
import Apecs.System
global :: Entity
global = Entity (-2)
newtype EntityCounter = EntityCounter {getCounter :: Sum Int} deriving (Semigroup, Monoid, Eq, Show)
instance Component EntityCounter where
type Storage EntityCounter = Global EntityCounter
{-# INLINE nextEntity #-}
nextEntity :: (Get w m EntityCounter, Set w m EntityCounter) => SystemT w m Entity
nextEntity = do EntityCounter n <- get global
set global (EntityCounter $ n+1)
return (Entity . getSum $ n)
{-# INLINE newEntity #-}
newEntity :: (Set w m c, Get w m EntityCounter, Set w m EntityCounter)
=> c -> SystemT w m Entity
newEntity c = do ety <- nextEntity
set ety c
return ety
runGC :: System w ()
runGC = lift performMajorGC
{-# INLINE quantize #-}
quantize :: (Fractional (v a), Integral b, RealFrac a, Functor v)
=> v a
-> v a
-> v b
quantize cell vec = floor <$> vec/cell
{-# INLINE flatten #-}
flatten :: (Applicative v, Integral a, Foldable v)
=> v a
-> v a -> Maybe a
flatten size vec = if inbounds size vec then Just (flatten' size vec) else Nothing
{-# INLINE inbounds #-}
inbounds :: (Num a, Ord a, Applicative v, Foldable v)
=> v a
-> v a -> Bool
inbounds size vec = and (liftA2 (\v s -> v >= 0 && v <= s) vec size)
{-# INLINE region #-}
region :: (Enum a, Applicative v, Traversable v)
=> v a
-> v a
-> [v a]
region a b = sequence $ liftA2 enumFromTo a b
{-# INLINE flatten' #-}
flatten' :: (Applicative v, Integral a, Foldable v)
=> v a
-> v a -> a
flatten' size vec = foldr (\(n,x) acc -> n*acc + x) 0 (liftA2 (,) size vec)
timeSystem :: System w a -> System w (Double, a)
timeSystem sys = do
s <- lift getCPUTime
a <- sys
t <- lift getCPUTime
return (fromIntegral (t-s)/1e12, a)
timeSystem_ :: System w a -> System w Double
timeSystem_ = fmap fst . timeSystem
forkSys :: System w () -> System w C.ThreadId
forkSys sys = ask >>= liftIO . C.forkIO . runSystem sys
atomically :: SystemT w C.STM () -> SystemT w IO ()
atomically sys = ask >>= liftIO . C.atomically . runSystem sys
sleep :: Int -> System w ()
sleep = liftIO . C.threadDelay