about summary refs log tree commit diff
path: root/src/Xanthous
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous')
-rw-r--r--src/Xanthous/App.hs6
-rw-r--r--src/Xanthous/Data.hs14
-rw-r--r--src/Xanthous/Data/EntityMap.hs104
-rw-r--r--src/Xanthous/Data/EntityMap/Graphics.hs28
-rw-r--r--src/Xanthous/Entities.hs16
-rw-r--r--src/Xanthous/Entities/Character.hs3
-rw-r--r--src/Xanthous/Entities/Creature.hs5
-rw-r--r--src/Xanthous/Entities/Environment.hs5
-rw-r--r--src/Xanthous/Game.hs35
-rw-r--r--src/Xanthous/Game/Draw.hs15
-rw-r--r--src/Xanthous/Generators/Util.hs8
-rw-r--r--src/Xanthous/Util.hs149
-rw-r--r--src/Xanthous/Util/Graphics.hs64
13 files changed, 402 insertions, 50 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 82c32f05a3fc..d4cc8d2b4fda 100644
--- a/src/Xanthous/App.hs
+++ b/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
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index 468e59217cce..704b3c6e74c4 100644
--- a/src/Xanthous/Data.hs
+++ b/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)
 
diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs
index e713aff32c6b..926a02a48ce1 100644
--- a/src/Xanthous/Data/EntityMap.hs
+++ b/src/Xanthous/Data/EntityMap.hs
@@ -1,27 +1,31 @@
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE TupleSections      #-}
+{-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DeriveFunctor #-}
-
+{-# LANGUAGE DeriveFunctor      #-}
+--------------------------------------------------------------------------------
 module Xanthous.Data.EntityMap
   ( EntityMap
+  , _EntityMap
   , EntityID
   , emptyEntityMap
   , insertAt
   , insertAtReturningID
+  , fromEIDsAndPositioned
   , atPosition
+  , atPositionWithIDs
   , positions
   , lookup
   , lookupWithPosition
   -- , positionedEntities
   , neighbors
-  ) where
-
-import Data.Monoid (Endo(..))
-import Test.QuickCheck (Arbitrary(..))
-import Test.QuickCheck.Checkers (EqProp)
+  , Deduplicate(..)
 
+    -- * Querying an entityMap
+  ) where
+--------------------------------------------------------------------------------
 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
-        eids :: Vector EntityID
-        eids = maybe mempty toNullable $ em ^. byPosition . at pos
-
-        getEIDAssume :: EntityID -> a
-        getEIDAssume eid = fromMaybe byIDInvariantError
-          $ em ^? byID . ix eid . positioned
-      in getEIDAssume <$> eids
+      let eids :: Vector EntityID
+          eids = maybe mempty toNullable $ em ^. byPosition . at pos
+      in getEIDAssume em <$> 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
diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs
new file mode 100644
index 000000000000..21a380a72c0a
--- /dev/null
+++ b/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
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
index bd52ae62b29f..223c8d769ba4 100644
--- a/src/Xanthous/Entities.hs
+++ b/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
-instance (Show a, Eq a, Draw a) => Entity a
+class (Show a, Eq a, Draw a) => Entity a where
+  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
 
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index faa9964a3833..e2ca874dddbc 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/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
 
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 983772090ee2..5af24a8cd3eb 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/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)
 
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index f5301f94adf2..90fa05315a57 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/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
 
diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs
index 6a4689610689..ed65217e627b 100644
--- a/src/Xanthous/Game.hs
+++ b/src/Xanthous/Game.hs
@@ -1,10 +1,11 @@
-{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE MultiWayIf      #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE RecordWildCards #-}
 --------------------------------------------------------------------------------
 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₂ _)
-    = es₁ == es₂
-    && ceid₁ == ceid₂
-    && mh₁ == mh₂
+  (==) = (==) `on` \gs ->
+    ( gs ^. entities
+    , gs ^. revealedEntities
+    , 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
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 4d3cb15dca4a..bb6508acdff7 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/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 em
+drawEntities
+  :: 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
-  $ game ^. entities
+  $ drawEntities
+    (game ^. revealedEntities)
+    (game ^. entities)
 
 drawGame :: GameState -> [Widget Name]
 drawGame game
diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
index 6a2d27839cf6..e399ca5d4936 100644
--- a/src/Xanthous/Generators/Util.hs
+++ b/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
diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs
index cf1f80b82e39..439f9e8ffaef 100644
--- a/src/Xanthous/Util.hs
+++ b/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 []
diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs
new file mode 100644
index 000000000000..5a174d4f415b
--- /dev/null
+++ b/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)
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-12-12T09·42+0000