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.Graphics.Drawable
import Classes.Graphics.Bindable
import Classes.Prop
import Classes.Actor
import Classes.Physics

import Types.Graphics.VertexBuffer
import Types.Texture
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
  }
  deriving (Eq, Show)

instance Drawable Pituicat where

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

instance Prop Pituicat where

  residentLayer _ = 0

  bindPropTexture = bind . pcTexture

instance Actor Pituicat where

  perform dt p =
    let (V2 _ dy) = velocity physCat
        physCat = (accelerate dt . gravitate constG)
          (p
            { pcAcc = 0
            , pcTMoveVel =
              case pcMoveState p of
                Just MoveRight -> V2 catMoveVelocity 0
                Just MoveLeft -> V2 (-catMoveVelocity) 0
                _ -> V2 0 0
            }
            )
        finalCat = physCat
          { pcMoveVel =
            lerp (min 0.95 (60 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat)
          , pcGrounded = if pcGrounded physCat
              then not (abs dy * dt > 2)
              else False
          }
    in
      finalCat

instance Mass Pituicat where

  mass _ = 1

  acceleration = pcAcc

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

  velocity cat = pcVel cat + pcMoveVel cat

  velocityUpdater cat =
    (\vel@(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 _ =
    ( V2 (-25) (-25)
    , V2 25 25
    )

  collide cat _ NoCollision = cat
  collide cat other collr@(Collision ddt (V2 dirx diry)) =
    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 =
          (vy * ddt) >= 0 &&
          (vy * ddt) < 5 && diry == -1
    in
      A.log
        Debug
        ("*boing* meow! collision result: " <>
          fromString (show collr) <>
          "\nother: " <>
          fromString (show other)
          )
        (
            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
              }
          )