keid-geometry 0.1.0.0 → 0.1.0.1
raw patch · 3 files changed
+193/−35 lines, 3 filesdep +mtldep +vector
Dependencies added: mtl, vector
Files
- ChangeLog.md +3/−1
- keid-geometry.cabal +3/−1
- src/Geometry/Icosphere.hs +187/−33
ChangeLog.md view
@@ -1,3 +1,5 @@ # Changelog for keid-geometry -## Unreleased changes+## 1.0.0.1++- Added an icosphere generator backed by a mutable vector.
keid-geometry.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: keid-geometry-version: 0.1.0.0+version: 0.1.0.1 synopsis: Geometry primitives for Keid engine. category: Game Engine author: IC Rainbow@@ -95,7 +95,9 @@ base >=4.7 && <5 , geomancy , keid-core+ , mtl , rio >=0.1.12.0 , rio-app+ , vector , vulkan default-language: Haskell2010
src/Geometry/Icosphere.hs view
@@ -1,48 +1,170 @@-module Geometry.Icosphere where+module Geometry.Icosphere+ ( generateIndexed + , icofaces+ , icopoints++ , icosphere+ , icotris_v1+ , subNormal+ , subdivide+ ) where+ import RIO import Data.List (iterate, (!!))-import RIO.Vector.Partial ((!))--import RIO.Vector qualified as Vector import Geomancy.Vec3 (Vec3, vec3) import Geomancy.Vec3 qualified as Vec3- import Resource.Model qualified as Model--icosphere :: (Vec3 -> attrs) -> Int -> [Model.Vertex Vec3.Packed attrs]-icosphere mkAttrs n = do- v <- reverse . concat $ subNormal n icotris_v1- pure Model.Vertex- { vPosition = Vec3.Packed v- , vAttrs = mkAttrs v- }+import Data.Vector qualified as Vector+import Data.Vector.Mutable qualified as Mutable+import RIO.Vector.Partial ((!))+import RIO.Map qualified as Map+import RIO.Vector.Storable qualified as Storable+import Control.Monad.State.Strict (get, put, runState)+import Vulkan.NamedType ((:::)) -subNormal :: Int -> [[Vec3]] -> [[Vec3]]-subNormal nu tris = map (map Vec3.normalize) $ subdivide nu tris+import Geometry.Face (Face(..)) -subdivide :: Int -> [[Vec3]] -> [[Vec3]]-subdivide frequency tris =- iterate (concatMap subdivideTri) tris !! (frequency - 1)+generateIndexed+ :: ( Fractional scale+ , Storable pos+ , Storable vertexAttr+ )+ => "subdivisions" ::: Natural+ -> "initial" ::: (Vec3 -> pointAttr)+ -> "midpoint" ::: (scale -> Vec3 -> pointAttr -> pointAttr -> pointAttr)+ -> "vertex" ::: (Vector (Vec3, pointAttr) -> [Face Int] -> Vector (pos, vertexAttr))+ -> "model vectors" ::: (Storable.Vector pos, Storable.Vector vertexAttr, Storable.Vector Word32)+generateIndexed details mkInitialAttrs mkMidpointAttrs mkVertices =+ ( Storable.convert pv+ , Storable.convert av+ , Storable.fromList iv+ ) where- subdivideTri = \case- [v1, v2, v3] ->- let- a = midpoint v1 v2- b = midpoint v2 v3- c = midpoint v3 v1- in- [ [ v1, a, c ]- , [ v2, b, a ]- , [ v3, c, b ]- , [ a, b, c ]- ]- _ ->- error "subdivideTri: not a triangle somehow"+ (pv, av) = Vector.unzip $ mkVertices finalPoints faces - midpoint a b = (a + b) / 2+ iv = do+ face <- faces+ vert <- toList face+ pure $ fromIntegral vert + (faces, (_midpoints, finalPoints, _finalPointsCount)) =+ runState+ (go icofaces details details)+ ( mempty+ , initialPoints+ , Vector.length icopoints+ )++ maxPoints = length icofaces * (4 ^ details) - 8++ initialPoints = Vector.create do+ v <- Mutable.new maxPoints+ Vector.imapM_+ (Mutable.unsafeWrite v)+ (Vector.map (id &&& mkInitialAttrs) icopoints)+ pure v++ go curFaces maxLevel curLevel = do+ -- traceShowM $ "Inflating level " <> textShow (maxLevel - curLevel)+ case curLevel of+ 0 ->+ pure curFaces+ _ -> do+ let scale = fromIntegral curLevel / fromIntegral maxLevel+ next <- traverse (subdivideFace scale) curFaces+ go (mconcat next) maxLevel (curLevel - 1)++ subdivideFace scale (Face a b c) = do+ (mids, points, numPoints) <- get++ let+ extras = mempty+ (midsAB, extrasAB, ab) = midpoint scale mids extras points numPoints (a, b)+ (midsBC, extrasBC, bc) = midpoint scale midsAB extrasAB points numPoints (b, c)+ (midsCA, extrasCA, ca) = midpoint scale midsBC extrasBC points numPoints (c, a)++ put+ ( midsCA+ , runST do+ old <- Vector.unsafeThaw points++ Vector.imapM_+ ( \i point ->+ Mutable.unsafeWrite old (numPoints + i) point+ )+ extrasCA++ Vector.unsafeFreeze old+ , numPoints + Vector.length extrasCA+ )++ pure+ [ Face ab bc ca+ , Face ca a ab+ , Face ab b bc+ , Face bc c ca+ ]++ midpoint scale mids extras points numPoints parents =+ case Map.lookup parents mids of+ Just knownIx ->+ ( mids+ , extras+ , knownIx+ )+ Nothing ->+ let+ (pos1, attr1) = points ! fst parents+ (pos2, attr2) = points ! snd parents+ midPos = Vec3.lerp 0.5 pos1 pos2++ newIx =+ numPoints ++ Vector.length extras++ point =+ ( midPos+ , mkMidpointAttrs scale midPos attr1 attr2+ )+ in+ ( Map.insert parents newIx mids+ , Vector.snoc extras point+ , newIx+ )++icofaces :: [Face Int]+icofaces =+ [ -- faces around point 0+ Face 5 11 0+ , Face 1 5 0+ , Face 7 1 0+ , Face 10 7 0+ , Face 11 10 0++ -- 5 adjacent faces+ , Face 9 5 1+ , Face 4 11 5+ , Face 2 10 11+ , Face 6 7 10+ , Face 8 1 7++ -- 5 adjacent faces around point 3+ , Face 4 9 3+ , Face 2 4 3+ , Face 6 2 3+ , Face 8 6 3+ , Face 9 8 3++ -- 5 adjacent faces+ , Face 5 9 4+ , Face 11 4 2+ , Face 10 2 6+ , Face 7 6 8+ , Face 1 8 9+ ]+ icopoints :: Vector Vec3 icopoints = Vector.fromList [ vec3 (-1) 0 t@@ -177,3 +299,35 @@ , icopoints ! 1 ] ]++icosphere :: (Vec3 -> attrs) -> Int -> [Model.Vertex Vec3.Packed attrs]+icosphere mkAttrs n = do+ v <- reverse . concat $ subNormal n icotris_v1+ pure Model.Vertex+ { vPosition = Vec3.Packed v+ , vAttrs = mkAttrs v+ }++subNormal :: Int -> [[Vec3]] -> [[Vec3]]+subNormal nu tris = map (map Vec3.normalize) $ subdivide nu tris++subdivide :: Int -> [[Vec3]] -> [[Vec3]]+subdivide frequency tris =+ iterate (concatMap subdivideTri) tris !! (frequency - 1)+ where+ subdivideTri = \case+ [v1, v2, v3] ->+ let+ a = midpoint v1 v2+ b = midpoint v2 v3+ c = midpoint v3 v1+ in+ [ [ v1, a, c ]+ , [ v2, b, a ]+ , [ v3, c, b ]+ , [ a, b, c ]+ ]+ _ ->+ error "subdivideTri: not a triangle somehow"++ midpoint a b = (a + b) / 2