module RSAGL.Modeling.Tesselation
(TesselatedSurface,
TesselatedElement(..),
tesselatedSurfaceToVertexCloud,
tesselateSurface,
tesselateGrid,
tesselatedElementToOpenGL,
unmapTesselatedElement)
where
import RSAGL.Math.Curve
import RSAGL.Auxiliary.Auxiliary
import RSAGL.Math.Affine
import RSAGL.Math.BoundingBox
import Data.List
import Control.Parallel.Strategies hiding (r0)
import Control.Arrow
import Graphics.Rendering.OpenGL.GL.BeginEnd
import RSAGL.Modeling.OpenGLPrimitives
import Text.Parsec.Prim
import Text.Parsec.String ()
import Data.Ord
import Control.Monad
import RSAGL.Math.Types
type TesselatedSurface a = [TesselatedElement a]
data TesselatedElement a =
TesselatedTriangleFan { tesselated_vertices :: [a] }
| TesselatedTriangleStrip { tesselated_vertices :: [a] }
| TesselatedTriangles { tesselated_vertices :: [a] }
deriving (Read,Show)
instance (AffineTransformable a) => AffineTransformable (TesselatedElement a) where
transform m (TesselatedTriangleFan as) = TesselatedTriangleFan $ transform m as
transform m (TesselatedTriangleStrip as) = TesselatedTriangleStrip $ transform m as
transform m (TesselatedTriangles as) = TesselatedTriangles $ transform m as
instance (NFData a) => NFData (TesselatedElement a) where
rnf (TesselatedTriangleFan as) = rnf as
rnf (TesselatedTriangleStrip as) = rnf as
rnf (TesselatedTriangles as) = rnf as
instance Functor TesselatedElement where
fmap f (TesselatedTriangleFan as) = TesselatedTriangleFan $ fmap f as
fmap f (TesselatedTriangleStrip as) = TesselatedTriangleStrip $ fmap f as
fmap f (TesselatedTriangles as) = TesselatedTriangles $ fmap f as
tesselatedSurfaceToVertexCloud :: TesselatedSurface a -> [a]
tesselatedSurfaceToVertexCloud = concatMap tesselated_vertices
instance (Bound3D a) => Bound3D (TesselatedElement a) where
boundingBox x = boundingBox $ tesselatedSurfaceToVertexCloud [x]
tesselateSurface :: Surface a -> (Integer,Integer) -> TesselatedSurface a
tesselateSurface s uv = tesselateGrid $
iterateSurface uv (zipSurface (,) (fmap fst uv_identity) s)
tesselateGrid :: [[(RSdouble,a)]] -> TesselatedSurface a
tesselateGrid = stripTriangles . map (selectiveShatter 5) .
concatMap (uncurry tesselateStrip) . doubles
selectiveShatter :: Int -> TesselatedElement a -> TesselatedElement a
selectiveShatter n e =
if isTriangles e || length (take n $ tesselated_vertices e) == n
then e else shatter e
shatter :: TesselatedElement a -> TesselatedElement a
shatter (TesselatedTriangleFan (a:as)) = TesselatedTriangles $ f as
where f (b:c:ds) = a:b:c:f (c:ds)
f _ = []
shatter (TesselatedTriangleStrip as) = TesselatedTriangles $ f as
where f (a:b:c:d:es) = a:b:c:c:b:d:f (c:d:es)
f _ = []
shatter x = x
stripTriangles :: TesselatedSurface a -> TesselatedSurface a
stripTriangles elems = TesselatedTriangles (concatMap tesselated_vertices triangles) : not_triangles
where f x = isTriangles x ||
map (const ()) (tesselated_vertices x) == [(),(),()]
triangles = filter f elems
not_triangles = filter (not . f) elems
isTriangles :: TesselatedElement a -> Bool
isTriangles (TesselatedTriangles _) = True
isTriangles _ = False
tesselateStrip :: [(RSdouble,a)] -> [(RSdouble,a)] -> TesselatedSurface a
tesselateStrip lefts rights = tesselate $ tesselateSteps lefts rights
data LR = L | R deriving (Eq)
otherLR :: LR -> LR
otherLR L = R
otherLR R = L
tesselateSteps :: [(RSdouble,a)] -> [(RSdouble,a)] -> [(LR,a)]
tesselateSteps lefts rights = map (second snd) $ sortBy (comparing $ fst . snd) $ map ((,) L) (reorder lefts) ++ map ((,) R) (reorder rights)
where reorder :: [(RSdouble,a)] -> [(RSdouble,a)]
reorder [] = []
reorder [a] = [a]
reorder (a:as) = a : map (\((x,_),(y,b)) -> ((x+y)/2,b)) (doubles (a:as))
type TesselationParser a = Parsec [(LR,a)] ()
vertex :: (LR -> Bool) -> TesselationParser a a
vertex testF = liftM snd $ tokenPrim (const "") (\x _ _ -> x) (\(lr,a) -> if testF lr then Just (lr,a) else Nothing)
pushback :: [(LR,a)] -> TesselationParser a ()
pushback as =
do setInput =<< liftM (as ++) getInput
return ()
triangleFan :: TesselationParser a (TesselatedElement a)
triangleFan = try (triangleFanSided L) <|> try (triangleFanSided R)
where triangleFanSided :: LR -> TesselationParser a (TesselatedElement a)
triangleFanSided x_side =
do let y_side = otherLR x_side
xs1 <- many $ vertex (== x_side)
y <- vertex $ (== y_side)
xs2 <- many $ vertex (== x_side)
let xs = xs1 ++ xs2
when (null $ drop 1 xs) $ fail "triangleFanSided: not enough x-vertices"
pushback $ if null xs2 then [(x_side,last xs1),(y_side,y)] else [(y_side,y),(x_side,last xs2)]
return $ TesselatedTriangleFan $ case x_side of
L -> y:xs
R -> y:reverse xs
triangleStrip :: TesselationParser a (TesselatedElement a)
triangleStrip =
do (pairs,pbs) <- liftM (first (concatMap $ \(x,y) -> [x,y]) . unzip) $ many $ try (opposingPair L) <|> try (opposingPair R)
when (null $ drop 2 pairs) $ fail "triangleStrip: not enough vertex pairs"
pushback $ last pbs
return $ TesselatedTriangleStrip pairs
where opposingPair :: LR -> TesselationParser a ((a,a),[(LR,a)])
opposingPair x_side =
do let y_side = otherLR x_side
x <- vertex (== x_side)
y <- vertex (== y_side)
return $ (case x_side of
L -> (y,x)
R -> (x,y),
[(x_side,x),(y_side,y)])
tesselate :: [(LR,a)] -> TesselatedSurface a
tesselate = either (error . ("tesselate: " ++) . show) id . runParser parser () ""
where parser =
do tesselated_surface <- many $ try triangleStrip <|> try triangleFan
skipMany (vertex $ const True)
return tesselated_surface
tesselatedElementToOpenGL :: (OpenGLPrimitive a) => Bool -> TesselatedElement a -> IO ()
tesselatedElementToOpenGL colors_on tesselated_element = renderPrimitives prim_mode colors_on as
where (prim_mode,as) = unmapTesselatedElement tesselated_element
unmapTesselatedElement :: TesselatedElement a -> (PrimitiveMode,[a])
unmapTesselatedElement (TesselatedTriangleFan as) = (TriangleFan,as)
unmapTesselatedElement (TesselatedTriangleStrip as) = (TriangleStrip,as)
unmapTesselatedElement (TesselatedTriangles as) = (Triangles,as)