Quad.hs

module Geometry.Quad
  ( coloredQuad
  , texturedQuad

  , Quad(..)
  , toVertices
  , toVertices2

  , quadPositions
  , quadUV
  , quadNormals
  ) where

import RIO

import Geomancy (Vec2, Vec4, vec2, vec3)
import Geomancy.Vec3 qualified as Vec3

import Resource.Model (Vertex(..))

data Quad a = Quad
  { quadLT :: a
  , quadRT :: a
  , quadLB :: a
  , quadRB :: a
  }
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

instance Applicative Quad where
  {-# INLINE pure #-}
  pure x = Quad
    { quadLT = x
    , quadRT = x
    , quadLB = x
    , quadRB = x
    }

  funcs <*> args = Quad
    { quadLT = quadLT funcs $ quadLT args
    , quadRT = quadRT funcs $ quadRT args
    , quadLB = quadLB funcs $ quadLB args
    , quadRB = quadRB funcs $ quadRB args
    }

-- | 2 clockwise ordered triangles
toVertices :: Quad (Vertex pos attrs) -> [Vertex pos attrs]
toVertices Quad{..} =
  [ quadLT, quadRT, quadLB
  , quadLB, quadRT, quadRB
  ]

toVertices2 :: Quad (Vertex pos attrs) -> [Vertex pos attrs]
toVertices2 q = vertices <> reverse vertices
  where
    vertices = toVertices q

coloredQuad :: Vec4 -> Quad (Vertex Vec3.Packed Vec4)
coloredQuad color = Vertex <$> quadPositions <*> pure color

texturedQuad :: Quad (Vertex Vec3.Packed Vec2)
texturedQuad = Vertex <$> quadPositions <*> quadUV

quadPositions :: Quad Vec3.Packed
quadPositions = fmap Vec3.Packed Quad
  { quadLT = vec3 (-0.5) (-0.5) 0
  , quadRT = vec3   0.5  (-0.5) 0
  , quadLB = vec3 (-0.5)   0.5  0
  , quadRB = vec3   0.5    0.5  0
  }

quadUV :: Quad Vec2
quadUV = Quad
  { quadLT = vec2 0 0
  , quadRT = vec2 1 0
  , quadLB = vec2 0 1
  , quadRB = vec2 1 1
  }

quadNormals :: Quad Vec3.Packed
quadNormals = pure . Vec3.Packed $ vec3 0 0 (-1)