Progressively reveal the map to the player

As the character walks around the map, progressively reveal the entities
on the map to them, using an algorithm based on well known
circle-rasterizing and line-rasterizing algorithms to calculate lines of
sight that are potentially obscured by walls.

src/Xanthous/App.hs

@@ -6,6 +6,7 @@ import qualified Brick
 import           Graphics.Vty.Attributes (defAttr)
 import           Graphics.Vty.Input.Events (Event(EvKey))
 import           Control.Monad.State (get)
+import           Control.Monad.State.Class (modify)
 import           Control.Monad.Random (getRandom)
 --------------------------------------------------------------------------------
 import           Xanthous.Command
@@ -60,6 +61,7 @@ startEvent = do
     $ Dimensions 80 80
   entities <>= level
   characterPosition .= charPos
+  modify updateCharacterVision
   -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
 
 
@@ -75,7 +77,9 @@ handleCommand Quit = halt
 handleCommand (Move dir) = do
   newPos <- uses characterPosition $ move dir
   collisionAt newPos >>= \case
-    Nothing -> characterPosition .= newPos
+    Nothing -> do
+      characterPosition .= newPos
+      modify updateCharacterVision
     Just Combat -> undefined
     Just Stop -> pure ()
   continue

src/Xanthous/Data.hs

@@ -12,9 +12,11 @@ module Xanthous.Data
   , y
 
   , Positioned(..)
+  , _Positioned
   , position
   , positioned
   , loc
+  , _Position
   , positionFromPair
 
     -- *
@@ -73,6 +75,12 @@ data Positioned a where
   deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
   deriving anyclass (CoArbitrary, Function)
 
+_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b)
+_Positioned = iso hither yon
+  where
+    hither (pos, a) = Positioned pos a
+    yon (Positioned pos b) = (pos, b)
+
 instance Arbitrary a => Arbitrary (Positioned a) where
   arbitrary = Positioned <$> arbitrary <*> arbitrary
 
@@ -92,6 +100,12 @@ loc = iso hither yon
     hither (Position px py) = Location (px, py)
     yon (Location (lx, ly)) = Position lx ly
 
+_Position :: Iso' Position (Int, Int)
+_Position = iso hither yon
+  where
+    hither (Position px py) = (px, py)
+    yon (lx, ly) = Position lx ly
+
 positionFromPair :: (Integral i, Integral j) => (i, j) -> Position
 positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
 

src/Xanthous/Data/EntityMap.hs

@@ -1,27 +1,31 @@
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE TupleSections      #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveFunctor      #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Data.EntityMap
   ( EntityMap
+  , _EntityMap
   , EntityID
   , emptyEntityMap
   , insertAt
   , insertAtReturningID
+  , fromEIDsAndPositioned
   , atPosition
+  , atPositionWithIDs
   , positions
   , lookup
   , lookupWithPosition
   -- , positionedEntities
   , neighbors
+  , Deduplicate(..)
+
+    -- * Querying an entityMap
   ) where
-
+--------------------------------------------------------------------------------
-import Data.Monoid (Endo(..))
-import Test.QuickCheck (Arbitrary(..))
-import Test.QuickCheck.Checkers (EqProp)
-
 import Xanthous.Prelude hiding (lookup)
 import Xanthous.Data
   ( Position
@@ -33,7 +37,11 @@ import Xanthous.Data
   )
 import Xanthous.Orphans ()
 import Xanthous.Util (EqEqProp(..))
-
+--------------------------------------------------------------------------------
+import Data.Monoid (Endo(..))
+import Test.QuickCheck (Arbitrary(..))
+import Test.QuickCheck.Checkers (EqProp)
+--------------------------------------------------------------------------------
 type EntityID = Word32
 type NonNullVector a = NonNull (Vector a)
 
@@ -43,7 +51,7 @@ data EntityMap a where
     , _byID       :: HashMap EntityID (Positioned a)
     , _lastID     :: EntityID
     } -> EntityMap a
