74 lines
2.2 KiB
Haskell
74 lines
2.2 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
module Polyhedra.Geodesic
|
|
where
|
|
import Geometry.Data
|
|
import Geometry.Vector3D
|
|
import Polyhedra.Data
|
|
|
|
import Data.List
|
|
import qualified Data.Map as M
|
|
|
|
icosahedronPoints :: [Point3]
|
|
icosahedronPoints = concat
|
|
[ [V3 0 one gr, V3 one gr 0, V3 gr 0 one]
|
|
| one <- [-1,1]
|
|
, gr <- [negate (1 + sqrt 5)/2, (1 + sqrt 5)/2 ]
|
|
]
|
|
|
|
icosohedronFaces :: [[Point3]]
|
|
icosohedronFaces = map orderFace $
|
|
rectEdgeFaces ++ map (map rotTrip) rectEdgeFaces ++ map (map (rotTrip . rotTrip)) rectEdgeFaces
|
|
++ addSym negFst (addSym negSnd $ addSym negThd rectCornFace)
|
|
where
|
|
rectEdgeFaces = addSym negThd $ addSym negFst rectEdgeFace
|
|
rectEdgeFace = [[ (gr,1,0) , (gr,negate 1,0) , (1,0,gr) ]]
|
|
rectCornFace = [[ (gr,1,0) , (0,gr,1) , (1,0,gr) ]]
|
|
addSym f faces = map (map f) faces ++ faces
|
|
negFst (x,y,z) = (negate x,y,z)
|
|
negSnd (x,y,z) = (x,negate y,z)
|
|
negThd (x,y,z) = (x,y,negate z)
|
|
rotTrip (x,y,z) = (z,x,y)
|
|
gr = (1 + sqrt 5) / 2 :: Float
|
|
orderFace ps = undefined orderAround3 ps
|
|
|
|
-- | Assuming that this works, note that it relies heavily on the ordering of
|
|
-- faces adjacent to a vertex (clockwise around the vertex)
|
|
-- and vertices on faces (anticlockwise around center of face).
|
|
truncate :: Ord a => VF a -> VF (a,a)
|
|
truncate vf = VF
|
|
{ _vertices = M.fromList . concatMap f $ M.toList vmap
|
|
}
|
|
where
|
|
vmap = _vertices vf
|
|
f (i, (pos, faces)) = map (g i pos faces) faces
|
|
g i pos faces (j:_) =
|
|
((i,j)
|
|
, (0.5 *.*.* (pos +.+.+ fst (vmap M.! j))
|
|
,truncFaces i j faces
|
|
)
|
|
)
|
|
g _ _ _ _ = undefined
|
|
|
|
truncFaces :: Eq a => a -> a -> [[a]] -> [[(a,a)]]
|
|
truncFaces v n vss =
|
|
[ reverse $ map ((v,) . head) (f1:fs)
|
|
, g (n:f0) ++ [(n,v)]
|
|
, (n,v) : g (f1 ++ [v])
|
|
]
|
|
where
|
|
(f0:f1:fs) = rotateTo ((== n) . head) vss
|
|
g (x:y:xs) = [(x,y),(y,x)] ++ g (y:xs)
|
|
g _ = []
|
|
|
|
rotateTo :: (a -> Bool) -> [a] -> [a]
|
|
rotateTo p xs = ys ++ zs
|
|
where
|
|
(zs,ys) = break p xs
|
|
|
|
facesToVF :: Ord a => [[a]] -> M.Map a [[a]]
|
|
facesToVF faces = foldr f M.empty vs
|
|
where
|
|
vs = nub $ concat faces
|
|
f v = M.insert v (g v)
|
|
g v = map (tail . rotateTo (== v)) $ filter (elem v) faces
|