module Graphics.FieldTrip.Geometry3
(
Geometry3, onMaterialG, materialG, rendererG, renderableG, flatG
, renderWith3, render3
, normalArrowG
, cube, box3
, sphere, usphere, frustrum, cone, cylinder, torus
, surfG, surfG'
, Filter3, move3, move3X, move3Y, move3Z, pivot3, andFlip3
, pivot3X, pivot3Y, pivot3Z
,vsurf
)
where
import Data.Monoid
import Control.Applicative
import Graphics.Rendering.OpenGL hiding (normal)
import qualified Graphics.Rendering.OpenGL as G
import Control.Instances ()
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.Formats
import Data.Derivative ((:>),pureD,idD,powVal)
import qualified Graphics.FieldTrip.ParamSurf as P
import Graphics.FieldTrip.ParamSurf hiding (frustrum,torus)
data Geometry3
= EmptyG
| UnionG Geometry3 Geometry3
| forall s. (Floating s, Real s, MatrixComponent s) =>
TransformG (Transform3 s) Geometry3
| RenderG Renderer
| GContextG (Unop GContext) Geometry3
| MaterialG MaterialTrans Geometry3
rendererG :: Renderer -> Geometry3
rendererG = RenderG
renderableG :: Renderable a => a -> Geometry3
renderableG = rendererG . const . render
instance Monoid Geometry3 where
mempty = EmptyG
mappend = UnionG
instance (Floating s, Real s, MatrixComponent s)
=> Transform (Transform3 s) Geometry3 where
(*%) = TransformG
onMaterialG :: MaterialTrans -> Filter3
onMaterialG = MaterialG
materialG :: Material -> Filter3
materialG = MaterialG . const
renderWith3 :: GContext -> Geometry3 -> IO ()
renderWith3 = flip renderIO
render3 :: Geometry3 -> IO ()
render3 = renderWith3 defaultGC
renderUsing3 :: Unop GContext -> Geometry3 -> Geometry3
renderUsing3 = GContextG
normalArrowG :: Col -> Filter3
normalArrowG col = renderUsing3 (\ gc -> gc { gcNormals = Just col })
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)
flatG :: Geometry2 -> Geometry3
flatG g2 = rendererG $ \ gc ->
G.normal (Normal3 0 0 (1 :: R)) >> renderWith2 gc g2
data Quad p = Quad !p !p !p !p
instance Functor Quad where
f `fmap` Quad a b c d = Quad (f a) (f b) (f c) (f d)
cube :: Geometry3
cube = topBottom `mappend` pivoted xAxis `mappend` pivoted yAxis
where
topBottom = andFlip3 yAxis (move3Z (1/2 :: R) side)
side = surfG (hfSurf (const 0))
pivoted = flip pivot3 topBottom
xAxis, yAxis :: Vector3 R
xAxis = xVector3
yAxis = yVector3
box3 :: (MatrixComponent s, Real s, Floating s) =>
s -> s -> s -> Geometry3
box3 sx sy sz = scale3 sx sy sz *% cube
usphere :: Geometry3
usphere = surfG (sphere1 :: Surf (Vector2 R :> R))
sphere :: R -> Geometry3
sphere r = uscale3 r *% usphere
frustrum :: R -> R -> R -> Geometry3
frustrum baseR topR h =
surfG (P.frustrum (pureD baseR) (pureD topR) (pureD h))
cone :: R -> R -> Geometry3
cone r h = frustrum r 0 h
cylinder :: R -> R -> Geometry3
cylinder r h = frustrum r r h
torus :: R -> R -> Geometry3
torus sr cr = surfG (P.torus (pureD sr) (pureD cr))
renderSurfG :: (Fractional s, Vertex b) =>
(Vector2 s -> b) -> ErrorBound -> IO ()
renderSurfG f = logMemo (3/4) $ \ err -> sequence_ $
let
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
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
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
the_surf = vsurf surf
rsurf = renderSurfG the_surf
arrows = renderNormalArrowsG the_surf
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
rsurf = renderSurfG (vsurf' surf img)
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)
params :: forall s. Fractional s => ErrorBound -> [[Vector2 s]]
params err = [[Vector2 u v | u <- us] | v <- vs]
where
nu :: Int
nu = round (recip err) `max` 1
du :: s
du = recip (fromIntegral nu)
us,vs :: [s]
us = fmap ((subtract 0.5).(*du).fromIntegral) [0::Int .. nu]
vs = us
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
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)))
type Filter3 = Geometry3 -> Geometry3
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
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)
andFlip3 :: (MatrixComponent s, Floating s, Real s) =>
Vector3 s -> Filter3
andFlip3 axis g = g `mappend` (rotate3 pi axis *% g)