118 lines
3.3 KiB
Haskell
118 lines
3.3 KiB
Haskell
module Polyhedra
|
|
where
|
|
import Geometry
|
|
--import Geometry.Data
|
|
import Geometry.Vector3D
|
|
import Polyhedra.Data
|
|
import Picture.Data
|
|
import Picture
|
|
|
|
import Data.Maybe
|
|
import Data.List
|
|
import Data.Bifunctor
|
|
import Control.Lens
|
|
--import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
|
|
|
translateXY :: Float -> Float -> Polyhedra -> Polyhedra
|
|
translateXY x y = pyFaces %~ map (map $ first tran)
|
|
where
|
|
tran (V3 a b c) = V3 (a+x) (b+y) c
|
|
|
|
rotateXY :: Float -> Polyhedra -> Polyhedra
|
|
rotateXY a = over pyFaces $ map $ map $ first $ rotate3 a
|
|
|
|
-- Another representation of polyhedra is as a list of edges.
|
|
-- 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.
|
|
--, _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) = (\(_,_,n) -> (x,y,z,n))
|
|
<$> find (\(a,b,_) -> (x,y) == (b,a)) otherEdges
|
|
|
|
faceEdges :: [Point3] -> [(Point3,Point3,Point3)]
|
|
faceEdges xs = zipWith addNormal 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]
|
|
{-# INLINE rhombus #-}
|
|
rhombus a b =
|
|
[V3 0 0 0
|
|
,a
|
|
,a +.+.+ b
|
|
,b
|
|
]
|
|
boxXYZnobase :: Float -> Float -> Float -> [[Point3]]
|
|
{-# INLINE boxXYZnobase #-}
|
|
boxXYZnobase x y z =
|
|
[ map (+.+.+ V3 0 0 z) $ reverse bottomFace
|
|
, frontFace
|
|
, map (+.+.+ V3 0 y 0) $ reverse frontFace
|
|
, sideFace
|
|
, map (+.+.+ V3 x 0 0) $ reverse sideFace
|
|
]
|
|
where
|
|
bottomFace = rhombus (V3 0 y 0) (V3 x 0 0)
|
|
frontFace = rhombus (V3 x 0 0) (V3 0 0 z)
|
|
sideFace = rhombus (V3 0 0 z) (V3 0 y 0)
|
|
|
|
boxXYZ :: Float -> Float -> Float -> [[Point3]]
|
|
{-# INLINE boxXYZ #-}
|
|
boxXYZ x y z =
|
|
[ bottomFace
|
|
, map (+.+.+ V3 0 0 z) $ reverse bottomFace
|
|
, frontFace
|
|
, map (+.+.+ V3 0 y 0) $ reverse frontFace
|
|
, sideFace
|
|
, map (+.+.+ V3 x 0 0) $ reverse sideFace
|
|
]
|
|
where
|
|
bottomFace = rhombus (V3 0 y 0) (V3 x 0 0)
|
|
frontFace = rhombus (V3 x 0 0) (V3 0 0 z)
|
|
sideFace = rhombus (V3 0 0 z) (V3 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
|
|
|
|
polyToPics :: Polyhedra -> [Picture]
|
|
polyToPics = map helpPoly3D . _pyFaces
|
|
|
|
helpPoly3D :: [(Point3, Point4)] -> Picture
|
|
--{-# INLINE helpPoly3D #-}
|
|
helpPoly3D vs = map f $ polyToTris vs
|
|
where
|
|
f (pos,col) = Verx pos col [] 0 polyNum
|
|
|
|
polysToPic :: [Polyhedra] -> Picture
|
|
polysToPic = pictures . concatMap polyToPics
|
|
|
|
polyToEdges :: Polyhedra -> [(Point3,Point3,Point3,Point3)]
|
|
polyToEdges = constructEdges . map (map fst) . _pyFaces
|
|
|
|
polyToGeoRender :: Polyhedra -> [Point3]
|
|
polyToGeoRender = concatMap (polyToTris . map fst) . _pyFaces
|