-  deriving stock (Functor, Foldable, Traversable)
+  deriving stock (Functor, Foldable, Traversable, Generic)
 deriving via (EqEqProp (EntityMap a)) instance Eq a => EqProp (EntityMap a)
 makeLenses ''EntityMap
 
@@ -85,9 +93,36 @@ instance At (EntityMap a) where
       removeEIDAtPos pos =
         byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid))
 
+instance Semigroup (EntityMap a) where
+  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
+
+instance Monoid (EntityMap a) where
+  mempty = emptyEntityMap
+
 emptyEntityMap :: EntityMap a
 emptyEntityMap = EntityMap mempty mempty 0
 
+newtype Deduplicate a = Deduplicate (EntityMap a)
+  deriving stock (Show, Traversable, Generic)
+  deriving newtype (Eq, Functor, Foldable, EqProp, Arbitrary)
+
+instance Semigroup (Deduplicate a) where
+  (Deduplicate em₁) <> (Deduplicate em₂) =
+    let _byID = em₁ ^. byID <> em₂ ^. byID
+        _byPosition = mempty &~ do
+          ifor_ _byID $ \eid (Positioned pos _) ->
+            at pos %= \case
+              Just eids -> Just $ eid <| eids
+              Nothing -> Just $ ncons eid mempty
+        _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
+    in Deduplicate EntityMap{..}
+
+instance Monoid (Deduplicate a) where
+  mempty = Deduplicate emptyEntityMap
+
+
+--------------------------------------------------------------------------------
+
 _EntityMap :: Iso' (EntityMap a) [(Position, a)]
 _EntityMap = iso hither yon
   where
@@ -100,12 +135,6 @@ _EntityMap = iso hither yon
     yon :: [(Position, a)] -> EntityMap a
     yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
 
-instance Semigroup (EntityMap a) where
-  em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
-
-instance Monoid (EntityMap a) where
-  mempty = emptyEntityMap
-
 
 insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a)
 insertAtReturningID pos e em =
@@ -124,17 +153,37 @@ atPosition :: forall a. Position -> Lens' (EntityMap a) (Vector a)
 atPosition pos = lens getter setter
   where
     getter em =
-      let
+      let eids :: Vector EntityID
-        eids :: Vector EntityID
           eids = maybe mempty toNullable $ em ^. byPosition . at pos
-
+      in getEIDAssume em <$> eids
-        getEIDAssume :: EntityID -> a
-        getEIDAssume eid = fromMaybe byIDInvariantError
-          $ em ^? byID . ix eid . positioned
-      in getEIDAssume <$> eids
     setter em Empty = em & byPosition . at pos .~ Nothing
     setter em entities = alaf Endo foldMap (insertAt pos) entities em
 
+getEIDAssume :: EntityMap a -> EntityID -> a
+getEIDAssume em eid = fromMaybe byIDInvariantError
+  $ em ^? byID . ix eid . positioned
+
+atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
+atPositionWithIDs pos em =
+  let eids = maybe mempty toNullable $ em ^. byPosition . at pos
+  in (id &&& Positioned pos . getEIDAssume em) <$> eids
+
+fromEIDsAndPositioned
+  :: (MonoFoldable mono, Element mono ~ (EntityID, Positioned a))
+  => mono
+  -> EntityMap a
+fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
+  where
+    insert' (eid, pe@(Positioned pos _))
+      = (byID . at eid ?~ pe)
+      . (byPosition . at pos %~ \case
+            Just eids -> Just $ eid <| eids
+            Nothing   -> Just $ ncons eid mempty
+        )
+    newLastID em = em & lastID
+      .~ fromMaybe 1
+         (maximumOf (ifolded . asIndex) (em ^. byID))
+
 positions :: EntityMap a -> [Position]
 positions = toListOf $ byPosition . to keys . folded
 
@@ -150,3 +199,6 @@ lookup eid = fmap (view positioned) . lookupWithPosition eid
 
 neighbors :: Position -> EntityMap a -> Neighbors (Vector a)
 neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
