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,
    startClosure,
    newDefaultGlyphObjectWithClosure,
    drawInstances,
    numInstances,
    setNumInstances,
  )
where

import Control.Applicative
import Control.Monad
import Data.Maybe
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.ExtendedGL as Ex
import Graphics.Glyph.Util
import Graphics.Rendering.OpenGL as GL

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
    setupRoutine2 :: (Maybe (GlyphObject a -> IO ())), -- Setup
    teardownRoutine :: (Maybe (GlyphObject a -> IO ())), -- Tear down
    primitiveMode :: ExPrimitiveMode,
    numInstances :: Int
  }

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 -> ExPrimitiveMode
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}

setSetupRoutine2 :: GlyphObject a -> (Maybe (GlyphObject a -> IO ())) -> GlyphObject a
setSetupRoutine2 o a = o {setupRoutine2 = a}

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

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

setNumInstances :: GlyphObject a -> Int -> GlyphObject a
setNumInstances o a = o {numInstances = a}

newGlyphObject ::
  BuilderM GLfloat x ->
  AttribLocation ->
  Maybe AttribLocation ->
  Maybe AttribLocation ->
  Maybe AttribLocation ->
  a ->
  Maybe (GlyphObject a -> IO ()) ->
  Maybe (GlyphObject a -> IO ()) ->
  ExPrimitiveMode ->
  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 Nothing tear mode 1

prepare :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
prepare a b = setSetupRoutine2 a (Just b)

startClosure :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
startClosure a b = setSetupRoutine a (Just b)

teardown :: GlyphObject a -> (GlyphObject a -> IO ()) -> GlyphObject a
teardown a b = setTeardownRoutine a (Just b)

instance Drawable (GlyphObject a) where
  draw = drawInstances <..> numInstances

drawInstances :: Int -> GlyphObject a -> IO ()
drawInstances n obj@(GlyphObject bo co vAttr nAttr cAttr tAttr _ setup1 setup2 tearDown p _) = do
  {- Setup whatever we need for the object to draw itself -}
  maybe (return ()) (Prelude.$ obj) setup1
  maybe (return ()) (Prelude.$ obj) setup2

  {- 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

  let p' = case p of
        Ex.Points -> GL.Points
        Ex.Lines -> GL.Lines
        Ex.Triangles -> GL.Triangles
        Ex.Patches -> GL.Patches

  drawArraysInstanced p' 0 (bufferLength co) $ fromIntegral n

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

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

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

newDefaultGlyphObject :: BuilderM 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
    Ex.Triangles -- primitive

newDefaultGlyphObjectWithClosure :: BuilderM GLfloat x -> a -> (GlyphObject a -> IO ()) -> IO (GlyphObject a)
newDefaultGlyphObjectWithClosure builder res func =
  liftM (flip startClosure func) $ newDefaultGlyphObject builder res