module Data.Geometry.LegacyVTK (
Geometry(..)
, Point(..)
, Points
, Attribute(..)
, makeVTK
) where
import Data.List (nub, sort)
import Data.Maybe (fromJust)
import Data.Scientific (Scientific)
import Prelude hiding (lines)
import qualified Data.Map.Strict as M (Map, fromList, keys, lookup)
data Geometry =
StructuredPoints
{
xDimension, yDimension, zDimension :: Int
, xOrigin, yOrigin, zOrigin :: Scientific
, xSpacing, ySpacing, zSpacing :: Scientific
}
| StructuredGrid
{
xDimension, yDimension, zDimension :: Int
, points :: Points
}
| UnstructuredGrid
{
points :: Points
, cells :: [Points]
, cellTypes :: [Int]
}
| PolyData
{
points :: Points
, vertices :: [Points]
, lines :: [Points]
, polygons :: [Points]
, triangleStrips :: [Points]
}
| RectilinearGrid
{
xDimension, yDimension, zDimension :: Int
, xCoordinates, yCoordinates, zCoordinates :: [Scientific]
}
| Field
deriving (Eq, Read, Show)
data Point = Point {x, y, z :: Scientific}
deriving (Eq, Ord, Read, Show)
type Points = [Point]
data Attribute =
Scalar
| ColorScalar
| LookupTable
| Vector
| Normal
| TextureCoordinate
| Tensor
| FieldData
deriving (Eq, Read, Show)
makeVTK
:: String
-> Geometry
-> Maybe Attribute
-> Maybe Attribute
-> [String]
makeVTK title geometry _ _ =
[
"# vtk DataFile Version 2.0"
, title
, "ASCII"
]
++
makeVTK' geometry
makeVTK' :: Geometry -> [String]
makeVTK' PolyData{..} =
let
pointMap :: M.Map Point Int
pointMap =
M.fromList
$ zip
(sort $ nub $ points ++ concat vertices ++ concat lines ++ concat polygons ++ concat triangleStrips)
[0..]
points' :: [Point]
points' = M.keys pointMap
in
[
"DATASET POLYDATA"
, "POINTS " ++ show (length points') ++ " double"
]
++
map (\Point{..} -> unwords $ map show [x, y, z]) points'
++
["POLYGONS " ++ show (length polygons) ++ " " ++ show (length polygons + length (concat polygons))]
++
map (\ps -> unwords $ map show $ length ps : map (fromJust . (`M.lookup` pointMap)) ps) polygons
makeVTK' _ = undefined