+
+--------------------------------------------------------------------------------
+makeWrapped ''Deduplicate

src/Xanthous/Data/EntityMap/Graphics.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE ViewPatterns #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.EntityMap.Graphics where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Xanthous.Util (takeWhileInclusive)
+import Xanthous.Data
+import Xanthous.Data.EntityMap
+import Xanthous.Entities
+import Xanthous.Util.Graphics (circle, line)
+--------------------------------------------------------------------------------
+
+-- | Given a point and a radius of vision, returns a list of all entities that
+-- are *visible* (eg, not blocked by an entity that obscures vision) from that
+-- point
+visibleEntities :: Position -> Word -> EntityMap SomeEntity -> EntityMap SomeEntity
+visibleEntities (view _Position -> pos) visionRadius em
+  = fromEIDsAndPositioned . fold . fold $ sightAdjustedLines
+  where
+    -- I love laziness!
+    radius = circle pos $ fromIntegral visionRadius
+    linesOfSight = radius <&> line pos
+    entitiesOnLines = linesOfSight <&> map getPositionedAt
+    sightAdjustedLines = entitiesOnLines <&> takeWhileInclusive (none $ blocksVision . snd)
+    getPositionedAt p =
+      let ppos = _Position # p
+      in atPositionWithIDs ppos em

src/Xanthous/Entities.hs

