Add various helpers for creating polyhedra

src/Polyhedra.hs

@@ -0,0 +1,76 @@
+module Polyhedra
+    where
+import Geometry.Data
+import Geometry.Vector3D
+
+import Data.Maybe
+import Data.List
+
+-- | Polyhedra are represented using two types of data: 
+-- 1. a list of faces,
+-- 2. a list of edges.
+-- Each face is a list of points that are assumed to lie on a plane, and be
+-- ordered to form an anticlockwise convex polygon within that plane.
+-- Each edge is a tuple containing four points: the first two are the two edge
+-- coordinates, the last two being the normals of two planes of the polyhedra
+-- that the edge connects.
+data Polyhedra = Polyhedron
+    { _pyFaces :: [[Point3]]
+    , _pyEdges :: [(Point3,Point3,Point3,Point3)]
+    }
+
+constructEdges :: [[Point3]] -> [(Point3,Point3,Point3,Point3)]
+constructEdges (face:faces) = mapMaybe (findReverseEdge otherEdges) (faceEdges face) 
+    ++ constructEdges faces
+  where
+    otherEdges = concatMap faceEdges faces
+constructEdges _ = []
+
+findReverseEdge 
+    :: [(Point3,Point3,Point3)] 
+    -> (Point3,Point3,Point3) 
+    -> Maybe (Point3,Point3,Point3,Point3)
+findReverseEdge otherEdges (x,y,z) = fmap (\(_,_,n) -> (x,y,z,n))
+    $ find (\(a,b,_) -> (x,y) == (b,a)) otherEdges
+
+faceEdges :: [Point3] -> [(Point3,Point3,Point3)]
+faceEdges xs = map addNormal $ zip xs (tail xs ++ [head xs])
+  where
+    addNormal (x,y) = (x,y,n)
+    (a:b:c:_) = xs
+    n = crossProd (b -.-.- a) (c -.-.- a)
+
+rhombus :: Point3 -> Point3 -> [Point3]
+rhombus a b = 
+    [(0,0,0)
+    ,a
+    ,a +.+.+ b
+    ,b
+    ]
+
+boxXYZ :: Float -> Float -> Float -> [[Point3]]
+boxXYZ x y z = 
+    [ bottomFace
+    , map (+.+.+ (0,0,z)) $ reverse bottomFace
+    , frontFace
+    , map (+.+.+ (0,y,0)) $ reverse frontFace
+    , sideFace
+    , map (+.+.+ (x,0,0)) $ reverse sideFace
+    ]
+  where
+    bottomFace = rhombus (0,y,0) (x,0,0) 
+    frontFace  = rhombus (x,0,0) (0,0,z)
+    sideFace   = rhombus (0,0,z) (0,y,0)
+boxABC :: Point3 -> Point3 -> Point3 -> [[Point3]]
+boxABC a b c =
+    [ faceNC
+    , map (+.+.+ c) $ reverse faceNC
+    , faceNB
+    , map (+.+.+ b) $ reverse faceNB
+    , faceNA
+    , map (+.+.+ a) $ reverse faceNA
+    ]
+  where
+    faceNC = rhombus b a
+    faceNB = rhombus a c
+    faceNA = rhombus c b