pituicat/src/Types/Player.hs

{-# LANGUAGE OverloadedStrings #-}
module Types.Player where

import Affection as A

import Linear

import qualified Data.Vector as V

import Data.String (fromString)

-- internal imports

import Util

import Classes.Prop
import Classes.Actor
import Classes.Collectable

import Graphics.Classes.Drawable
import Graphics.Classes.Bindable
import Graphics.Types.VertexBuffer
import Graphics.Types.Texture

import Physics.Classes

import Types.Subsystems

catMoveVelocity :: Double
catMoveVelocity = 100

data Pituicat = Pituicat
  { pcPos           :: V2 Double
  , pcVel           :: V2 Double
  , pcMoveVel       :: V2 Double
  , pcTMoveVel      :: V2 Double
  , pcAcc           :: V2 Double
  , pcHealth        :: Int
  , pcTexture       :: Texture
  , pcGrounded      :: Bool
  , pcMoveState     :: Maybe Action
  , pcViewDirection :: ViewDirection
  , pcEffects       :: [EffectHolder]
  }
  deriving (Eq, Show)

data ViewDirection = ViewLeft | ViewRight
  deriving (Eq, Show)

instance Drawable Pituicat where

  toVertices (Pituicat (V2 x y) _ _ _ _ _ _ _ _ vd _) =
    ( V.fromList [0, 1, 2, 2, 3, 0]
    , V.fromList
      [ newVertex
        (V3 (realToFrac x - 25) (realToFrac y - 25) 0)
        (V4 1 1 1 1)
        (if vd == ViewRight
          then V2 0 (1 - 50 / 1024)
          else V2 (50 / 1024) (1 - 50 / 1024)
          )
        1
      , newVertex
        (V3 (realToFrac x + 25) (realToFrac y - 25) 0)
        (V4 1 1 1 1)
        (if vd == ViewRight
          then V2 (50 / 1024) (1 - 50 / 1024)
          else V2 0 (1 - 50 / 1024)
          )
        1
      , newVertex
        (V3 (realToFrac x + 25) (realToFrac y + 25) 0)
        (V4 1 1 1 1)
        (if vd == ViewRight
          then V2 (50 / 1024) 1
          else V2 0 1
          )
        1
      , newVertex
        (V3 (realToFrac x - 25) (realToFrac y + 25) 0)
        (V4 1 1 1 1)
        (if vd == ViewRight
          then V2 0 1
          else V2 (50 / 1024) 1
          )
        1
      ]
    )

instance Prop Pituicat where

  residentLayer _ = 0

  bindPropTexture = bind . pcTexture

instance Actor Pituicat where

  perform dt p =
    let (V2 _ dy) = velocity physCat
        moveFact =
          if
            not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
          then 1
          else 2
        physCat = (accelerate dt . gravitate constG)
          (p
            { pcAcc = V2 0 0
            , pcTMoveVel =
              case pcMoveState p of
                Just MoveRight -> V2 (catMoveVelocity * moveFact) 0
                Just MoveLeft -> V2 ((-catMoveVelocity) * moveFact) 0
                _ -> V2 0 0
            }
            )
        finalCat = physCat
          { pcMoveVel =
            lerp (min 0.95 (60 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat)
          , pcGrounded = pcGrounded physCat && abs dy * dt <= 2
          , pcEffects =
            foldl
              (\acc eff ->
                let nduration = effectDuration eff - dt
                in
                  if nduration > 0
                  then
                    eff { effectDuration = nduration} : acc
                  else
                    acc
                )
              []
              (pcEffects p)
          }
    in
      A.log A.Debug ("*meow* am at: " <> fromString (show $ position finalCat))
        (finalCat
          { pcViewDirection = if pcGrounded finalCat
            then
              case pcMoveState finalCat of
                Just MoveRight -> ViewRight
                Just MoveLeft -> ViewLeft
                _ -> pcViewDirection finalCat
            else
              pcViewDirection finalCat
          }
        )

instance Mass Pituicat where

  mass _ = 100

  acceleration = pcAcc

  accelerationUpdater cat =
    \accel -> cat
      { pcAcc = accel
      }

  velocity cat =
    let mvel@(V2 mx _) = pcMoveVel cat
        nvel@(V2 x y) = pcVel cat + mvel
    in
      if abs x > abs mx then V2 (signum x * abs mx) y else nvel

  velocityUpdater cat =
    \(V2 vx vy) ->
      let
        (V2 mx my) = pcMoveVel cat
        nvel = V2
          (if abs mx > abs vx
            then 0
            else signum vx * (abs vx - abs mx)
            )
          (if abs my > abs vy
            then 0
            else signum vy * (abs vy - abs my)
            )
      in
        cat
          { pcVel = nvel
          }

  position = pcPos

  positionUpdater cat =
    \pos -> cat
      { pcPos = pos
      }

instance Collidible Pituicat where

  boundary cat =
    if pcViewDirection cat == ViewRight
    then
      ( V2 (-18) (-25)
      , V2 25 15
      )
    else
      ( V2 (-25) (-25)
      , V2 18 15
      )

  collide cat _ NoCollision = cat
  collide cat other collr@(Collision ddt (V2 dirx diry)) =
    let ncat = elasticCollision 0.3 cat other collr
        nvel@(V2 _ vy) = pcVel ncat
        grounded = diry == -1 && abs (vy * ddt) < 2
        fact = fromIntegral <$> V2
          (1 - abs dirx)
          (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0)
    in
      ncat
        { pcVel = nvel * fact
        , pcMoveVel = pcMoveVel ncat * fact
        , pcTMoveVel = pcTMoveVel ncat * fact
        , pcGrounded = grounded
        }
    -- let ncat = (elasticCollision 0.3 cat other collr)
    --     vel@(V2 vx vy) = velocity ncat
    --     moveVel@(V2 mx my) = pcMoveVel cat
    --     nvel = V2
    --       (if abs mx > abs vx
    --         then 0
    --         else (signum vx) * (abs vx - abs mx)
    --         )
    --       ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
    --     grounded =
    --       diry == -1 && abs (vy * ddt) < 2
    -- in
    --   ncat
    --     { pcGrounded = grounded
    --     , pcMoveVel = pcMoveVel ncat *
    --       if dirx /= 0
    --       then V2 0 1
    --       else V2 1 1
    --     , pcVel = nvel *
    --       if dirx /= 0
    --       then V2 0 1
    --       else V2 1 1
    --     }