@@ -7,7 +7,7 @@ module Xanthous.Entities
   ( Draw(..)
   , DrawCharacter(..)
   , DrawStyledCharacter(..)
-  , Entity
+  , Entity(..)
   , SomeEntity(..)
   , downcastEntity
   , entityIs
@@ -29,8 +29,11 @@ import           Data.Aeson
 import           Xanthous.Data
 --------------------------------------------------------------------------------
 
-class (Show a, Eq a, Draw a) => Entity a
+class (Show a, Eq a, Draw a) => Entity a where
-instance (Show a, Eq a, Draw a) => Entity a
+  blocksVision :: a -> Bool
+
+instance Entity a => Entity (Positioned a) where
+  blocksVision (Positioned _ ent) = blocksVision ent
 
 --------------------------------------------------------------------------------
 data SomeEntity where
@@ -47,6 +50,9 @@ instance Eq SomeEntity where
 instance Draw SomeEntity where
   drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
 
+instance Entity SomeEntity where
+  blocksVision (SomeEntity ent) = blocksVision ent
+
 downcastEntity :: (Entity a, Typeable a) => SomeEntity -> Maybe a
 downcastEntity (SomeEntity e) = cast e
 
@@ -61,6 +67,10 @@ class Draw a where
   draw :: a -> Widget n
   draw = drawWithNeighbors $ pure mempty
 
+instance Draw a => Draw (Positioned a) where
+  drawWithNeighbors ns (Positioned _ a) = drawWithNeighbors ns a
+  draw (Positioned _ a) = draw a
+
 newtype DrawCharacter (char :: Symbol) (a :: Type) where
   DrawCharacter :: a -> DrawCharacter char a
 

src/Xanthous/Entities/Character.hs

@@ -14,6 +14,9 @@ data Character = Character
   deriving anyclass (CoArbitrary, Function)
   deriving Draw via (DrawCharacter "@" Character)
 
+instance Entity Character where
+  blocksVision _ = False
+
 instance Arbitrary Character where
   arbitrary = pure Character
 

src/Xanthous/Entities/Creature.hs

@@ -8,7 +8,7 @@ import Data.Word
 
 import Xanthous.Prelude
 import Xanthous.Entities.RawTypes hiding (Creature)
-import Xanthous.Entities (Draw(..))
+import Xanthous.Entities (Draw(..), Entity(..))
 
 data Creature = Creature
   { _creatureType :: CreatureType
@@ -17,6 +17,9 @@ data Creature = Creature
   deriving stock (Eq, Show, Generic)
 makeLenses ''Creature
 
+instance Entity Creature where
+  blocksVision _ = False
+
 instance Draw Creature where
   draw = draw .view (creatureType . char)
 

src/Xanthous/Entities/Environment.hs

@@ -7,7 +7,7 @@ import Test.QuickCheck
 import Brick (str)
 import Brick.Widgets.Border.Style (unicode)
 --------------------------------------------------------------------------------
-import Xanthous.Entities (Draw(..), entityIs)
+import Xanthous.Entities (Draw(..), entityIs, Entity(..))
 import Xanthous.Entities.Draw.Util
 import Xanthous.Data
 --------------------------------------------------------------------------------
@@ -16,6 +16,9 @@ data Wall = Wall
   deriving stock (Show, Eq, Ord, Generic, Enum)
   deriving anyclass (CoArbitrary, Function)
 
+instance Entity Wall where
+  blocksVision _ = True
+
 instance Arbitrary Wall where
   arbitrary = pure Wall
 

src/Xanthous/Game.hs

@@ -5,6 +5,7 @@
 module Xanthous.Game
   ( GameState(..)
   , entities
+  , revealedEntities
   , messageHistory
   , randomGen
 
@@ -13,6 +14,7 @@ module Xanthous.Game
   , positionedCharacter
   , character
   , characterPosition
+  , updateCharacterVision
 
   , MessageHistory(..)
   , pushMessage
@@ -33,8 +35,10 @@ import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
 import           Control.Monad.State.Class
 --------------------------------------------------------------------------------
+import           Xanthous.Util (appendVia)
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Data.EntityMap.Graphics
 import           Xanthous.Data (Positioned, Position(..), positioned, position)
 import           Xanthous.Entities (SomeEntity(..), downcastEntity, entityIs)
 import           Xanthous.Entities.Character
@@ -68,6 +72,8 @@ hideMessage (MessageHistory msgs _) = MessageHistory msgs False
 
 data GameState = GameState
   { _entities          :: EntityMap SomeEntity
+    -- | A subset of the overall set of entities
+  , _revealedEntities  :: EntityMap SomeEntity
   , _characterEntityID :: EntityID
   , _messageHistory    :: MessageHistory
   , _randomGen         :: StdGen
@@ -76,10 +82,12 @@ data GameState = GameState
 makeLenses ''GameState
 
 instance Eq GameState where
-  (GameState es₁ ceid₁ mh₁ _) == (GameState es₂ ceid₂ mh₂ _)
+  (==) = (==) `on` \gs ->
-    = es₁ == es₂
+    ( gs ^. entities
-    && ceid₁ == ceid₂
+    , gs ^. revealedEntities
-    && mh₁ == mh₂
+    , gs ^. characterEntityID
+    , gs ^. messageHistory
+    )
 
 instance Arbitrary GameState where
   arbitrary = do
@@ -88,6 +96,11 @@ instance Arbitrary GameState where
     _messageHistory <- arbitrary
     (_characterEntityID, _entities) <- arbitrary <&>
       EntityMap.insertAtReturningID charPos (SomeEntity char)
+    revealedPositions <- sublistOf $ EntityMap.positions _entities
+    let _revealedEntities = mempty &~ do
+          for_ revealedPositions $ \pos -> do
+            let ents = _entities ^. EntityMap.atPosition pos
+            EntityMap.atPosition pos <>= ents
     _randomGen <- mkStdGen <$> arbitrary
     pure $ GameState {..}
 
@@ -101,6 +114,7 @@ getInitialState = do
           (SomeEntity char)
           mempty
       _messageHistory = NoMessageHistory
+      _revealedEntities = _entities
   pure GameState {..}
 
 positionedCharacter :: Lens' GameState (Positioned Character)
@@ -130,6 +144,17 @@ character = positionedCharacter . positioned
 characterPosition :: Lens' GameState Position
 characterPosition = positionedCharacter . position
 
+visionRadius :: Word
+visionRadius = 12 -- TODO make this dynamic
+
+-- | Update the revealed entities at the character's position based on their vision
+updateCharacterVision :: GameState -> GameState
+updateCharacterVision game =
+  let charPos = game ^. characterPosition
+      visible = visibleEntities charPos visionRadius $ game ^. entities
+  in game & revealedEntities %~ appendVia EntityMap.Deduplicate visible
+
+
 --------------------------------------------------------------------------------
 
 data Collision

src/Xanthous/Game/Draw.hs

@@ -17,6 +17,7 @@ import Xanthous.Entities
 import Xanthous.Game
   ( GameState(..)
   , entities
+  , revealedEntities
   , characterPosition
   , MessageHistory(..)
   , messageHistory
@@ -35,8 +36,11 @@ drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
 --   (MessageHistory _ False) -> padTop (Pad 2) $ str " "
 --   (MessageHistory (lastMessage :| _) True) -> txt lastMessage
 
-drawEntities :: EntityMap SomeEntity -> Widget Name
+drawEntities
-drawEntities em
+  :: EntityMap SomeEntity -- ^ visible entities
+  -> EntityMap SomeEntity -- ^ all entities
+  -> Widget Name
+drawEntities em allEnts
   = vBox rows
   where
     entityPositions = EntityMap.positions em
@@ -45,7 +49,7 @@ drawEntities em
     rows = mkRow <$> [0..maxY]
     mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
     renderEntityAt pos =
-      let neighbors = EntityMap.neighbors pos em
+      let neighbors = EntityMap.neighbors pos allEnts
       in maybe (str " ") (drawWithNeighbors neighbors)
          $ em ^? atPosition pos . folded
 
@@ -53,8 +57,9 @@ drawMap :: GameState -> Widget Name
 drawMap game
   = viewport MapViewport Both
   . showCursor Character (game ^. characterPosition . loc)
-  . drawEntities
+  $ drawEntities
-  $ game ^. entities
+    (game ^. revealedEntities)
+    (game ^. entities)
 
 drawGame :: GameState -> [Widget Name]
 drawGame game

src/Xanthous/Generators/Util.hs

@@ -104,14 +104,6 @@ fillOuterEdgesM arr = do
     writeArray arr (minX, y) True
     writeArray arr (maxX, y) True
 
-safeGet :: (IArray a e, Ix i) => a i e -> i -> Maybe e
-safeGet arr idx =
-  let (minIdx, maxIdx) = bounds arr
-  in if idx < minIdx || idx > maxIdx
-     then Nothing
-     else Just $ arr ! idx
-
-
 cloneMArray
   :: forall a a' i e m.
   ( Ix i

src/Xanthous/Util.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 module Xanthous.Util
   ( EqEqProp(..)
@@ -6,12 +7,29 @@ module Xanthous.Util
   , foldlMapM
   , foldlMapM'
   , between
+
+  , appendVia
+
+    -- * Foldable
+    -- ** Uniqueness
+    -- *** Predicates on uniqueness
+  , isUniqueOf
+  , isUnique
+    -- *** Removing all duplicate elements in n * log n time
+  , uniqueOf
+  , unique
+    -- *** Removing sequentially duplicate elements in linear time
+  , uniqOf
+  , uniq
+    -- ** Bag sequence algorithms
+  , takeWhileInclusive
   ) where
 
 import Xanthous.Prelude hiding (foldr)
 
 import Test.QuickCheck.Checkers
 import Data.Foldable (foldr)
+import Data.Monoid
 
 newtype EqEqProp a = EqEqProp a
   deriving newtype Eq
@@ -44,3 +62,134 @@ between
   -> a -- ^ scrutinee
   -> Bool
 between lower upper x = x >= lower && x <= upper
+
+-- |
+-- >>> appendVia Sum 1 2
+-- 3
+appendVia :: (Rewrapping s t, Semigroup s) => (Unwrapped s -> s) -> Unwrapped s -> Unwrapped s -> Unwrapped s
+appendVia wrap x y = op wrap $ wrap x <> wrap y
+
+--------------------------------------------------------------------------------
+
+-- | Returns True if the targets of the given 'Fold' are unique per the 'Ord' instance for @a@
+--
+-- >>> isUniqueOf (folded . _1) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)])
+-- True
+--
+-- >>> isUniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)])
+-- False
+--
+-- @
+-- 'isUniqueOf' :: Ord a => 'Getter' s a     -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Fold' s a       -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Lens'' s a      -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Iso'' s a       -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Traversal'' s a -> s -> 'Bool'
+-- 'isUniqueOf' :: Ord a => 'Prism'' s a     -> s -> 'Bool'
+-- @
+isUniqueOf :: Ord a => Getting (Endo (Set a, Bool)) s a -> s -> Bool
+isUniqueOf aFold = orOf _2 . foldrOf aFold rejectUnique (mempty, True)
+ where
+  rejectUnique x (seen, acc)
+    | seen ^. contains x = (seen, False)
+    | otherwise          = (seen & contains x .~ True, acc)
+
+-- | Returns true if the given 'Foldable' container contains only unique
+-- elements, as determined by the 'Ord' instance for @a@
+--
+-- >>> isUnique ([3, 1, 2] :: [Int])
+-- True
+--
+-- >>> isUnique ([1, 1, 2, 2, 3, 1] :: [Int])
+-- False
+isUnique :: (Foldable f, Ord a) => f a -> Bool
+isUnique = isUniqueOf folded
+
+
+-- | O(n * log n). Returns a monoidal, 'Cons'able container (a list, a Set,
+-- etc.) consisting of the unique (per the 'Ord' instance for @a@) targets of
+-- the given 'Fold'
+--
+-- >>> uniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2), (4, 3)] :: [(Int, Int)]) :: [Int]
+-- [2,3]
+--
+-- @
+-- 'uniqueOf' :: Ord a => 'Getter' s a     -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Fold' s a       -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Lens'' s a      -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Iso'' s a       -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Traversal'' s a -> s -> [a]
+-- 'uniqueOf' :: Ord a => 'Prism'' s a     -> s -> [a]
+-- @
+uniqueOf
+  :: (Monoid c, Ord w, Cons c c w w) => Getting (Endo (Set w, c)) a w -> a -> c
+uniqueOf aFold = snd . foldrOf aFold rejectUnique (mempty, mempty)
+ where
+  rejectUnique x (seen, acc)
+    | seen ^. contains x = (seen, acc)
+    | otherwise          = (seen & contains x .~ True, cons x acc)
+
+-- | Returns a monoidal, 'Cons'able container (a list, a Set, etc.) consisting
+-- of the unique (per the 'Ord' instance for @a@) contents of the given
+-- 'Foldable' container
+--
+-- >>> unique [1, 1, 2, 2, 3, 1] :: [Int]
+-- [2,3,1]
+
+-- >>> unique [1, 1, 2, 2, 3, 1] :: Set Int
+-- fromList [3,2,1]
+unique :: (Foldable f, Cons c c a a, Ord a, Monoid c) => f a -> c
+unique = uniqueOf folded
+
+--------------------------------------------------------------------------------
+
+-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.)
+-- consisting of the targets of the given 'Fold' with sequential duplicate
+-- elements removed
+--
+-- This function (sorry for the confusing name) differs from 'uniqueOf' in that
+-- it only compares /sequentially/ duplicate elements (and thus operates in
+-- linear time).
+-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name
+--
+-- >>> uniqOf (folded . _2) ([(1, 2), (2, 2), (3, 1), (4, 2)] :: [(Int, Int)]) :: [Int]
+-- [2,1,2]
+--
+-- @
+-- 'uniqOf' :: Eq a => 'Getter' s a     -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Fold' s a       -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Lens'' s a      -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Iso'' s a       -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Traversal'' s a -> s -> [a]
+-- 'uniqOf' :: Eq a => 'Prism'' s a     -> s -> [a]
+-- @
+uniqOf :: (Monoid c, Cons c c w w, Eq w) => Getting (Endo (Maybe w, c)) a w -> a -> c
+uniqOf aFold = snd . foldrOf aFold rejectSeen (Nothing, mempty)
+  where
+    rejectSeen x (Nothing, acc) = (Just x, x <| acc)
+    rejectSeen x tup@(Just a, acc)
+      | x == a     = tup
+      | otherwise = (Just x, x <| acc)
+
+-- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.)
+-- consisting of the targets of the given 'Foldable' container with sequential
+-- duplicate elements removed
+--
+-- This function (sorry for the confusing name) differs from 'unique' in that
+-- it only compares /sequentially/ unique elements (and thus operates in linear
+-- time).
+-- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name
+--
+-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: [Int]
+-- [1,2,3,1]
+--
+-- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: Vector Int
+-- [1,2,3,1]
+--
+uniq :: (Foldable f, Eq a, Cons c c a a, Monoid c) => f a -> c
+uniq = uniqOf folded
+
+-- | Like 'takeWhile', but inclusive
+takeWhileInclusive :: (a -> Bool) -> [a] -> [a]
+takeWhileInclusive _ [] = []
+takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else []

