{-# LANGUAGE TemplateHaskell #-}

module Graphics.Glyph.GlyphObject
  ( GlyphObject (..),
    getBufferObject,
    getCompiledData,
    getVertexAttribute,
    getNormalAttribute,
    getColorAttribute,
    getTextureAttribute,
    getResources,
    getSetupRoutine,
    getTeardownRoutine,
    getPrimitiveMode,
    setBufferObject,
    setCompiledData,
    setVertexAttribute,
    setNormalAttribute,
    setColorAttribute,
    setTextureAttribute,
    setResources,
    setSetupRoutine,
    setTeardownRoutine,
    setPrimitiveMode,
    prepare,
    teardown,
    Drawable,
    draw,
    newGlyphObject,
    newDefaultGlyphObject,
  )
where

import Control.Applicative
import Control.Monad
import Data.Maybe
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL

class Drawable a where
  -- mvMat -> pMat -> obj -> IO ()
  draw :: a -> IO ()

data GlyphObject a = GlyphObject
  { bufferObject :: BufferObject, -- buffer
    compiledData :: (CompiledBuild GLfloat), -- compiled data
    vertexAttribute :: AttribLocation, -- vertex attribute
    normalAttribute :: (Maybe AttribLocation), -- normal attrib
    colorAttribute :: (Maybe AttribLocation), -- color attrib
    textureAttribute :: (Maybe AttribLocation), -- texture attrib
    resources :: a, -- Resources
    setupRoutine :: (Maybe (GlyphObject a -> IO ())), -- Setup
    teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
    primitiveMode :: PrimitiveMode
  }

getBufferObject :: GlyphObject a -> BufferObject
getBufferObject = bufferObject

getCompiledData :: GlyphObject a -> (CompiledBuild GLfloat)
getCompiledData = compiledData

getVertexAttribute :: GlyphObject a -> AttribLocation
getVertexAttribute = vertexAttribute

getNormalAttribute :: GlyphObject a -> (Maybe AttribLocation)
getNormalAttribute = normalAttribute

getColorAttribute :: GlyphObject a -> (Maybe AttribLocation)
getColorAttribute = colorAttribute

getTextureAttribute :: GlyphObject a -> (Maybe AttribLocation)
getTextureAttribute = textureAttribute

getResources :: GlyphObject a -> a
getResources = resources

getSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ()))
getSetupRoutine = setupRoutine

getTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ()))
getTeardownRoutine = teardownRoutine

getPrimitiveMode :: GlyphObject a -> PrimitiveMode
getPrimitiveMode = primitiveMode

setBufferObject :: GlyphObject a -> BufferObject -> GlyphObject a
setBufferObject o a = o {bufferObject = a}

setCompiledData :: GlyphObject a -> (CompiledBuild GLfloat) -> GlyphObject a
setCompiledData o a = o {compiledData = a}

setVertexAttribute :: GlyphObject a -> AttribLocation -> GlyphObject a
setVertexAttribute o a = o {vertexAttribute = a}

setNormalAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
setNormalAttribute o a = o {normalAttribute = a}

setColorAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
setColorAttribute o a = o {colorAttribute = a}

setTextureAttribute :: GlyphObject a -> (Maybe AttribLocation) -> GlyphObject a
setTextureAttribute o a = o {textureAttribute = a}

setResources :: GlyphObject a -> a -> GlyphObject a
setResources o a = o {resources = a}

setSetupRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
setSetupRoutine o a = o {setupRoutine = a}

setTeardownRoutine :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
setTeardownRoutine o a = o {teardownRoutine = a}

setPrimitiveMode :: GlyphObject a -> PrimitiveMode -> GlyphObject a
setPrimitiveMode o a = o {primitiveMode = a}

newGlyphObject ::
  Builder GLfloat x ->
  AttribLocation ->
  Maybe AttribLocation ->
  Maybe AttribLocation ->
  Maybe AttribLocation ->
  a ->
  Maybe (GlyphObject a -> IO ()) ->
  Maybe (GlyphObject a -> IO ()) ->
  PrimitiveMode ->
  IO (GlyphObject a)
newGlyphObject builder vertAttr normAttr colorAttr textureAttr res setup tear mode = do
  compiled <- compilingBuilder builder
  buffer <- createBufferObject ArrayBuffer compiled
  return $ GlyphObject buffer compiled vertAttr normAttr colorAttr textureAttr res setup tear mode

prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
prepare a b = a {setupRoutine = (Just b)}

teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
teardown a b = a {teardownRoutine = Just b}

instance Drawable (GlyphObject a) where
  draw obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup tearDown p) = do
    {- Setup whatever we need for the object to draw itself -}
    maybe (return ()) (apply obj) setup

    {- Get the array descriptors for the possible
     - parts -}
    let vad = vertexArrayDescriptor co
    let nad = normalArrayDescriptor co
    let cad = colorArrayDescriptor co
    let tad = textureArrayDescriptor co

    bindBuffer ArrayBuffer $= Just bo
    let enabled =
          catMaybes $
            map liftMaybe [(Just vAttr, Just vad), (nAttr, nad), (cAttr, cad), (tAttr, tad)]

    forM_ enabled $ \(attr, ad) -> do
      vertexAttribPointer attr $= (ToFloat, ad)
      vertexAttribArray attr $= Enabled

    drawArrays p 0 (bufferLength co)

    forM_ enabled $ \(attr, _) -> do
      vertexAttribArray attr $= Disabled

    {- Tear down whatever the object needs -}
    maybe (return ()) (apply obj) tearDown
    where
      liftMaybe (Just a, Just b) = Just (a, b)
      liftMaybe _ = Nothing
      apply obj' f = f obj'

instance (Show a) => Show (GlyphObject a) where
  show (GlyphObject _ co vAttr nAttr cAttr tAttr res _ _ p) =
    "[GlyphObject compiled=" ++! co ++ " vertAttr=" ++! vAttr
      ++ " normalAttr=" ++! nAttr
      ++ " colorAttr=" ++! cAttr
      ++ " textureAttr=" ++! tAttr
      ++ " res=" ++! res
      ++ " PrimitiveMode=" ++! p
      ++ "]"

newDefaultGlyphObject :: Builder GLfloat x -> a -> IO (GlyphObject a)
newDefaultGlyphObject builder resources =
  newGlyphObject
    builder
    (AttribLocation 0) -- vertex
    (Just $ AttribLocation 1) -- normal
    (Just $ AttribLocation 2) -- color
    (Just $ AttribLocation 3) -- texture
    resources
    Nothing -- setup
    Nothing -- teardown
    Triangles -- primitive