module Mischief.Animation.Spritesheet where

import Control.Applicative
import Data.List (find, (!?))
import Data.Text (Text)
import GHC.Stack
import GHC.TypeLits
import KDL qualified
import Linear (V2 (V2))
import Mischief.Assets
import Mischief.Assets.Image
import Mischief.ECS
import Mischief.ECS.Utils
import Mischief.Render.Sprite
import Mischief.Render.Sprite.Common

data Spritesheet = Spritesheet
  { Spritesheet -> V2 Int
frameSize :: V2 Int,
    Spritesheet -> V2 Int
padding :: V2 Int,
    Spritesheet -> V2 Int
size :: V2 Int,
    Spritesheet -> AssetRef Image
image :: AssetRef Image
  }
  deriving (Typeable Spritesheet
[HookRel Spritesheet]
[Hook Spritesheet]
Set DefaultComponentType
IsExclusive (IsExclusiveRel Spritesheet)
(Typeable Spritesheet, IsExclusive (IsExclusiveRel Spritesheet)) =>
Set DefaultComponentType
-> [Hook Spritesheet]
-> [Hook Spritesheet]
-> [Hook Spritesheet]
-> [HookRel Spritesheet]
-> [HookRel Spritesheet]
-> [HookRel Spritesheet]
-> Component Spritesheet
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook Spritesheet]
onAdd :: [Hook Spritesheet]
$conSet :: [Hook Spritesheet]
onSet :: [Hook Spritesheet]
$conRemove :: [Hook Spritesheet]
onRemove :: [Hook Spritesheet]
$conAddRel :: [HookRel Spritesheet]
onAddRel :: [HookRel Spritesheet]
$conSetRel :: [HookRel Spritesheet]
onSetRel :: [HookRel Spritesheet]
$conRemoveRel :: [HookRel Spritesheet]
onRemoveRel :: [HookRel Spritesheet]
Component, Int -> Spritesheet -> ShowS
[Spritesheet] -> ShowS
Spritesheet -> String
(Int -> Spritesheet -> ShowS)
-> (Spritesheet -> String)
-> ([Spritesheet] -> ShowS)
-> Show Spritesheet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Spritesheet -> ShowS
showsPrec :: Int -> Spritesheet -> ShowS
$cshow :: Spritesheet -> String
show :: Spritesheet -> String
$cshowList :: [Spritesheet] -> ShowS
showList :: [Spritesheet] -> ShowS
Show)

noSpritesheet :: KdlRef Spritesheet
noSpritesheet :: KdlRef Spritesheet
noSpritesheet = Spritesheet -> KdlRef Spritesheet
forall a. a -> KdlRef a
KdlValue (Spritesheet -> KdlRef Spritesheet)
-> Spritesheet -> KdlRef Spritesheet
forall a b. (a -> b) -> a -> b
$ Spritesheet {frameSize :: V2 Int
frameSize = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
0 Int
0, padding :: V2 Int
padding = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
0 Int
0, size :: V2 Int
size = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 Int
0 Int
0, image :: AssetRef Image
image = AssetRef Image
forall a. AssetRef a
NullRef}

sheetCoords :: Int -> Spritesheet -> (V2 Int, V2 Int)
sheetCoords :: Int -> Spritesheet -> (V2 Int, V2 Int)
sheetCoords Int
index Spritesheet
sheet = do
  let boxSize :: V2 Int
boxSize = Spritesheet
sheet.padding V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
+ Spritesheet
sheet.frameSize
  let framesPerRow :: Int