src/Xanthous/Util/Graphics.hs

@@ -0,0 +1,64 @@
+-- | Graphics algorithms and utils for rendering things in 2D space
+--------------------------------------------------------------------------------
+module Xanthous.Util.Graphics where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import           Data.List                                ( unfoldr )
+--------------------------------------------------------------------------------
+
+-- | Generate a circle centered at the given point and with the given radius
+-- using the <midpoint circle algorithm
+-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>.
+--
+-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell>
+circle :: (Num i, Ord i)
+       => (i, i) -- ^ center
+       -> i      -- ^ radius
+       -> [(i, i)]
+circle (x₀, y₀) radius
+  -- Four initial points, plus the generated points
+  = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points
+    where
+      -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
+      points = concatMap generatePoints $ unfoldr step initialValues
+
+      generatePoints (x, y)
+        = [ (x₀ `xop` x', y₀ `yop` y')
+          | (x', y') <- [(x, y), (y, x)]
+          , xop <- [(+), (-)]
+          , yop <- [(+), (-)]
+          ]
+
+      initialValues = (1 - radius, 1, (-2) * radius, 0, radius)
+
+      step (f, ddf_x, ddf_y, x, y)
+        | x >= y = Nothing
+        | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y'))
+        where
+          (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1)
+                           | otherwise = (f + ddf_x, ddf_y, y)
+          ddf_x' = ddf_x + 2
+          x' = x + 1
+
+-- | Draw a line between two points using Bresenham's line drawing algorithm
+--
+-- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm>
+line :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
+line pa@(xa, ya) pb@(xb, yb)
+  = (if maySwitch pa < maySwitch pb then id else reverse) points
+  where
+    points               = map maySwitch . unfoldr go $ (x₁, y₁, 0)
+    steep                = abs (yb - ya) > abs (xb - xa)
+    maySwitch            = if steep then swap else id
+    [(x₁, y₁), (x₂, y₂)] = sort [maySwitch pa, maySwitch pb]
+    δx                   = x₂ - x₁
+    δy                   = abs (y₂ - y₁)
+    ystep                = if y₁ < y₂ then 1 else -1
+    go (xTemp, yTemp, err)
+      | xTemp > x₂ = Nothing
+      | otherwise  = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
+      where
+        tempError        = err + δy
+        (newY, newError) = if (2 * tempError) >= δx
+                           then (yTemp + ystep, tempError - δx)
+                           else (yTemp, tempError)

