-----------------------------------------------------------------------------
-- |
-- Copyright   : (C) 2015 Dimitri Sabadie
-- License     : BSD3
--
-- Maintainer  : Dimitri Sabadie <dimitri.sabadie@gmail.com>
-- Stability   : experimental
-- Portability : portable
--
-----------------------------------------------------------------------------

{-# LANGUAGE OverloadedStrings #-}
module Codec.Wavefront.Lexer where

import Codec.Wavefront.Element
import Codec.Wavefront.Face
import Codec.Wavefront.FreeForm
import Codec.Wavefront.Line
import Codec.Wavefront.Location
import Codec.Wavefront.Normal
import Codec.Wavefront.Point
import Codec.Wavefront.Token
import Codec.Wavefront.TexCoord
import Data.DList ( DList, append, empty, fromList, snoc )
import Data.Text ( Text )
import Control.Monad.State ( State, execState, gets, modify )
import Data.Foldable ( traverse_ )
import Numeric.Natural ( Natural )

-- |The lexer context. The result of lexing a stream of tokens is this exact type.
data Ctxt = Ctxt {
    -- |Locations.
    ctxtLocations :: (Int, DList Location)
    -- |Texture coordinates.
  , ctxtTexCoords :: (Int, DList TexCoord)
    -- |Texture coordinates.
  , ctxtParamCoords :: (Int, DList ParamCoord)
    -- |Normals.
  , ctxtNormals :: (Int, DList Normal)
    -- |Points.
  , ctxtPoints :: DList (Element Point)
    -- |Lines.
  , ctxtLines :: DList (Element Line)
    -- |Faces.
  , ctxtFaces :: DList (Element Face)
    -- |Curves.
  , ctxtCurves :: DList (Element Curve)
    -- |Curves on surfaces.
  , ctxtEmbeddedCurves :: DList (Element EmbeddedCurve)
    -- |Surfaces.
  , ctxtSurfaces :: DList (Element Surface)
    -- |Current object.
  , ctxtCurrentObject :: Maybe Text
    -- |Current groups.
  , ctxtCurrentGroups :: [Text]
    -- |Current material.
  , ctxtCurrentMtl :: Maybe Text
    -- |Material libraries.
  , ctxtMtlLibs :: DList Text
    -- |Current smoothing group.
  , ctxtCurrentSmoothingGroup :: Natural
  } deriving (Eq,Show)

-- |The empty 'Ctxt'. Such a context exists at the beginning of the token stream and gets altered
-- as we consume tokens.
emptyCtxt :: Ctxt
emptyCtxt = Ctxt {
    ctxtLocations = (0,empty)
  , ctxtTexCoords = (0,empty)
  , ctxtParamCoords = (0,empty)
  , ctxtNormals = (0,empty)
  , ctxtPoints = empty
  , ctxtLines = empty
  , ctxtFaces = empty
  , ctxtCurves = empty
  , ctxtEmbeddedCurves = empty
  , ctxtSurfaces = empty
  , ctxtCurrentObject = Nothing
  , ctxtCurrentGroups = ["default"]
  , ctxtCurrentMtl = Nothing
  , ctxtMtlLibs = empty
  , ctxtCurrentSmoothingGroup = 0
  }

updateList v field setField = do
    (c0,vs) <- gets field
    let c = succ c0
    c `seq` modify $ setField (c, vs `snoc` v)

derel c x | x > 0     = x
          | otherwise = c + x + 1

derelF cv ct cn (FaceIndex v mt mn) = FaceIndex (derel cv v) (derel ct <$> mt) (derel cn <$> mn)

derelativizeFace cv ct cn (Face a b c ds) = Face a' b' c' ds'
 where
    a':b':c':ds' = map (derelF cv ct cn) $ a:b:c:ds

-- |The lexer function, consuming tokens and yielding a 'Ctxt'.
lexer :: TokenStream -> Ctxt
lexer stream = execState (traverse_ consume stream) emptyCtxt
  where
    consume tk = case tk of
      TknV v   -> updateList v  ctxtLocations   $ \x ctxt -> ctxt { ctxtLocations   = x }
      TknVN vn -> updateList vn ctxtNormals     $ \x ctxt -> ctxt { ctxtNormals     = x }
      TknVT vt -> updateList vt ctxtTexCoords   $ \x ctxt -> ctxt { ctxtTexCoords   = x }
      TknVP vp -> updateList vp ctxtParamCoords $ \x ctxt -> ctxt { ctxtParamCoords = x }
      TknP p -> do
        (pts,element) <- prepareElement ctxtPoints
        modify $ \ctxt -> ctxt { ctxtPoints = pts `append` fmap element (fromList p) }
      TknL l -> do
        (lns,element) <- prepareElement ctxtLines
        modify $ \ctxt -> ctxt { ctxtLines = lns `append` fmap element (fromList l) }
      TknF f0 -> do
        vgcnt <- gets (fst . ctxtLocations)
        vtcnt <- gets (fst . ctxtTexCoords)
        vncnt <- gets (fst . ctxtNormals)
        let f = derelativizeFace vgcnt vtcnt vncnt f0
        (fcs,element) <- prepareElement ctxtFaces
        modify $ \ctxt -> ctxt { ctxtFaces = fcs `snoc` element f }
      TknG g -> modify $ \ctxt -> ctxt { ctxtCurrentGroups = g }
      TknO o -> modify $ \ctxt -> ctxt { ctxtCurrentObject = Just o }
      TknMtlLib l -> do
        libs <- gets ctxtMtlLibs
        modify $ \ctxt -> ctxt { ctxtMtlLibs = libs `append` fromList l }
      TknUseMtl mtl -> modify $ \ctxt -> ctxt { ctxtCurrentMtl = Just mtl }
      TknS sg -> modify $ \ctxt -> ctxt { ctxtCurrentSmoothingGroup = sg }

-- Prepare to create a new 'Element' by retrieving its associated list.
prepareElement :: (Ctxt -> DList (Element a)) -> State Ctxt (DList (Element a),a -> Element a)
prepareElement field = do
  (aList,obj,grp,mtl,sg) <- gets $ (\ctxt -> (field ctxt,ctxtCurrentObject ctxt,ctxtCurrentGroups ctxt,ctxtCurrentMtl ctxt,ctxtCurrentSmoothingGroup ctxt))
  pure (aList,Element obj grp mtl sg)