141 lines
3.8 KiB
Haskell
141 lines
3.8 KiB
Haskell
module Polyhedra
|
|
( translateXY
|
|
, rotateXY
|
|
, polyToEdges
|
|
, constructEdgesList
|
|
, boxXYZ
|
|
, boxABC
|
|
, boxXYZnobase
|
|
, polyToGeoRender
|
|
, polysToPic
|
|
) where
|
|
import Geometry
|
|
import Polyhedra.Data
|
|
import Picture.Data
|
|
import Picture
|
|
|
|
import Data.Maybe
|
|
import Data.List
|
|
import Data.Bifunctor
|
|
import Control.Lens
|
|
import qualified Streaming.Prelude as S
|
|
|
|
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
|
|
|
|
constructEdges :: [[Point3]] -> [(Point3,Point3,Point3,Point3)]
|
|
constructEdges (face:faces) = mapMaybe (findReverseEdge otherEdges) (faceEdges face)
|
|
++ constructEdges faces
|
|
where
|
|
otherEdges = concatMap faceEdges faces
|
|
constructEdges _ = []
|
|
|
|
-- | a version of construct edges that directly returns the flattened list of
|
|
-- tuples
|
|
constructEdgesList :: [[Point3]] -> [Point3]
|
|
constructEdgesList (face:faces) = concatMap (findReverseEdgeList otherEdges) (faceEdges face)
|
|
++ constructEdgesList faces
|
|
where
|
|
otherEdges = concatMap faceEdges faces
|
|
constructEdgesList _ = []
|
|
|
|
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
|
|
|
|
findReverseEdgeList
|
|
:: [(Point3,Point3,Point3)]
|
|
-> (Point3,Point3,Point3)
|
|
-> [Point3]
|
|
findReverseEdgeList a b = case findReverseEdge a b of
|
|
Nothing -> []
|
|
Just (x,y,z,w) -> [x,y,z,w]
|
|
|
|
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
|
|
helpPoly3D = S.each . map f . polyToTris
|
|
where
|
|
f (pos,col) = Verx pos col [] BottomLayer polyNum
|
|
|
|
polysToPic :: [Polyhedra] -> Picture
|
|
polysToPic = pictures . concatMap polyToPics
|
|
|
|
polyToEdges :: Polyhedra -> [(Point3,Point3,Point3,Point3)]
|
|
polyToEdges = map denormalEdges . constructEdges . map (map fst) . _pyFaces
|
|
|
|
denormalEdges :: (Point3,Point3,Point3,Point3) -> (Point3,Point3,Point3,Point3)
|
|
denormalEdges (a,b,n,m) = (a,b,a - x, b - y)
|
|
where
|
|
x = crossProd (b - a) n
|
|
y = crossProd (a - b) m
|
|
|
|
polyToGeoRender :: Polyhedra -> [Point3]
|
|
polyToGeoRender = concatMap (polyToTris . map fst) . _pyFaces
|