{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Play.Engine.Utils where
import Data.Word (Word8)
import SDL.Vect (V4(..), V2(..))
import qualified SDL.Vect as Vect (Point(..))
import qualified SDL
import qualified SDL.Font as SDLF
import qualified Data.Text as T
import qualified Foreign.C.Types as C (CInt)
import Control.Lens
import Control.DeepSeq
import Prelude hiding (head)
import qualified Data.List as List
import Control.Lens (over, (^.))
import Data.List (group, sort)
import qualified Data.DList as DL
import Play.Engine.Types
firstM :: Functor f => (a -> f c) -> (a, b) -> f (c, b)
firstM f (a, b) = (, b) <$> f a
replicateMChain :: Monad m => Int -> (a -> m a) -> a -> m a
replicateMChain n f x'
| n <= 0 = return x'
| otherwise = f x' >>= replicateMChain (n-1) f
maybeToEither :: a -> Maybe b -> Either a b
maybeToEither _ (Just y') = Right y'
maybeToEither x' Nothing = Left x'
duplicates :: Ord a => [a] -> [a]
duplicates = map List.head . filter ((>1) . length) . group . sort
splitBy :: Eq a => a -> [a] -> [[a]]
splitBy v vs = map reverse $ go [] vs
where go ws [] = [ws]
go ws (z:zs)
| z == v = ws : go [] zs
| otherwise = go (z:ws) zs
supplyBoth :: (a -> b -> c) -> (b -> a) -> b -> c
supplyBoth = (=<<)
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) f g a b = f (g a b)
absPoint :: IPoint -> IPoint
absPoint = fmap abs
addPoint :: (NFData a, Num a) => Point a -> Point a -> Point a
addPoint (Point x1 y1) (Point x2 y2) = force $ Point (x1 + x2) (y1 + y2)
{-# INLINE addPoint #-}
mulPoint :: (NFData a, Num a) => Point a -> Point a -> Point a
mulPoint (Point x1 y1) (Point x2 y2) = force $ Point (x1 * x2) (y1 * y2)
{-# INLINE mulPoint #-}
updateList :: (a -> [a]) -> DL.DList a -> DL.DList a
updateList f = DL.foldr (\a acc -> DL.fromList (f a) `DL.append` acc) DL.empty
updateListWith :: NFData b => b -> (b -> b -> b) -> (a -> ([a], b)) -> DL.DList a -> (DL.DList a, b)
updateListWith start combine f = flip DL.foldr (DL.empty, start) $ \a !acc ->
case (f a, acc) of
(([], b), (aacc, bacc)) -> (aacc, force $ combine bacc b)
((xs, b), (aacc, bacc)) -> (DL.fromList xs `DL.append` aacc, force $ combine bacc b)
toRect :: IPoint -> Size -> SDL.Rectangle C.CInt
toRect posi sz =
SDL.Rectangle
(Vect.P . uncurry V2 . over both fromIntegral . pointToTuple $ posi)
(uncurry V2 . over both fromIntegral . sizeToTuple $ sz)
data HasPosSize
= HasPosSize
{ _pos :: !IPoint
, _size :: !Size
}
deriving Show
makeFieldsNoPrefix ''HasPosSize
data Hitbox
= Hitbox
{ _alignment :: {-# UNPACK #-} !IPoint
, _size :: {-# UNPACK #-} !Size
}
deriving (Eq, Show)
makeFieldsNoPrefix ''Hitbox
data HasHitBox
= HasHitBox
{ _hitbox :: !Hitbox
}
deriving Show
makeFieldsNoPrefix ''HasHitBox
circ' = HasPosSize
{ _pos = Point 356 795
, _size = Point 12 12
}
rec' = HasHitBox
{ _hitbox = Hitbox
{ _alignment = Point 346 830
, _size = Point 21 64
}
}
isTouchingCircleRect
:: (HasPos circle IPoint, HasSize circle Size, HasPos rect IPoint, HasHitbox rect Hitbox)
=> circle -> rect -> Maybe (circle, rect)
isTouchingCircleRect circle rect =
let
circleDistance =
Point
( abs
$ circle ^. pos . x
- (rect ^. pos . x + rect ^. hitbox . alignment . x)
- (rect ^. hitbox . size . x) `div` 2
)
( abs
$ circle ^. pos . y
- (rect ^. pos . y + rect ^. hitbox . alignment . y)
- (rect ^. hitbox . size . y) `div` 2
)
cornerDistance_sq =
(+)
((circleDistance ^. x - rect ^. hitbox . size . x `div` 2) ^ 2)
((circleDistance ^. y - rect ^. hitbox . size . y `div` 2) ^ 2)
in if
| circleDistance ^. x > (rect ^. hitbox . size . x `div` 2) + (circle ^. size . x `div` 2) -> Nothing
| circleDistance ^. y > (rect ^. hitbox . size . y `div` 2) + (circle ^. size . y `div` 2) -> Nothing
| circleDistance ^. x <= (rect ^. hitbox . size . x `div` 2) -> Just (circle, rect)
| circleDistance ^. y <= (rect ^. hitbox . size . y `div` 2) -> Just (circle, rect)
| cornerDistance_sq <= (circle ^. size . x `div` 2) ^ 2 -> Just (circle, rect)
| otherwise -> Nothing
isTouchingCircleCircle
:: (HasSize a Size, HasPos a IPoint, HasSize b Size, HasPos b IPoint)
=> a -> b -> Maybe (a,b)
isTouchingCircleCircle a b =
let
getCenter p = (p ^. pos) `addPoint` Point ((p ^. size . x) `div` 2) ((p ^. size . y) `div` 2)
aCenter = getCenter a
bCenter = getCenter b
aRadius = (a ^. size . x) `div` 2 - (a ^. size . x) `div` 8
bRadius = (b ^. size . x) `div` 2 - (b ^. size . x) `div` 8
distX = (aCenter ^. x) - (bCenter ^. x)
distY = (aCenter ^. y) - (bCenter ^. y)
dist = sqrt $ fromIntegral ((distX * distX) + (distY * distY))
in
if dist < fromIntegral (aRadius + bRadius)
then Just (a, b)
else Nothing
fixPos :: (HasSize a Size, HasPos a IPoint) => Size -> a -> a
fixPos wsize entity =
let
x_ = entity ^. pos . x
y_ = entity ^. pos . y
x' =
if x_ <= 0
then 0
else if x_ + (entity ^. size . x) <= (wsize ^. x)
then x_
else (wsize ^. x) - (entity ^. size . x)
y' =
if y_ <= 0
then 0
else if y_ + (entity ^. size . y) <= (wsize ^. y)
then y_
else (wsize ^. y) - (entity ^. size . y)
in
set pos (Point x' y') entity
isInWindow :: Size -> IPoint -> Size -> Bool
isInWindow = isInSquare (Point 0 0)
isInSquare :: IPoint -> Size -> IPoint -> Size -> Bool
isInSquare wpos wsize posi sz
| posi ^. x + sz ^. x < (wpos ^. x) || posi ^. x > wpos ^.x + wsize ^. x
|| posi ^. y + sz ^. y < (wpos ^. y) || posi ^. y > wpos ^.y + wsize ^. y
= False
| otherwise = True
isAround :: IPoint -> IPoint -> Size -> Bool
isAround place posi sz =
isInSquare (place `addPoint` Point (-5) (-5)) sz posi sz
dirToPlace :: IPoint -> IPoint -> IPoint
dirToPlace posi place =
Point (dir x) (negate $ dir y)
where
dir c
| place ^. c > posi ^. c = 1
| place ^. c < posi ^. c = -1
| otherwise = 0
type Camera = IPoint -> IPoint
mkAngles :: Int -> Int -> [Float]
mkAngles initAngle ((`mod` 200) -> n) =
let
m = 360 / fromIntegral n
in
force $ map ((+) (fromIntegral initAngle) . (*) m . fromIntegral) [0..(n-1)]
renderText :: SDL.Renderer -> SDLF.Font -> IPoint -> T.Text -> IO ()
renderText renderer font loc txt =
if T.null txt
then pure ()
else do
texture' <- SDL.createTextureFromSurface renderer
=<< SDLF.solid
font
(V4 255 255 255 255)
txt
ti <- SDL.queryTexture texture'
SDL.copy
renderer
texture'
Nothing
(Just $ toRect
loc
(Point (fromIntegral $ SDL.textureWidth ti) (fromIntegral $ SDL.textureHeight ti))
)
SDL.destroyTexture texture'
shade :: SDL.Renderer -> Camera -> Word8 -> IO ()
shade renderer cam n = do
let
rect = toRect (cam $ Point 0 0) (Point 800 1000)
SDL.rendererDrawColor renderer SDL.$= V4 0 0 0 n
SDL.fillRect renderer (Just rect)
data Stack a = Stack !a ![a]
head :: Stack a -> a
head = fst . pop
push :: a -> Stack a -> Stack a
push !new (Stack !a as) = Stack new (a:as)
init :: a -> Stack a
init = flip Stack []
pop :: Stack a -> (a, Maybe (Stack a))
pop = \case
Stack !a [] -> (a, Nothing)
Stack !a (!b:bs) -> (a `seq` a, pure $! Stack b bs)
replace :: a -> Stack a -> Stack a
replace a = \case
Stack _ as -> Stack (a `seq` a) as