keid-geometry 0.1.1.1 → 0.1.1.2

raw patch · 5 files changed

+284/−19 lines, 5 filesdep ~keid-corePVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: keid-core

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• keid-geometry.cabal +4/−2
• src/Geometry/Quad.hs +32/−17
• src/Geometry/Tile/Microblob.hs +144/−0
• src/Geometry/Tile/Neighbors.hs +99/−0

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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"+  }