module Graphics.Mars.Ply
( surface
, Surface()
, toPly
)
where
import Data.Array.IArray
import Data.Array.MArray
import Data.Array.IO
import Graphics.Mars.Array
import Data.Maybe
import Data.Array.Unboxed as U
import Data.Array as A
data Vertex = Vertex Float Float Float
data Face = Face Int Int Int Int
data Surface a = Surface (a Int Vertex) (a Int Face)
vertices :: UArray (Int, Int) Float -> Array Int Vertex
vertices a =
let b@(i, j) = U.bounds a
lindex = linearIndex b
al = [ (lindex (r, c), Vertex (fromIntegral c) (fromIntegral r) e)
| ((r, c), e) <- U.assocs a ]
in A.array (lindex i, lindex j) al
faces :: UArray (Int, Int) Float -> Array Int Face
faces a =
let b@(i, j) = U.bounds a
lindex = linearIndex b
bottomEdge' = bottomEdge a
rightEdge' = rightEdge a
l = [ if or [bottomEdge' (r, c), rightEdge' (r, c)]
then Nothing
else Just (Face
(lindex (r, c))
(lindex (r, c + 1))
(lindex (r + 1, c + 1))
(lindex (r + 1, c)))
| (r, c) <- U.indices a ]
l' = map fromJust (filter isJust l)
in A.listArray (0, length l' 1) l'
surface :: UArray (Int, Int) Float -> Surface Array
surface a = Surface (vertices a) (faces a)
header :: Surface Array -> String
header (Surface v f) =
"ply\n"
++ "format ascii 1.0\n"
++ "element vertex " ++ show numv ++ "\n"
++ "property float32 x\n"
++ "property float32 y\n"
++ "property float32 z\n"
++ "element face " ++ show numf ++ "\n"
++ "property list uint8 int32 vertex_index\n"
++ "end_header\n"
where (_, i2) = A.bounds v
(_, j2) = A.bounds f
numv = i2 + 1
numf = j2 + 1
asciiVertices :: Array Int Vertex -> String
asciiVertices a =
concat (map (\(Vertex x y z) ->
concat [show x, " ", show y, " ", show z, "\n"])
(A.elems a))
asciiFaces :: Array Int Face -> String
asciiFaces a =
concat (map (\(Face i1 i2 i3 i4) ->
concat ["4 ", show i1, " ", show i2, " ",
show i3, " ", show i4, "\n"])
(A.elems a))
toPly :: Surface Array -> String
toPly s@(Surface v f) = header s ++ asciiVertices v ++ asciiFaces f