framesPerRow = Spritesheet
sheet.size.x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` V2 Int
boxSize.x
  let start :: V2 Int
start = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
V2 (Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
framesPerRow) (Int
index Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
framesPerRow)
  (V2 Int
start V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
* (Spritesheet
sheet.frameSize V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
+ V2 Int
1), Spritesheet
sheet.frameSize)

data AnimationFrames = RangedFrames Int Int | ManualFrames [Int] deriving (Int -> AnimationFrames -> ShowS
[AnimationFrames] -> ShowS
AnimationFrames -> String
(Int -> AnimationFrames -> ShowS)
-> (AnimationFrames -> String)
-> ([AnimationFrames] -> ShowS)
-> Show AnimationFrames
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AnimationFrames -> ShowS
showsPrec :: Int -> AnimationFrames -> ShowS
$cshow :: AnimationFrames -> String
show :: AnimationFrames -> String
$cshowList :: [AnimationFrames] -> ShowS
showList :: [AnimationFrames] -> ShowS
Show)

data AnimationTime = FpsTime Float | TotalTime Float deriving (Int -> AnimationTime -> ShowS
[AnimationTime] -> ShowS
AnimationTime -> String
(Int -> AnimationTime -> ShowS)
-> (AnimationTime -> String)
-> ([AnimationTime] -> ShowS)
-> Show AnimationTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AnimationTime -> ShowS
showsPrec :: Int -> AnimationTime -> ShowS
$cshow :: AnimationTime -> String
show :: AnimationTime -> String
$cshowList :: [AnimationTime] -> ShowS
showList :: [AnimationTime] -> ShowS
Show)

data Animation = Animation {Animation -> Bool
dummy :: Bool, Animation -> AnimationTime
time :: AnimationTime, Animation -> AnimationFrames
frames :: AnimationFrames, Animation -> Bool
loop :: Bool, Animation -> KdlRef Spritesheet
spritesheet :: KdlRef Spritesheet} deriving (Typeable Animation
[HookRel Animation]
[Hook Animation]
Set DefaultComponentType
IsExclusive (IsExclusiveRel Animation)
(Typeable Animation, IsExclusive (IsExclusiveRel Animation)) =>
Set DefaultComponentType
-> [Hook Animation]
-> [Hook Animation]
-> [Hook Animation]
-> [HookRel Animation]
-> [HookRel Animation]
-> [HookRel Animation]
-> Component Animation
forall c.
(Typeable c, IsExclusive (IsExclusiveRel c)) =>
Set DefaultComponentType
-> [Hook c]
-> [Hook c]
-> [Hook c]
-> [HookRel c]
-> [HookRel c]
-> [HookRel c]
-> Component c
$crequired :: Set DefaultComponentType
required :: Set DefaultComponentType
$conAdd :: [Hook Animation]
onAdd :: [Hook Animation]
$conSet :: [Hook Animation]
onSet :: [Hook Animation]
$conRemove :: [Hook Animation]
onRemove :: [Hook Animation]
$conAddRel :: [HookRel Animation]
onAddRel :: [HookRel Animation]
$conSetRel :: [HookRel Animation]
onSetRel :: [HookRel Animation]
$conRemoveRel :: [HookRel Animation]
onRemoveRel :: [HookRel Animation]
Component, Int -> Animation -> ShowS
[Animation] -> ShowS
Animation -> String
(Int -> Animation -> ShowS)
-> (Animation -> String)
-> ([Animation] -> ShowS)
-> Show Animation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Animation -> ShowS
showsPrec :: Int -> Animation -> ShowS
$cshow :: Animation -> String
show :: Animation -> String
$cshowList :: [Animation] -> ShowS
showList :: [Animation] -> ShowS
Show)

noAnimation :: AssetRef Animation
noAnimation :: AssetRef Animation
noAnimation = Animation -> AssetRef Animation
forall a. a -> AssetRef a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Animation -> AssetRef Animation)
-> Animation -> AssetRef Animation
forall a b. (a -> b) -> a -> b
$ Animation {dummy :: Bool
dummy = Bool
True, time :: AnimationTime
time = Float -> AnimationTime
TotalTime Float
0, frames :: AnimationFrames
frames = [Int] -> AnimationFrames
ManualFrames [Int
0], loop :: Bool
loop = Bool
False, spritesheet :: KdlRef Spritesheet
spritesheet = KdlRef Spritesheet
noSpritesheet}

nframes :: Animation -> Int
nframes :: Animation -> Int
nframes Animation {frames :: Animation -> AnimationFrames
frames = RangedFrames Int
start Int
end} = Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
nframes Animation {frames :: Animation -> AnimationFrames
frames = ManualFrames [Int]
f} = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
f

animFrameIndex :: Int -> AnimationFrames -> Maybe Int
animFrameIndex :: Int -> AnimationFrames -> Maybe Int
animFrameIndex Int
frame (RangedFrames Int
start Int
end) =
  let f :: Int
f = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frame
   in if Int
f Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
end then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
f else Maybe Int
forall a. Maybe a
Nothing
animFrameIndex Int
frame (ManualFrames [Int]
f) = [Int]
f [Int] -> Int -> Maybe Int
forall a. [a] -> Int -> Maybe a
!? Int
frame

animFrameCoords :: Int -> Animation -> System (Maybe SpriteSlice)
animFrameCoords :: Int -> Animation -> System (Maybe SpriteSlice)
animFrameCoords Int
frame Animation
animation = do
  let index :: Maybe Int
index = Int -> AnimationFrames -> Maybe Int
animFrameIndex Int
frame Animation
animation.frames
  case Maybe Int
index of
    Maybe Int
Nothing -> Maybe SpriteSlice -> System (Maybe SpriteSlice)
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SpriteSlice
forall a. Maybe a
Nothing
    Just Int
index -> do
      sheet <- AssetRef Spritesheet -> System (Maybe Spritesheet)
forall a. AssetRef a -> System (Maybe a)
asset (AssetRef Spritesheet -> System (Maybe Spritesheet))
-> AssetRef Spritesheet -> System (Maybe Spritesheet)
forall a b. (a -> b) -> a -> b
$ KdlRef Spritesheet -> AssetRef Spritesheet
forall a. (Asset a, Bundle a) => KdlRef a -> AssetRef a
forall (r :: * -> *) a.
(ToAssetRef r, Asset a, Bundle a) =>
r a -> AssetRef a
toRef Animation
animation.spritesheet
      case sheet of
        Maybe Spritesheet
Nothing -> Maybe SpriteSlice -> System (Maybe SpriteSlice)
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SpriteSlice
forall a. Maybe a
Nothing
        Just Spritesheet
sheet -> do
          Maybe SpriteSlice -> System (Maybe SpriteSlice)
forall a. a -> System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SpriteSlice -> System (Maybe SpriteSlice))
-> Maybe SpriteSlice -> System (Maybe SpriteSlice)
forall a b. (a -> b) -> a -> b
$ SpriteSlice -> Maybe SpriteSlice
forall a. a -> Maybe a
Just (SpriteSlice -> Maybe SpriteSlice)
-> SpriteSlice -> Maybe SpriteSlice
forall a b. (a -> b) -> a -> b
$ (V2 Int -> V2 Int -> SpriteSlice)
-> (V2 Int, V2 Int) -> SpriteSlice
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry V2 Int -> V2 Int -> SpriteSlice
SpriteSlice ((V2 Int, V2 Int) -> SpriteSlice)
-> (V2 Int, V2 Int) -> SpriteSlice
forall a b. (a -> b) -> a -> b
$ Int -> Spritesheet -> (V2 Int, V2 Int)
sheetCoords Int
index Spritesheet
sheet

qanimFrameCoords :: Int -> Animation -> Query System (Maybe SpriteSlice)
qanimFrameCoords :: Int -> Animation -> Query System (Maybe SpriteSlice)
qanimFrameCoords Int
frame Animation
animation = do
  let index :: Maybe Int
index = Int -> AnimationFrames -> Maybe Int
animFrameIndex Int
frame Animation
animation.frames
  case Maybe Int
index of
    Maybe Int
Nothing -> Maybe SpriteSlice -> Query System (Maybe SpriteSlice)
forall a. a -> Query System a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SpriteSlice
forall a. Maybe a
Nothing
    Just Int
index ->
      SpriteSlice -> Maybe SpriteSlice
forall a. a -> Maybe a
Just (SpriteSlice -> Maybe SpriteSlice)
-> Query System SpriteSlice -> Query System (Maybe SpriteSlice)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        sheet <- AssetRef Spritesheet -> Query System Spritesheet
forall a. AssetRef a -> Query System a
qasset (AssetRef Spritesheet -> Query System Spritesheet)
-> AssetRef Spritesheet -> Query System Spritesheet
forall a b. (a -> b) -> a -> b
$ KdlRef Spritesheet -> AssetRef Spritesheet
forall a. (Asset a, Bundle a) => KdlRef a -> AssetRef a
kdlToAssetRef Animation
animation.spritesheet
        pure $ uncurry SpriteSlice $ sheetCoords index sheet

qanimImage :: Animation -> Query System Entity
qanimImage :: Animation -> Query System Entity
qanimImage Animation
animation = do
  sheet <- AssetRef Spritesheet -> Query System Spritesheet
forall a. AssetRef a -> Query System a
qasset (AssetRef Spritesheet -> Query System Spritesheet)
-> AssetRef Spritesheet -> Query System Spritesheet
forall a b. (a -> b) -> a -> b
$ KdlRef Spritesheet -> AssetRef Spritesheet
forall a. (Asset a, Bundle a) => KdlRef a -> AssetRef a
kdlToAssetRef Animation
animation.spritesheet
  qmaybe =<< qlift (getRefEntity sheet.image)

instance Asset Spritesheet where
  type Saveable Spritesheet = False
  loadAsset :: String -> Text -> IO (Either Text Spritesheet)
loadAsset = Text -> String -> Text -> IO (Either Text Spritesheet)
forall a.
KdlAsset a =>
Text -> String -> Text -> IO (Either Text a)
loadKdl Text
"spritesheet"

instance KdlAsset Spritesheet where
  decodeKdl :: Text -> NodeDecoder Spritesheet
decodeKdl Text
path = NodeListDecodeArrow () Spritesheet -> NodeDecoder Spritesheet
forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
KDL.children (NodeListDecodeArrow () Spritesheet -> NodeDecoder Spritesheet)
-> NodeListDecodeArrow () Spritesheet -> NodeDecoder Spritesheet
forall a b. (a -> b) -> a -> b
$ do
    frameSize <- Text -> NodeListDecoder (V2 Int)
forall a. DecodeNode a => Text -> NodeListDecoder a
KDL.node Text
"frameSize"
    padding <- KDL.node "padding"
    size <- KDL.node "size"
    image <- KDL.nodeWith "image" $ decodeKdl path

    pure $ Spritesheet {frameSize, padding, size, image}

instance Asset Animation where
  type Saveable Animation = False
  loadAsset :: String -> Text -> IO (Either Text Animation)
loadAsset = Text -> String -> Text -> IO (Either Text Animation)
forall a.
KdlAsset a =>
Text -> String -> Text -> IO (Either Text a)
loadKdl Text
"animation"

instance KdlAsset Animation where
  decodeKdl :: Text -> NodeDecoder Animation
decodeKdl Text
path = NodeListDecodeArrow () Animation -> NodeDecoder Animation
forall a b. NodeListDecodeArrow a b -> NodeDecodeArrow a b
KDL.children (NodeListDecodeArrow () Animation -> NodeDecoder Animation)
-> NodeListDecodeArrow () Animation -> NodeDecoder Animation
forall a b. (a -> b) -> a -> b
$ do
    time <- NodeListDecoder AnimationTime
animationTimeDecoder
    frames <- animationFramesDecoder
    loop <- animationLoopDecoder
    spritesheet <- KDL.nodeWith "spritesheet" $ decodeKdl path
    pure $ Animation {dummy = False, time, frames, loop, spritesheet}

animationTimeDecoder :: KDL.NodeListDecoder AnimationTime
animationTimeDecoder :: NodeListDecoder AnimationTime
animationTimeDecoder = NodeListDecoder AnimationTime
f1 NodeListDecoder AnimationTime
-> NodeListDecoder AnimationTime -> NodeListDecoder AnimationTime
forall a.
DecodeArrow NodeList () a
-> DecodeArrow NodeList () a -> DecodeArrow NodeList () a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NodeListDecoder AnimationTime
f2
  where
    f1 :: NodeListDecoder AnimationTime
f1 = Float -> AnimationTime
FpsTime (Float -> AnimationTime)
-> DecodeArrow NodeList () Float -> NodeListDecoder AnimationTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> DecodeArrow NodeList () Float
forall a. DecodeValue a => Text -> NodeListDecoder a
KDL.argAt Text
"fps"
    f2 :: NodeListDecoder AnimationTime
f2 = Float -> AnimationTime
TotalTime (Float -> AnimationTime)
-> DecodeArrow NodeList () Float -> NodeListDecoder AnimationTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> DecodeArrow NodeList () Float
forall a. DecodeValue a => Text -> NodeListDecoder a
KDL.argAt Text
"time"

animationFramesDecoder :: KDL.NodeListDecoder AnimationFrames
animationFramesDecoder :: NodeListDecoder AnimationFrames
animationFramesDecoder = NodeListDecoder AnimationFrames
f1 NodeListDecoder AnimationFrames
-> NodeListDecoder AnimationFrames
-> NodeListDecoder AnimationFrames
forall a.
DecodeArrow NodeList () a
-> DecodeArrow NodeList () a -> DecodeArrow NodeList () a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NodeListDecoder AnimationFrames
f2
  where
    f1 :: NodeListDecoder AnimationFrames
f1 = do
      Text
-> NodeDecodeArrow () AnimationFrames
-> NodeListDecoder AnimationFrames
forall a b.
Typeable b =>
Text -> NodeDecodeArrow a b -> NodeListDecodeArrow a b
KDL.nodeWith Text
"range" (NodeDecodeArrow () AnimationFrames
 -> NodeListDecoder AnimationFrames)
-> NodeDecodeArrow () AnimationFrames
-> NodeListDecoder AnimationFrames
forall a b. (a -> b) -> a -> b
$ do
        start <- NodeDecoder Int
forall a. DecodeValue a => NodeDecoder a
KDL.arg
        RangedFrames start <$> KDL.arg
    f2 :: NodeListDecoder AnimationFrames
f2 = [Int] -> AnimationFrames
ManualFrames ([Int] -> AnimationFrames)
-> DecodeArrow NodeList () [Int] -> NodeListDecoder AnimationFrames
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> DecodeArrow NodeList () [Int]
forall a. DecodeValue a => Text -> NodeListDecoder [a]
KDL.argsAt Text
"frames"

animationLoopDecoder :: KDL.NodeListDecoder Bool
animationLoopDecoder :: NodeListDecoder Bool
animationLoopDecoder = NodeListDecoder Bool
f1 NodeListDecoder Bool
-> NodeListDecoder Bool -> NodeListDecoder Bool
forall a.
DecodeArrow NodeList () a
-> DecodeArrow NodeList () a -> DecodeArrow NodeList () a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NodeListDecoder Bool
f2
  where
    f1 :: NodeListDecoder Bool
f1 = Text -> NodeListDecoder Bool
forall a. DecodeValue a => Text -> NodeListDecoder a
KDL.argAt Text
"loop"
    f2 :: NodeListDecoder Bool
f2 = Bool -> NodeListDecoder Bool
forall a. a -> DecodeArrow NodeList () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False