{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses
           , ParallelListComp, ScopedTypeVariables, TypeOperators
	   , FlexibleContexts, TypeFamilies
  #-}
-- {-# OPTIONS_GHC -Wall #-}
-- TODO: restore
----------------------------------------------------------------------
-- |
-- Module      :  Graphics.FieldTrip.Geometry3
-- Copyright   :  (c) Conal Elliott and Andy J Gill 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net, andygill@ku.edu
-- Stability   :  experimental
-- 
-- 3D geometry
----------------------------------------------------------------------

module Graphics.FieldTrip.Geometry3
  (
    Geometry3, onMaterialG, materialG, rendererG, renderableG, flatG
  , renderWith3, render3
  , normalArrowG
  , cube, box3
  , sphere, usphere, frustum, cone, cylinder, torus
  , surfG, surfG'
  -- * Geometry filters
  , Filter3, move3, move3X, move3Y, move3Z, pivot3, andFlip3
  , pivot3X, pivot3Y, pivot3Z
	-- tmp
  ,vsurf
  )
  where

-- TODO: restore exports when i get this module compiling again

import Data.Monoid
import Control.Applicative

import Graphics.Rendering.OpenGL hiding (normal,frustum)
import qualified Graphics.Rendering.OpenGL as G

-- TypeCompose
import Control.Instances () -- IO monoid

import Data.VectorSpace
import Data.MemoTrie
import Data.Basis
import Data.Cross
import Data.AffineSpace

import Graphics.FieldTrip.Misc
import Graphics.FieldTrip.Vector2
import Graphics.FieldTrip.Vector3
import Graphics.FieldTrip.Normal3
import Graphics.FieldTrip.Point3
import Graphics.FieldTrip.Color
import Graphics.FieldTrip.Material
import Graphics.FieldTrip.Transform
import Graphics.FieldTrip.Transform3
import Graphics.FieldTrip.Render
import Graphics.FieldTrip.Geometry2
-- import Graphics.FieldTrip.Image

import Graphics.Formats

-- for parametric surfaces
import Data.Derivative ((:>),pureD,idD,powVal)
import qualified Graphics.FieldTrip.ParamSurf as P
import Graphics.FieldTrip.ParamSurf hiding (frustum,torus)

-- | 3D geometry
data Geometry3
   = EmptyG
   | UnionG     Geometry3 Geometry3
   | forall s. (Floating s, Real s, MatrixComponent s) =>
        TransformG (Transform3 s) Geometry3
   | RenderG Renderer
   | GContextG (Unop GContext) Geometry3
   -- temporary:
   | MaterialG MaterialTrans Geometry3
   -- TextureG   Image Geometry3
   -- LightG     LightType            -- embedded light     

-- TODO: textures & lights.  What interface to use for textures?  I'd like
-- to have a composable image type.

-- TODO: consider dropping EmptyG in favor of a trivial use of RenderG.
-- Possible drawback: loss of optimization.

-- Why represent 3d geometry as an algebraic type but 2d geometry as a
-- rendering action?  Because of embeddable lights and cameras, which can
-- be extracted by a first pass for rendering in a second pass.  We could
-- represent a geometry as a set of lights and cameras plus a rendering
-- action.  We'll probably want to gather up and use all of the lights,
-- but just one of the cameras.  Question: how to select an embedded camera?
-- 
-- Still -- make 2d & 3d consistent, even if currently unnecessary for 2d.
-- 
-- Why *embed* lights and cameras in the geometry instead of specifying
-- them separately?  Because then they can be placed deeply into the
-- scene, accumulating transforms, along with the visible geometry.

-- TODO: consider replacing RenderG with something more declarative,
-- such as a parametric surface and an image.  Then we could do other
-- things with geometry.

-- | Make a geometry from a rendering action.  The action must leave graphics
-- state as it found it.
rendererG :: Renderer -> Geometry3
rendererG = RenderG

renderableG :: Renderable a => a -> Geometry3
renderableG = rendererG . const . render

instance Monoid Geometry3 where
  mempty  = EmptyG
  mappend = UnionG  -- TODO: optimize

instance  (Floating s, Real s, MatrixComponent s)
     => Transform (Transform3 s) Geometry3  where
  (*%) = TransformG

-- | Modify the material in a geometry.  See also 'materialG'.
onMaterialG :: MaterialTrans -> Filter3
onMaterialG = MaterialG

-- | Replace the material of a geometry.  More generally, see 'onMaterialG'.
materialG :: Material -> Filter3
materialG = MaterialG . const

-- | Render the geometry, given a graphics context.  Leaves graphics state unchanged.
renderWith3 :: GContext -> Geometry3 -> IO ()
renderWith3 = flip renderIO

-- | Render the geometry with default graphics context.  See also 'renderWith3'.
render3 :: Geometry3 -> IO ()
render3 = renderWith3 defaultGC

-- | Use a graphics context transformer. 
-- TODO: rewrite onColor usi9ng renderUsing3.
renderUsing3 :: Unop GContext -> Geometry3 -> Geometry3
renderUsing3 = GContextG 

normalArrowG :: Col -> Filter3
normalArrowG col = renderUsing3 (\ gc -> gc { gcNormals = Just col })

-- -- | Flatten 3d geometry to 2d.
-- flatten :: Geometry3 -> Geometry2
-- flatten = renderer2 . renderIO

-- IO version.
renderIO :: Geometry3 -> Renderer
renderIO EmptyG              = mempty
renderIO (g `UnionG` g')     = renderIO g `mappend` renderIO g'
renderIO (xf `TransformG` g) = \ gc -> preservingMatrix $
                                   do tweakMatrix3 xf
                                      renderIO g (onErr (tweakError3 xf) gc)
renderIO (RenderG r)         = r
renderIO (GContextG f g)     = \ gc -> renderIO g (f gc)
renderIO (MaterialG i g)        = \ (GC err o norms) -> renderIO g (GC err (o.i) norms)

-- TODO: resolve inconsistency between style for tweaking err vs colortrans.


-- | Flat geometry
flatG :: Geometry2 -> Geometry3
flatG g2 = rendererG $ \ gc ->
              -- The 2d geometry likely omits normals, so set them all here.  If we
              -- don't, then normals from 3D geometry will contaminate 2D.
              G.normal (Normal3 0 0 (1 :: R)) >> renderWith2 gc g2


-- TODO: Get flatG and flatten to work together.  I'd like flatten to 

---- primitives

-- | Four-tuple.  Useful for making quadrilateral geometry.
data Quad p = Quad !p !p !p !p

-- Useful?
instance Functor Quad where
  f `fmap` Quad a b c d = Quad (f a) (f b) (f c) (f d)

-- TODO: Get flatG and flatten to work together.

-- Unit cube
cube :: Geometry3
cube = topBottom `mappend` pivoted xAxis `mappend` pivoted yAxis
 where
   topBottom = andFlip3 yAxis (move3Z (1/2 :: R) side)
--   side = flatG ubox2
   side = surfG (hfSurf (const 0))
   pivoted   = flip pivot3 topBottom
   xAxis, yAxis :: Vector3 R -- monomorphic versions
   xAxis = xVector3
   yAxis = yVector3

-- Box with given sizes in X, Y, and Z
box3 :: (MatrixComponent s, Real s, Floating s) =>
        s -> s -> s -> Geometry3
box3 sx sy sz = scale3 sx sy sz *% cube


-- TODO:
-- + more elegant/modular way to specify normals
-- + triangle fans


-- | Unit sphere
usphere :: Geometry3
usphere = surfG (sphere1 :: Surf (Vector2 R :> R))

-- | Sphere with given radius
sphere :: R -> Geometry3
sphere r = uscale3 r *% usphere

-- | Frustum of a cone, with given base radius, top radius, and height,
-- centered at origin.
frustum :: R -> R -> R -> Geometry3
frustum baseR topR h =
  surfG (P.frustum (pureD baseR) (pureD topR) (pureD h))

-- | Cone with given base radius and height, and height,
-- centered at origin..
cone :: R -> R -> Geometry3
cone r h = frustum r 0 h

-- | Cylinder with given radius and height, centered at origin, and height,
-- centered at origin..
cylinder :: R -> R -> Geometry3
cylinder r h = frustum r r h

-- | Torus with given radii for the sweep and the swept circle
torus :: R -> R -> Geometry3
torus sr cr = surfG (P.torus (pureD sr) (pureD cr))

-- General surface renderer
renderSurfG :: (Fractional s, Vertex b) =>
               (Vector2 s -> b) -> ErrorBound -> IO ()
renderSurfG f = logMemo (3/4) $ \ err -> sequence_ $
  let -- Surface samples.
      -- outs :: [[VN3 R]]
      outs = (fmap.fmap) f (params err)
  in
    [ renderPrimitive TriangleStrip $ sequence_ $
        [ vertex vn' >> vertex vn | vn <- row | vn' <- row' ]
      | row <- outs | row' <- tail outs ] 

renderNormalArrowsG :: (Vector2 R -> VN3 R) -> ErrorBound -> Col -> IO ()
renderNormalArrowsG f = logMemo (1/4) $ \ err col -> sequence_ $
  let -- Surface samples.
      -- outs :: [[VN3 R]]
      outs = (fmap.fmap) f (params err)
  in
    [ renderPrimitive Lines $ sequence_ $
        [ case vn of
	   (VN pt3 nor3) -> 
		color col >> vertex pt3 >> vertex (add err pt3 nor3) | vn <- row ]
      | row <- outs ]
  where add :: R -> Vertex3 R -> Normal3 R -> Vertex3 R
        add err (Vertex3 x y z) (Normal3 x' y' z') = Vertex3 (x + x' * err') (y + y' * err') (z + z' * err')
		where err' = sqrt err

-- | Parametric surface without texture
surfG :: Surf (Vector2 R :> R) -> Geometry3

surfG surf = rendererG $ \ (GC err fmat norms) ->
               do material (fmat defaultMat)
                  rsurf err
		  case norms of
		    Nothing   -> return ()
		    Just col' -> arrows err col'
 where
   -- out of the \ (GC ...) so computed once per surf, not once per gc
   the_surf = vsurf surf
   rsurf    = renderSurfG the_surf
   arrows   = renderNormalArrowsG the_surf

-- The types of surfG and related functions can be parameterized over
-- scalar types and material type.

-- | Parametric surface with texture
-- surfG' :: Surf (Vector2 R :> R) -> ImageC -> Geometry3
surfG' :: ( Floating s, InnerSpace s, Scalar s ~ s
          , HasBasis s, HasTrie (Basis s), Basis s ~ ()
          , VertexComponent s, NormalComponent s, Color c) =>
          Surf (Vector2 s :> s) -> ((s, s) -> c) -> Geometry3
surfG' surf img = rendererG $ \ (GC err _ _) -> rsurf err
 where
   -- out of the \ (GC ...) so computed once per surf, not once per gc
   rsurf = renderSurfG (vsurf' surf img)

-- TODO: refactor surfG' & surfG

-- type VNC s = VC (VN3 s) (Color4 s)

vsurf' :: ( InnerSpace s, Floating s, Scalar s ~ s
          , HasBasis s, HasTrie (Basis s), Basis s ~ ()) =>
          Surf (Vector2 s :> s) -> ((s,s) -> c) -> Vector2 s -> VC (VN3 s) c
vsurf' surf img = liftA2 VC (vsurf surf) (img . coords2)
 where
   coords2 (Vector2 x y) = (x,y)



-- Parameter space samples, based on error bound.  Should really depend on
-- the surface properties.  Redo later.
params :: forall s. Fractional s => ErrorBound -> [[Vector2 s]]
params err = [[Vector2 u v | u <- us] | v <- vs]
 where
   -- Steps/facets in u and in v.  Placeholder.
   -- TODO: consider how to distribute the error for surfaces.  Maybe use
   -- derivative bounds and adaptively tessellate.
   nu :: Int
   nu = round (recip err) `max` 1
   -- nv = ...
   du :: s
   du = recip (fromIntegral nu)
   -- dv = du                              -- recip (fromIntegral nv)
   -- nu+1 u samples, and nv+1 v samples
   us,vs :: [s]
   us = fmap ((subtract 0.5).(*du).fromIntegral) [0::Int .. nu]
   vs = us                     -- fmap ((*du).fromIntegral) [0::Int .. nu]

-- TODO: consider redoing tessellation functionally, i.e., generating a
-- list of OpenGL primitives instead of rendering them.  So far, I don't
-- see a benefit.


-- x',y',z' :: a :-* (a :> s)

-- look for a simpler formulation, exploiting linearity.  first collapse
-- @(a:>s, a:>s, a:>s)@ to @a:>(s,s,s)@.

-- vec3 = linearD (\ (x,y,z) -> Vector3 x y z)

-- type SurfPt s = Two s :> Three s
type SurfPt s = Vector2 s :> Vector3 s

vsurf :: ( InnerSpace s, Floating s, Scalar s ~ s
         , HasBasis s, HasTrie (Basis s), Basis s ~ ()) =>
         Surf (Vector2 s :> s) -> (Vector2 s -> VN3 s)
vsurf surf = toVN3 . vector3D . surf . unvector2D . idD

-- dId :: R2 -> R2 :> R2
-- unvec2 . dId :: R2 -> (R2:>R,R2:>R)
-- surf . unvec2 . dId :: R2 -> (R2:>R,R2:>R,R2:>R)
-- vec3 . surf . unvec2 . dId :: R2 -> R2 :> R3
-- toVN3 . vec3 . surf . unvec2 . dId :: R2 -> VN3

toVN3 :: ( Floating s, InnerSpace s, Scalar s ~ s
         , HasBasis s, HasTrie (Basis s)
         , HasNormal (SurfPt s), InnerSpace (SurfPt s)
         ) =>
         SurfPt s -> VN3 s

toVN3 v =
  VN (origin3 .+^ powVal v)
     (vectorToNormal3 (powVal (normal v)))


-- toVN3 :: a
-- toVN3 = error "toVN3"


---- Geometry3 filters

-- Geometry3 filter
type Filter3 = Geometry3 -> Geometry3

-- move3 :: R -> R -> R -> Filter3
move3 :: (MatrixComponent s, Real s, Floating s) =>
         s -> s -> s -> Filter3
move3 dx dy dz = (translate3 (Vector3 dx dy dz) *%)

move3X, move3Y, move3Z :: (MatrixComponent s, Real s, Floating s) =>
                          s -> Filter3
move3X dx = move3 dx 0 0
move3Y dy = move3 0 dy 0
move3Z dz = move3 0 0 dz

-- Rotate pi/2 about axis
pivot3 :: (MatrixComponent s, Floating s, Real s) =>
          Vector3 s -> Filter3
pivot3 axis = (rotate3 (pi/2) axis *%)

pivot3X, pivot3Y, pivot3Z :: Filter3
pivot3X = pivot3 (xVector3 :: Vector3 R)
pivot3Y = pivot3 (yVector3 :: Vector3 R)
pivot3Z = pivot3 (zVector3 :: Vector3 R)

-- A geometry plus its a rotated-by-pi version.
andFlip3 :: (MatrixComponent s, Floating s, Real s) =>
            Vector3 s -> Filter3
andFlip3 axis g = g `mappend` (rotate3 pi axis *% g)