about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Generators/Util.hs
diff options
context:
space:
mode:
authorGriffin Smith <grfn@gws.fyi>2021-04-11T21·53-0400
committerglittershark <grfn@gws.fyi>2021-04-12T14·45+0000
commit6266c5d32f9ff651fcfc3a4cc0c68e89da56ca65 (patch)
tree5be3967585787c4456e17cb29423770217fdcede /users/grfn/xanthous/src/Xanthous/Generators/Util.hs
parent968effb5dc1a4617a0dceaffc70e986abe300c6e (diff)
refactor(users/glittershark): Rename to grfn r/2485
Rename my //users directory and all places that refer to glittershark to
grfn, including nix references and documentation.

This may require some extra attention inside of gerrit's database after
it lands to allow me to actually push things.

Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: lukegb <lukegb@tvl.fyi>
Reviewed-by: glittershark <grfn@gws.fyi>
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Generators/Util.hs')
-rw-r--r--users/grfn/xanthous/src/Xanthous/Generators/Util.hs220
1 files changed, 220 insertions, 0 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Util.hs
new file mode 100644
index 000000000000..88aadd5aadd9
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Generators/Util.hs
@@ -0,0 +1,220 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
+module Xanthous.Generators.Util
+  ( MCells
+  , Cells
+  , CellM
+  , randInitialize
+  , initializeEmpty
+  , numAliveNeighborsM
+  , numAliveNeighbors
+  , fillOuterEdgesM
+  , cloneMArray
+  , floodFill
+  , regions
+  , fillAll
+  , fillAllM
+  , fromPoints
+  , fromPointsM
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (Foldable, toList, for_)
+--------------------------------------------------------------------------------
+import           Data.Array.ST
+import           Data.Array.Unboxed
+import           Control.Monad.ST
+import           Control.Monad.Random
+import           Data.Monoid
+import           Data.Foldable (Foldable, toList, for_)
+import qualified Data.Set as Set
+import           Data.Semigroup.Foldable
+import           Linear.V2
+--------------------------------------------------------------------------------
+import           Xanthous.Util (foldlMapM', maximum1, minimum1)
+import           Xanthous.Data (Dimensions, width, height)
+--------------------------------------------------------------------------------
+
+type MCells s = STUArray s (V2 Word) Bool
+type Cells = UArray (V2 Word) Bool
+type CellM g s a = RandT g (ST s) a
+
+randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s)
+randInitialize dims aliveChance = do
+  res <- initializeEmpty dims
+  for_ [0..dims ^. width] $ \i ->
+    for_ [0..dims ^. height] $ \j -> do
+      val <- (>= aliveChance) <$> getRandomR (0, 1)
+      lift $ writeArray res (V2 i j) val
+  pure res
+
+initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s)
+initializeEmpty dims =
+  lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False
+
+numAliveNeighborsM
+  :: forall a i m
+  . (MArray a Bool m, Ix i, Integral i)
+  => a (V2 i) Bool
+  -> V2 i
+  -> m Word
+numAliveNeighborsM cells (V2 x y) = do
+  cellBounds <- getBounds cells
+  getSum <$> foldlMapM'
+    (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds)
+    neighborPositions
+
+  where
+    boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool
+    boundedGet (V2 minX minY, V2 maxX maxY) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = pure True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in readArray cells $ V2 nx ny
+
+numAliveNeighbors
+  :: forall a i
+  . (IArray a Bool, Ix i, Integral i)
+  => a (V2 i) Bool
+  -> V2 i
+  -> Word
+numAliveNeighbors cells (V2 x y) =
+  let cellBounds = bounds cells
+  in getSum $ foldMap
+      (Sum . fromIntegral . fromEnum . boundedGet cellBounds)
+      neighborPositions
+
+  where
+    boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool
+    boundedGet (V2 minX minY, V2 maxX maxY) (i, j)
+      | x <= minX
+        || y <= minY
+        || x >= maxX
+        || y >= maxY
+      = True
+      | otherwise =
+        let nx = fromIntegral $ fromIntegral x + i
+            ny = fromIntegral $ fromIntegral y + j
+        in cells ! V2 nx ny
+
+neighborPositions :: [(Int, Int)]
+neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)]
+
+fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m ()
+fillOuterEdgesM arr = do
+  (V2 minX minY, V2 maxX maxY) <- getBounds arr
+  for_ (range (minX, maxX)) $ \x -> do
+    writeArray arr (V2 x minY) True
+    writeArray arr (V2 x maxY) True
+  for_ (range (minY, maxY)) $ \y -> do
+    writeArray arr (V2 minX y) True
+    writeArray arr (V2 maxX y) True
+
+cloneMArray
+  :: forall a a' i e m.
+  ( Ix i
+  , MArray a e m
+  , MArray a' e m
+  , IArray UArray e
+  )
+  => a i e
+  -> m (a' i e)
+cloneMArray = thaw @_ @UArray <=< freeze
+
+--------------------------------------------------------------------------------
+
+-- | Flood fill a cell array starting at a point, returning a list of all the
+-- (true) cell locations reachable from that point
+floodFill :: forall a i.
+            ( IArray a Bool
+            , Ix i
+            , Enum i
+            , Bounded i
+            , Eq i
+            )
+          => a (V2 i) Bool -- ^ array
+          -> (V2 i)        -- ^ position
+          -> Set (V2 i)
+floodFill = go mempty
+  where
+    go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i)
+    go res arr@(bounds -> arrBounds) idx@(V2 x y)
+      | not (inRange arrBounds idx) =  res
+      | not (arr ! idx) =  res
+      | otherwise =
+        let neighbors
+              = filter (inRange arrBounds)
+              . filter (/= idx)
+              . filter (`notMember` res)
+              $ V2
+              <$> [(if x == minBound then x else pred x)
+                   ..
+                   (if x == maxBound then x else succ x)]
+              <*> [(if y == minBound then y else pred y)
+                   ..
+                   (if y == maxBound then y else succ y)]
+        in foldl' (\r idx' ->
+                     if arr ! idx'
+                     then r <> (let r' = r & contains idx' .~ True
+                               in r' `seq` go r' arr idx')
+                     else r)
+           (res & contains idx .~ True) neighbors
+{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-}
+
+-- | Gives a list of all the disconnected regions in a cell array, represented
+-- each as lists of points
+regions :: forall a i.
+          ( IArray a Bool
+          , Ix i
+          , Enum i
+          , Bounded i
+          , Eq i
+          )
+        => a (V2 i) Bool
+        -> [Set (V2 i)]
+regions arr
+  | Just firstPoint <- findFirstPoint arr =
+      let region = floodFill arr firstPoint
+          arr' = fillAll region arr
+      in region : regions arr'
+  | otherwise = []
+  where
+    findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i)
+    findFirstPoint = fmap fst . headMay . filter snd . assocs
+{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-}
+
+fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool
+fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes
+
+fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m ()
+fillAllM ixes a = for_ ixes $ \i -> writeArray a i False
+
+fromPoints
+  :: forall a f i.
+    ( IArray a Bool
+    , Ix i
+    , Functor f
+    , Foldable1 f
+    )
+  => f (i, i)
+  -> a (i, i) Bool
+fromPoints points =
+  let pts = Set.fromList $ toList points
+      dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points)
+             , (maximum1 $ fst <$> points, maximum1 $ snd <$> points)
+             )
+  in array dims $ range dims <&> \i -> (i, i `member` pts)
+
+fromPointsM
+  :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f)
+  => NonNull f
+  -> m (a i Bool)
+fromPointsM points = do
+  arr <- newArray (minimum points, maximum points) False
+  fillAllM (otoList points) arr
+  pure arr