# LANGUAGE TemplateHaskell , CPP #
-----------------------------------------------------------------------------
-- |
-- Module      :  FreeGame.Util
  Copyright    :   ( C ) 2013   
-- License     :  BSD-style (see the file LICENSE)
--
  Maintainer   :     <  > 
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------

module FreeGame.Util (
    -- * Controlling
    delay,
    tick,
    foreverTick,
    foreverFrame,
    untick,
    untickInfinite,
    -- * Random
    randomness,
    -- * Helper
    degrees,
    radians,
    unitV2,
    angleV2,
    -- * Loading
    loadPictureFromFile,
    loadBitmaps,
    loadBitmapsWith,
    -- * Keyboard
    charToKey,
    keyChar,
    keySpecial
    ) where

import Control.Monad
import Control.Monad.Free.Class
import Control.Monad.Trans.Iter
import Control.Monad.Trans
import Data.Char
import Data.Void
import FreeGame.Backend.GLFW
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

-- | Delimit the computation to yield a frame.
tick :: (Monad f, MonadFree f m) => m ()
tick = delay (return ())

-- | An infinite loop that run 'tick' every frame after the given action.
foreverTick :: Game a -> Game any
foreverTick m = let m' = foreverTick m in m >> wrap (return m')

-- | @foreverFrame :: Frame a -> Game any@
foreverFrame :: Frame a -> Game any
foreverFrame m = foreverTick (Game $ lift m)

-- | Extract the next frame of the action.
untick :: Game a -> Frame (Either (Game a) a)
untick = fmap (either Right (Left . Game)) . runIterT . unGame where

-- | An infinite version of 'untick'.
untickInfinite :: Game Void -> Frame (Game Void)
untickInfinite = fmap (either absurd Game) . runIterT . unGame where

-- | An unit vector with the specified angle.
unitV2 :: Floating a => a -> V2 a
unitV2 t = V2 (cos t) (sin t)

-- | An angle of the given vector.
angleV2 :: RealFloat a => V2 a -> a
angleV2 (V2 a b) = atan2 b a

-- | Get a given range of value.
randomness :: (Random r, MonadIO m) => (r, r) -> m r
randomness r = liftIO $ randomRIO r
# INLINE randomness #

-- | Convert radians to degrees.
degrees :: Floating a => a -> a
# INLINE degrees #
degrees x = x / pi * 180

-- | Convert degrees to radians.
radians :: Floating a => a -> a
# INLINE radians #
radians x = x / 180 * pi

-- | Create a 'Picture' from the given file.
loadPictureFromFile :: (Picture2D p, MonadIO m) => FilePath -> m (p ())
loadPictureFromFile = liftIO . fmap bitmap . readBitmap

  | The type of the given ' ExpQ ' must be @FilePath - > IO FilePath@ 
-- FIXME: This may cause name duplication if there are multiple non-alphanumeric file names.
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)

-- | Load and define all pictures in the specified directory.
loadBitmaps :: FilePath -> Q [Dec]
loadBitmaps path = loadBitmapsWith (varE 'return) path

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

# DEPRECATED keySpecial " use keyPress instead " #
keySpecial :: Keyboard f => Key -> f Bool
keySpecial = keyPress

---------------------------------------------------------------------------
 |
 Module      :  FreeGame.Util
 License     :  BSD-style (see the file LICENSE)

 Stability   :  experimental
 Portability :  non-portable

--------------------------------------------------------------------------
 * Controlling
 * Random
 * Helper
 * Loading
 * Keyboard
 | Delimit the computation to yield a frame.
 | An infinite loop that run 'tick' every frame after the given action.
 | @foreverFrame :: Frame a -> Game any@
 | Extract the next frame of the action.
 | An infinite version of 'untick'.
 | An unit vector with the specified angle.
 | An angle of the given vector.
 | Get a given range of value.
 | Convert radians to degrees.
 | Convert degrees to radians.
 | Create a 'Picture' from the given file.
 FIXME: This may cause name duplication if there are multiple non-alphanumeric file names.
 | Load and define all pictures in the specified directory.

# LANGUAGE TemplateHaskell , CPP #
  Copyright    :   ( C ) 2013   
  Maintainer   :     <  > 

module FreeGame.Util (
    delay,
    tick,
    foreverTick,
    foreverFrame,
    untick,
    untickInfinite,
    randomness,
    degrees,
    radians,
    unitV2,
    angleV2,
    loadPictureFromFile,
    loadBitmaps,
    loadBitmapsWith,
    charToKey,
    keyChar,
    keySpecial
    ) where

import Control.Monad
import Control.Monad.Free.Class
import Control.Monad.Trans.Iter
import Control.Monad.Trans
import Data.Char
import Data.Void
import FreeGame.Backend.GLFW
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

tick :: (Monad f, MonadFree f m) => m ()
tick = delay (return ())

foreverTick :: Game a -> Game any
foreverTick m = let m' = foreverTick m in m >> wrap (return m')

foreverFrame :: Frame a -> Game any
foreverFrame m = foreverTick (Game $ lift m)

untick :: Game a -> Frame (Either (Game a) a)
untick = fmap (either Right (Left . Game)) . runIterT . unGame where

untickInfinite :: Game Void -> Frame (Game Void)
untickInfinite = fmap (either absurd Game) . runIterT . unGame 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, MonadIO m) => (r, r) -> m r
randomness r = liftIO $ randomRIO r
# INLINE randomness #

degrees :: Floating a => a -> a
# INLINE degrees #
degrees x = x / pi * 180

radians :: Floating a => a -> a
# INLINE radians #
radians x = x / 180 * pi

loadPictureFromFile :: (Picture2D p, MonadIO m) => FilePath -> m (p ())
loadPictureFromFile = liftIO . fmap bitmap . readBitmap

  | The type of the given ' ExpQ ' must be @FilePath - > IO FilePath@ 
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)

loadBitmaps :: FilePath -> Q [Dec]
loadBitmaps path = loadBitmapsWith (varE 'return) path

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

# DEPRECATED keySpecial " use keyPress instead " #
keySpecial :: Keyboard f => Key -> f Bool
keySpecial = keyPress
