{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}

module Graphics.Glyph.GeometryBuilder where

import Data.ByteString.Lazy
import Data.ByteString.Lazy.Char8 as BSLC
import Data.ByteStringBuilder
import Data.Foldable as Fold
import Data.Maybe
import Data.Sequence as Seq
import Graphics.Glyph.BufferBuilder
import Graphics.Glyph.Util
import Text.Printf

data OutType = TriangleStrip | Triangles

instance Show OutType where
  show TriangleStrip = "triangle_strip"
  show Triangles = "triangle_strip"

buildSourceAsString :: GeometryBuilder a -> String
buildSourceAsString = BSLC.unpack . buildSource

buildSource :: GeometryBuilder a -> ByteString
buildSource builder =
  runBuilder $ do
    putSLn "#version 150"
    putSLn "#extension GL_ARB_explicit_attrib_location : enable"
    putSLn "#extension GL_ARB_explicit_uniform_location : enable"
    putSLn "layout(points) in ;"

    let isVertex (Vertex _ _ _ _) = True
        isVertex _ = False
    putSLn $
      printf
        "layout(%s,max_vertices=%d) out ;"
        (show $ maybeDefault TriangleStrip $ gOutType builder)
        (Seq.length $ Seq.filter isVertex $ gList builder)

    forM_ (textureOut builder) $ putSLn . ("out vec2 " ++) . (++ ";")
    forM_ (normalOut builder) $ putSLn . ("out vec3 " ++) . (++ ";")
    forM_ (positionOut builder) $ putSLn . ("out vec4 " ++) . (++ ";")

    let pjMatStr = fromJust (pjMatrixUniform builder >||> Just "pjMatrix")
    let mvMatStr = fromJust (mvMatrixUniform builder >||> Just "mvMatrix")

    Fold.mapM_ (putSLn . ("uniform mat4 " ++) . (++ ";")) [pjMatStr, mvMatStr]

    putSLn "void main() {"

    let vertexOutF =
          case positionOut builder of
            Nothing ->
              printf
                "\tgl_Position = %s * (gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));"
                pjMatStr
                mvMatStr
            Just str ->
              printf
                "\tgl_Position = %s * (%s = gl_in[0].gl_Position + %s * vec4(%f,%f,%f,%f));"
                pjMatStr
                str
                mvMatStr
    let normalOutF = case normalOut builder of
          Nothing -> const3 ""
          Just str -> printf "\t%s = -inverse(transpose(mat3(%s))) * vec3(%f,%f,%f);" str mvMatStr

    let textureOutF = case textureOut builder of
          Nothing -> const2 ""
          Just str -> printf "\t%s = vec2(%f,%f);" str

    forM_ (gList builder) $ \datum ->
      case datum of
        Vertex x y z w -> putSLn $ vertexOutF x y z w
        Normal x y z -> putSLn $ normalOutF x y z
        Texture x y -> putSLn $ textureOutF x y
        EmitVertex -> putSLn "\tEmitVertex();"
        EndPrimitive -> putSLn "\tEndPrimitive();"
    putSLn "}"

data GeometryDatum
  = Vertex Float Float Float Float
  | Texture Float Float
  | Normal Float Float Float
  | EmitVertex
  | EndPrimitive

data GeometryBuilder a = GeometryBuilder
  { gList :: (Seq GeometryDatum),
    gOutType :: Maybe OutType,
    pjMatrixUniform :: Maybe String,
    mvMatrixUniform :: Maybe String,
    maxVerts :: Maybe Int,
    textureOut :: Maybe String,
    normalOut :: Maybe String,
    positionOut :: Maybe String,
    gRet :: a
  }

generating :: OutType -> GeometryBuilder () -> GeometryBuilder ()
generating TriangleStrip builder = builder {gOutType = Just TriangleStrip}
generating Triangles builder = do
  let (nSeq, _) =
        Fold.foldl'
          ( \(tSeq, cnt) datum ->
              case datum of
                EmitVertex ->
                  if cnt == (2 :: Int)
                    then (tSeq |> datum |> EndPrimitive, 0)
                    else (tSeq |> datum, cnt + 1)
                _ -> (tSeq |> datum, cnt)
          )
          (Seq.empty, 0)
          (gList builder)

  builder
    { gOutType = Just Triangles,
      gList = nSeq
    }

projectionMatrixUniform :: String -> GeometryBuilder ()
projectionMatrixUniform str = (return ()) {pjMatrixUniform = (Just str)}

modelViewMatrixUniform :: String -> GeometryBuilder ()
modelViewMatrixUniform str = (return ()) {mvMatrixUniform = (Just str)}

maxVerticies :: Int -> GeometryBuilder ()
maxVerticies i = (return ()) {maxVerts = (Just i)}

textureOutput :: String -> GeometryBuilder ()
textureOutput str = (return ()) {textureOut = (Just str)}

normalOutput :: String -> GeometryBuilder ()
normalOutput str = (return ()) {normalOut = (Just str)}

positionOutput :: String -> GeometryBuilder ()
positionOutput str = (return ()) {positionOut = (Just str)}

gVertex4 :: Float -> Float -> Float -> Float -> GeometryBuilder ()
gVertex4 x y z w = (return ()) {gList = Seq.singleton $ Vertex x y z w}

gNormal3 :: Float -> Float -> Float -> GeometryBuilder ()
gNormal3 x y z = (return ()) {gList = (Seq.singleton $ Normal x y z)}

gTexture2 :: Float -> Float -> GeometryBuilder ()
gTexture2 x y = (return ()) {gList = (Seq.singleton $ Texture x y)}

gEmitVertex :: GeometryBuilder ()
gEmitVertex = (return ()) {gList = (Seq.singleton $ EmitVertex)}

gEndPrimitive :: GeometryBuilder ()
gEndPrimitive = (return ()) {gList = Seq.singleton $ EndPrimitive}

gVertex4E :: Float -> Float -> Float -> Float -> GeometryBuilder ()
gVertex4E x y z w = gVertex4 x y z w >> gEmitVertex

instance Functor GeometryBuilder where
  fmap f bb = bb >>= (return . f)

instance Applicative GeometryBuilder where
  (<*>) afn aa = do
    fn <- afn
    a <- aa
    return (fn a)

  pure = return

instance Monad GeometryBuilder where
  aB >> bB =
    GeometryBuilder
      (gList aB >< gList bB)
      (select gOutType gOutType)
      (select pjMatrixUniform pjMatrixUniform)
      (select mvMatrixUniform mvMatrixUniform)
      (select maxVerts maxVerts)
      (select textureOut textureOut)
      (select normalOut normalOut)
      (select positionOut positionOut)
      (gRet bB)
    where
      select f1 f2 = (f1 bB) >||> (f2 aB)
  aB >>= func = aB >> func (gRet aB)
  return =
    GeometryBuilder
      Seq.empty
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing
      Nothing

instance IsModelBuilder Float GeometryBuilder where
  plotVertex3 x y z = gVertex4E x y z 0
  plotNormal = gNormal3
  plotTexture = gTexture2