module FreeGame.Util (
tick,
foreverTick,
foreverFrame,
untick,
untickInfinite,
randomness,
degrees,
radians,
unitV2,
angleV2,
loadPictureFromFile,
loadBitmaps,
loadBitmapsWith,
charToKey,
keyChar,
keySpecial
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Free.Class
import Control.Monad.Trans.Iter
import Control.Monad.Trans
import Control.Monad.Free.Church
import Data.Char
import Data.Void
import FreeGame.Data.Bitmap
import FreeGame.Class
import FreeGame.Types
import Language.Haskell.TH
import Linear
import System.Directory
import System.FilePath
import System.IO.Unsafe
import System.Random
import System.Environment
tick :: (Monad f, MonadFree f m) => m ()
tick = delay (return ())
foreverTick :: (Monad f, MonadFree f m) => m a -> m any
foreverTick m = let m' = foreverTick m in m >> wrap (return m')
foreverFrame :: (Monad f, Monad m, MonadTrans t, MonadFree f (t m)) => m a -> t m any
foreverFrame m = foreverTick (lift m)
untick :: (Functor f, MonadFree f m) => IterT (F f) a -> m (Either (IterT (F f) a) a)
untick = liftM (either Right Left) . iterM wrap . runIterT where
untickInfinite :: (Functor f, MonadFree f m) => IterT (F f) Void -> m (IterT (F f) Void)
untickInfinite = liftM (either absurd id) . iterM wrap . runIterT where
unitV2 :: Floating a => a -> V2 a
unitV2 t = V2 (cos t) (sin t)
angleV2 :: RealFloat a => V2 a -> a
angleV2 (V2 a b) = atan2 b a
randomness :: (Random r, FromFinalizer m) => (r, r) -> m r
randomness r = embedIO $ randomRIO r
degrees :: Floating a => a -> a
degrees x = x / pi * 180
radians :: Floating a => a -> a
radians x = x / 180 * pi
loadPictureFromFile :: (Picture2D p, FromFinalizer m) => FilePath -> m (p ())
loadPictureFromFile = embedIO . fmap bitmap . readBitmap
loadBitmapsWith :: ExpQ -> FilePath -> Q [Dec]
loadBitmapsWith getFullPath path = do
loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
paths <- runIO $ getFileList loc
sequence $ do
p <- paths
let name = pathToName p
[ return $ SigD (mkName name) (ConT ''Bitmap)
, funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
]
where
load name fp = do
runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
(varE '(>>=))
(varE 'readBitmap)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706
loadBitmaps :: FilePath -> Q [Dec]
loadBitmaps path = do
v <- newName "v"
loadBitmapsWith (lamE [varP v] $
appsE [varE 'fmap, uInfixE
(infixE Nothing (varE '(</>)) (Just (varE v)))
(varE '(.))
(varE 'takeDirectory)
, varE 'getExecutablePath]) path
#else
loadBitmaps :: FilePath -> Q [Dec]
loadBitmaps path = loadBitmapsWith (varE 'return) path
#endif
getFileList :: FilePath -> IO [FilePath]
getFileList path = do
allContents <- filter notHidden `fmap` getDirectoryContents path
files <- filterM (doesFileExist . (path</>)) allContents
dirs <- filterM (doesDirectoryExist . (path</>)) allContents
fmap ((files++).concat) $ forM dirs $ \i -> map (i</>) `fmap` getFileList (path</>i)
where
notHidden ('.':_) = False
notHidden _ = True
pathToName :: FilePath -> String
pathToName = ('_':) . map p where
p c | isAlphaNum c = c
| otherwise = '_'
charToKey :: Char -> Key
charToKey ch
| isAlpha ch = toEnum $ fromEnum KeyA + fromEnum ch fromEnum 'A'
| isDigit ch = toEnum $ fromEnum Key0 + fromEnum ch fromEnum '0'
charToKey '-' = KeyMinus
charToKey ',' = KeyComma
charToKey '.' = KeyPeriod
charToKey '/' = KeySlash
charToKey ' ' = KeySpace
charToKey '\'' = KeyApostrophe
charToKey '\\' = KeyBackslash
charToKey '=' = KeyEqual
charToKey ';' = KeySemicolon
charToKey '[' = KeyLeftBracket
charToKey ']' = KeyRightBracket
charToKey '`' = KeyGraveAccent
charToKey '\n' = KeyEnter
charToKey '\r' = KeyEnter
charToKey '\t' = KeyTab
charToKey _ = KeyUnknown
keyChar :: Keyboard f => Char -> f Bool
keyChar = keyPress . charToKey
keySpecial :: Keyboard f => Key -> f Bool
keySpecial = keyPress