diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for keid-geometry +## 0.1.1.2 + +- Added `Geometry.Tile.Neighbors` collection and bitset-based adjacency tests. +- Added `Geometry.Tile.Microblob` collection for sub-grid synthesis of "blob" tileset. + ## 0.1.1.1 - Added ray-plane intersection and related types. diff --git a/keid-geometry.cabal b/keid-geometry.cabal --- a/keid-geometry.cabal +++ b/keid-geometry.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: keid-geometry -version: 0.1.1.1 +version: 0.1.1.2 synopsis: Geometry primitives for Keid engine. category: Game Engine author: IC Rainbow @@ -33,6 +33,8 @@ Geometry.Plane Geometry.Quad Geometry.Ray + Geometry.Tile.Microblob + Geometry.Tile.Neighbors other-modules: Paths_keid_geometry hs-source-dirs: @@ -98,7 +100,7 @@ build-depends: base >=4.7 && <5 , geomancy - , keid-core + , keid-core >=0.1.6.1 , mtl , rio >=0.1.12.0 , vector diff --git a/src/Geometry/Quad.hs b/src/Geometry/Quad.hs --- a/src/Geometry/Quad.hs +++ b/src/Geometry/Quad.hs @@ -6,6 +6,10 @@ , toVertices , toVertices2 + , indicesQuad + , indicesWire + , indices + , quadPositions , quadUV , quadNormals @@ -17,6 +21,7 @@ import Geomancy.Vec3 qualified as Vec3 import Resource.Model (Vertex(..)) +import Resource.Collection (Generic1, Generically1(..), enumerate) data Quad a = Quad { quadLT :: a @@ -24,23 +29,8 @@ , quadLB :: a , quadRB :: a } - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -instance Applicative Quad where - {-# INLINE pure #-} - pure x = Quad - { quadLT = x - , quadRT = x - , quadLB = x - , quadRB = x - } - - funcs <*> args = Quad - { quadLT = quadLT funcs $ quadLT args - , quadRT = quadRT funcs $ quadRT args - , quadLB = quadLB funcs $ quadLB args - , quadRB = quadRB funcs $ quadRB args - } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1) + deriving Applicative via Generically1 Quad -- | 2 clockwise ordered triangles toVertices :: Quad (Vertex pos attrs) -> [Vertex pos attrs] @@ -53,6 +43,31 @@ toVertices2 q = vertices <> reverse vertices where vertices = toVertices q + +{-# SPECIALIZE indicesQuad :: [Word32] #-} +indicesQuad :: Num a => [a] +indicesQuad = + [ quadLT, quadRT, quadLB + , quadLB, quadRT, quadRB + ] + where + Quad{..} = indices + +{-# SPECIALIZE indicesWire :: [Word32] #-} +indicesWire :: Num a => [a] +indicesWire = + [ quadLT, quadRT + , quadRT, quadRB + , quadRB, quadLB + , quadLB, quadLT + ] + where + Quad{..} = indices + +{-# SPECIALIZE indices :: Quad Int #-} +{-# SPECIALIZE indices :: Quad Word32 #-} +indices :: Num a => Quad a +indices = fmap fst . enumerate $ pure () coloredQuad :: Vec4 -> Quad (Vertex Vec3.Packed Vec4) coloredQuad color = Vertex <$> quadPositions <*> pure color diff --git a/src/Geometry/Tile/Microblob.hs b/src/Geometry/Tile/Microblob.hs new file mode 100644 --- /dev/null +++ b/src/Geometry/Tile/Microblob.hs @@ -0,0 +1,144 @@ +module Geometry.Tile.Microblob + ( Microblob(..) + , indices + , names + , quad + + , genSets + ) where + +import RIO + +import Data.Bits +import Geometry.Quad (Quad(..)) +import Geometry.Tile.Neighbors (Neighbors(..)) +import Resource.Collection (Generic1, Generically1(..), enumerate) +import RIO.Map qualified as Map +import RIO.Set qualified as Set + +data Microblob a = Microblob + { brCornerInner :: a + , blCornerInner :: a + , trCornerInner :: a + , tlCornerInner :: a + , tlCornerOuter :: a + , ttEdgeHorizontal :: a + , trCornerOuter :: a + , llEdgeVertical :: a + , full :: a + , rrEdgeVertical :: a + , blCornerOuter :: a + , bbEdgeHorizontal :: a + , brCornerOuter :: a + } + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1) + deriving Applicative via Generically1 Microblob + +indices :: Microblob Int +indices = fmap fst . enumerate $ pure () + +names :: Microblob Text +names = Microblob + { brCornerInner = "brCornerInner" + , blCornerInner = "blCornerInner" + , trCornerInner = "trCornerInner" + , tlCornerInner = "tlCornerInner" + , tlCornerOuter = "tlCornerOuter" + , ttEdgeHorizontal = "ttEdgeHorizontal" + , trCornerOuter = "trCornerOuter" + , llEdgeVertical = "llEdgeVertical" + , full = "full" + , rrEdgeVertical = "rrEdgeVertical" + , blCornerOuter = "blCornerOuter" + , bbEdgeHorizontal = "bbEdgeHorizontal" + , brCornerOuter = "brCornerOuter" + } + +quad :: Neighbors Int -> Microblob a -> Int -> Quad a +quad Neighbors{..} Microblob{..} index = Quad + { quadLT = + if iNorth && iWest then + if testBit index northWest then + full + else + tlCornerInner + else + if iNorth then + llEdgeVertical + else + if iWest then + ttEdgeHorizontal + else + tlCornerOuter + + , quadRT = + if iNorth && iEast then + if testBit index northEast then + full + else + trCornerInner + else + if iNorth then + rrEdgeVertical + else + if iEast then + ttEdgeHorizontal + else + trCornerOuter + + , quadLB = + if iSouth && iWest then + if testBit index southWest then + full + else + blCornerInner + else + if iSouth then + llEdgeVertical + else + if iWest then + bbEdgeHorizontal + else + blCornerOuter + + , quadRB = + if iSouth && iEast then + if testBit index southEast then + full + else + brCornerInner + else + if iSouth then + rrEdgeVertical + else + if iEast then + bbEdgeHorizontal + else + brCornerOuter + } + where + iNorth = testBit index north + iWest = testBit index west + iEast = testBit index east + iSouth = testBit index south + +genSets :: Neighbors Int -> (Set Int, Map Int Int) +genSets bits = foldl' @[] f (Set.empty, Map.empty) [0..255] + where + Neighbors{..} = bits + + f (uniq, dups) i = + ( Set.insert index uniq + , Map.insert i index dups + ) + where + index = i + & bool (clearBit northWest) id (iNorth && iWest) + & bool (clearBit northEast) id (iNorth && iEast) + & bool (clearBit southWest) id (iSouth && iWest) + & bool (clearBit southEast) id (iSouth && iEast) + + iNorth = testBit i north + iWest = testBit i west + iEast = testBit i east + iSouth = testBit i south diff --git a/src/Geometry/Tile/Neighbors.hs b/src/Geometry/Tile/Neighbors.hs new file mode 100644 --- /dev/null +++ b/src/Geometry/Tile/Neighbors.hs @@ -0,0 +1,99 @@ +module Geometry.Tile.Neighbors + ( Neighbors(..) + , nobody + , everyone + + , bitsNW + , testBitsNW + , fromBitsNW + , toBitsNW + + , directionsWith + , isCorner + , names + ) where + +import RIO + +import Data.Bits +import Resource.Collection (Generic1, Generically1(..), enumerate) + +nobody :: Neighbors Bool +nobody = pure False + +everyone :: Neighbors Bool +everyone = pure True + +data Neighbors a = Neighbors + { northWest :: a + , north :: a + , northEast :: a + , east :: a + , southEast :: a + , south :: a + , southWest :: a + , west :: a + } + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1) + deriving Applicative via Generically1 Neighbors + +bitsNW :: Neighbors Int +bitsNW = fmap fst . enumerate $ pure () + +{-# INLINE testBitsNW #-} +testBitsNW :: Bits a => Neighbors (a -> Bool) +testBitsNW = + bitsNW <&> \i packed -> + testBit packed i + +{-# INLINE fromBitsNW #-} +fromBitsNW :: Bits a => a -> Neighbors Bool +fromBitsNW packed = + testBitsNW <&> \test -> + test packed + +{-# INLINE toBitsNW #-} +toBitsNW :: Neighbors Bool -> Int +toBitsNW = toBits bitsNW + +{-# INLINE toBits #-} +toBits :: Neighbors Int -> Neighbors Bool -> Int +toBits bits = foldl' (flip (.|.)) zeroBits . liftA2 toBit bits + where + toBit i = bool zeroBits (bit i) + +directionsWith :: (Num a) => (a -> a -> b) -> Neighbors b +directionsWith f = Neighbors + { northWest = f (-1) (-1) + , north = f 0 (-1) + , northEast = f 1 (-1) + , east = f 1 0 + , southEast = f 1 1 + , south = f 0 1 + , southWest = f (-1) 1 + , west = f (-1) 0 + } + +isCorner :: Neighbors Bool +isCorner = Neighbors + { northWest = True + , north = False + , northEast = True + , east = False + , southEast = True + , south = False + , southWest = True + , west = False + } + +names :: IsString a => Neighbors a +names = Neighbors + { northWest = "nw" + , north = "n" + , northEast = "ne" + , east = "e" + , southEast = "se" + , south = "s" + , southWest = "sw" + , west = "w" + }