free-game-1.2: FreeGame/Class.hs

{-# LANGUAGE BangPatterns, Rank2Types, DeriveFunctor #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  FreeGame.Class
-- Copyright   :  (C) 2013 Fumiaki Kinoshita
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module FreeGame.Class where

import Linear
import FreeGame.Types
import FreeGame.Data.Bitmap
import Data.Color
import Data.Coerce
import Control.Bool
import qualified Data.Map as Map

infixr 5 `translate`
infixr 5 `rotateR`
infixr 5 `rotateD`
infixr 5 `scale`
infixr 5 `color`
infixr 5 `thickness`
infixr 5 `blendMode`

class Functor p => Affine p where
    -- | (radians)
    rotateR :: Double -> p a -> p a
    -- | (degrees)
    rotateD :: Double -> p a -> p a
    scale :: Vec2 -> p a -> p a
    translate :: Vec2 -> p a -> p a

    rotateR = rotateD . (* 180) . (/ pi)
    rotateD = rotateR . (/ 180) . (* pi)

-- | The class of types that can be regarded as a kind of picture.
class Affine p => Picture2D p where
    -- | Construct a 'Picture2D' from a 'Bitmap'.
    bitmap :: Bitmap -> p ()
    -- | Same as 'bitmap', but it does not create a cache.
    bitmapOnce :: Bitmap -> p ()
    line :: [Vec2] -> p ()
    polygon :: [Vec2] -> p ()
    polygonOutline :: [Vec2] -> p ()
    circle :: Double -> p ()
    circleOutline :: Double -> p ()
    thickness :: Float -> p a -> p a
    color :: Color Float -> p a -> p a
    blendMode :: BlendMode -> p a -> p a

class Affine p => Local p where
    getLocation :: p (Location a)

data Location a = Location (Vec2 -> Vec2) (Vec2 -> Vec2) deriving Functor

coerceLocation :: Location a -> Location b
coerceLocation = coerce

flipLocation :: Location a -> Location b
flipLocation (Location f g) = Location g f

localize :: Local f => Vec2 -> f Vec2
localize v = (\(Location _ g) -> g v) <$> getLocation

globalize :: Local f => Vec2 -> f Vec2
globalize v = (\(Location f _) -> f v) <$> getLocation

instance Affine Location where
    translate v (Location f g) = Location (f . (^+^v)) ((^-^v) . g)
    rotateR t (Location f g) = Location (f . rot2 t) (rot2 (-t) . g)
    scale v (Location f g) = Location (f . (*v)) ((/v) . g)

rot2 :: Floating a => a -> V2 a -> V2 a
rot2 t (V2 x y) = V2 (p * x + q * y) (-q * x + p * y) where
    !p = cos t
    !q = sin t

data ButtonState = Down | Press | Up | Release　| ChatterDown | ChatterUp

buttonDown :: ButtonState -> ButtonState
buttonDown Release = Down
buttonDown Up = ChatterDown
buttonDown ChatterUp = ChatterDown
buttonDown x = x

buttonUp :: ButtonState -> ButtonState
buttonUp Press = Up
buttonUp Down = ChatterUp
buttonUp ChatterDown = ChatterUp
buttonUp x = x

buttonStay :: ButtonState -> ButtonState
buttonStay Down = Press
buttonStay Press = Press
buttonStay Up = Release
buttonStay Release = Release
buttonStay ChatterDown = Press
buttonStay ChatterUp = Release

isDown :: ButtonState -> Bool
isDown Down = True
isDown ChatterDown = True
isDown ChatterUp = True
isDown _ = False

isUp :: ButtonState -> Bool
isUp Up = True
isUp ChatterUp = True
isUp ChatterDown = True
isUp _ = False

isPressed :: ButtonState -> Bool
isPressed Down = True
isPressed ChatterUp = True
isPressed Press = True
isPressed ChatterDown = True
isPressed _ = False

class Functor f => Keyboard f where
    keyStates_ :: f (Map.Map Key ButtonState)

keyStates :: Keyboard f => f (Map.Map Key Bool)
keyStates = Map.map isPressed <$> keyStates_

keyPress :: Keyboard f => Key -> f Bool
keyPress k = isPressed <$> (Map.! k) <$> keyStates_

keyDown :: Keyboard f => Key -> f Bool
keyDown k = isDown <$> (Map.! k) <$> keyStates_

keyUp :: Keyboard f => Key -> f Bool
keyUp k = isUp <$> (Map.! k) <$> keyStates_

class Functor f => Mouse f where
    globalMousePosition :: f Vec2
    mouseButtons_ :: f (Map.Map Int ButtonState)
    mouseInWindow :: f Bool
    mouseScroll :: f Vec2

-- | Returns the relative coordinate of the cursor.
mousePosition :: (Applicative f, Mouse f, Local f) => f Vec2
mousePosition = (\v (Location _ g) -> g v) <$> globalMousePosition <*> getLocation

mousePositionMay :: (Applicative f, Mouse f, Local f) => f (Maybe Vec2)
mousePositionMay = guard' <$> mouseInWindow <*> mousePosition

mouseButtons :: Mouse f => f (Map.Map Int Bool)
mouseButtons = Map.map isPressed <$> mouseButtons_

mouseButton :: Mouse f => Int -> f Bool
mouseButton k = isPressed <$> (Map.! k) <$> mouseButtons_

mouseDown :: Mouse f => Int -> f Bool
mouseDown k = isDown <$> (Map.! k) <$> mouseButtons_

mouseUp :: Mouse f => Int -> f Bool
mouseUp k = isUp <$> (Map.! k) <$> mouseButtons_

mouseButtonL :: Mouse f => f Bool
mouseButtonL = mouseButton 0

mouseButtonR :: Mouse f => f Bool
mouseButtonR = mouseButton 1

mouseButtonM :: Mouse f => f Bool
mouseButtonM = mouseButton 2

mouseDownL :: Mouse f => f Bool
mouseDownL = mouseDown 0

mouseDownR :: Mouse f => f Bool
mouseDownR = mouseDown 1

mouseDownM :: Mouse f => f Bool
mouseDownM = mouseDown 2

mouseUpL :: Mouse f => f Bool
mouseUpL = mouseUp 0

mouseUpR :: Mouse f => f Bool
mouseUpR = mouseUp 1

mouseUpM :: Mouse f => f Bool
mouseUpM = mouseUp 2