test/Spec.hs

@@ -6,6 +6,7 @@ import qualified Xanthous.GameSpec
 import qualified Xanthous.Generators.UtilSpec
 import qualified Xanthous.MessageSpec
 import qualified Xanthous.OrphansSpec
+import qualified Xanthous.Util.GraphicsSpec
 
 main :: IO ()
 main = defaultMain test
@@ -19,4 +20,5 @@ test = testGroup "Xanthous"
   , Xanthous.MessageSpec.test
   , Xanthous.OrphansSpec.test
   , Xanthous.DataSpec.test
+  , Xanthous.Util.GraphicsSpec.test
   ]

test/Xanthous/Data/EntityMapSpec.hs

@@ -11,8 +11,12 @@ main :: IO ()
 main = defaultMain test
 
 test :: TestTree
-test = testGroup "Xanthous.Data.EntityMap"
+test = localOption (QuickCheckTests 20)
+  $ testGroup "Xanthous.Data.EntityMap"
   [ testBatch $ monoid @(EntityMap Int) mempty
+  , testGroup "Deduplicate"
+    [ testBatch $ monoid @(Deduplicate Int) mempty
+    ]
   , testGroup "Eq laws"
     [ testProperty "reflexivity" $ \(em :: EntityMap Int) ->
         em == em

test/Xanthous/Util/GraphicsSpec.hs

@@ -0,0 +1,39 @@
+module Xanthous.Util.GraphicsSpec (main, test) where
+--------------------------------------------------------------------------------
+import Test.Prelude hiding (head)
+--------------------------------------------------------------------------------
+import Xanthous.Util.Graphics
+import Xanthous.Util
+import Data.List (head)
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Util.Graphics"
+  [ testGroup "circle"
+    [ testCase "radius 12, origin 0"
+      $ (sort . unique @[] @[_]) (circle @Int (0, 0) 12)
+      @?= (sort . unique) (
+        let quadrant =
+              [ (0, 12) , (1, 12) , (2, 12) , (3, 12)
+              , (4, 12) , (5, 11) , (6, 11) , (7, 10)
+              , (8, 9)  , (9, 9)  , (9, 8)  , (10, 7)
+              , (11, 6) , (11, 5) , (12, 4) , (12, 3)
+              , (12, 2) , (12, 1) , (12, 0)
+              ]
+        in  quadrant
+         <> (quadrant <&> _1 %~ negate)
+         <> (quadrant <&> _2 %~ negate)
+         <> (quadrant <&> both %~ negate)
+      )
+    ]
+
+  , testGroup "line"
+    [ testProperty "starts and ends at the start and end points" $ \start end ->
+        let ℓ = line @Int start end
+        in counterexample ("line: " <> show ℓ)
+        $ length ℓ > 2 ==> (head ℓ === start) .&&. (head (reverse ℓ) === end)
+    ]
+  ]

xanthous.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: a79caccff8895730c394c19244f068830759636d17f55f3b6d1d8a9ebe43ecdd
+-- hash: 86b7d3047b95fc65f4c6489a21e8c89883981c8c5bd552b5ea83aaf70de8a7cf
 
 name:           xanthous
 version:        0.1.0.0
@@ -34,6 +34,7 @@ library
       Xanthous.Command
       Xanthous.Data
       Xanthous.Data.EntityMap
+      Xanthous.Data.EntityMap.Graphics
       Xanthous.Entities
       Xanthous.Entities.Arbitrary
       Xanthous.Entities.Character
@@ -55,6 +56,7 @@ library
       Xanthous.Random
       Xanthous.Resource
       Xanthous.Util
+      Xanthous.Util.Graphics
   other-modules:
       Paths_xanthous
   hs-source-dirs:
@@ -102,6 +104,7 @@ executable xanthous
       Xanthous.Command
       Xanthous.Data
       Xanthous.Data.EntityMap
+      Xanthous.Data.EntityMap.Graphics
       Xanthous.Entities
       Xanthous.Entities.Arbitrary
       Xanthous.Entities.Character
@@ -123,6 +126,7 @@ executable xanthous
       Xanthous.Random
       Xanthous.Resource
       Xanthous.Util
+      Xanthous.Util.Graphics
       Paths_xanthous
   hs-source-dirs:
       src
@@ -174,6 +178,7 @@ test-suite test
       Xanthous.Generators.UtilSpec
       Xanthous.MessageSpec
       Xanthous.OrphansSpec
+      Xanthous.Util.GraphicsSpec
       Paths_xanthous
   hs-source-dirs:
       test