From 58fce2ec1976b957c7e24a282964c62f7ddf7b02 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 15 Sep 2019 13:00:28 -0400 Subject: 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 +- src/Xanthous/Data.hs | 14 +++ src/Xanthous/Data/EntityMap.hs | 104 ++++++++++++++++------ src/Xanthous/Data/EntityMap/Graphics.hs | 28 ++++++ src/Xanthous/Entities.hs | 16 +++- src/Xanthous/Entities/Character.hs | 3 + src/Xanthous/Entities/Creature.hs | 5 +- src/Xanthous/Entities/Environment.hs | 5 +- src/Xanthous/Game.hs | 35 ++++++-- src/Xanthous/Game/Draw.hs | 15 ++-- src/Xanthous/Generators/Util.hs | 8 -- src/Xanthous/Util.hs | 149 ++++++++++++++++++++++++++++++++ src/Xanthous/Util/Graphics.hs | 64 ++++++++++++++ test/Spec.hs | 2 + test/Xanthous/Data/EntityMapSpec.hs | 6 +- test/Xanthous/Util/GraphicsSpec.hs | 39 +++++++++ xanthous.cabal | 7 +- 17 files changed, 454 insertions(+), 52 deletions(-) create mode 100644 src/Xanthous/Data/EntityMap/Graphics.hs create mode 100644 src/Xanthous/Util/Graphics.hs create mode 100644 test/Xanthous/Util/GraphicsSpec.hs 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 . +-- +-- Code taken from +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 +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) diff --git a/test/Spec.hs b/test/Spec.hs index dd4212c2eb70..cac474053ccb 100644 --- a/test/Spec.hs +++ b/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 ] diff --git a/test/Xanthous/Data/EntityMapSpec.hs b/test/Xanthous/Data/EntityMapSpec.hs index c08b568d9eca..00bf1500466a 100644 --- a/test/Xanthous/Data/EntityMapSpec.hs +++ b/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 diff --git a/test/Xanthous/Util/GraphicsSpec.hs b/test/Xanthous/Util/GraphicsSpec.hs new file mode 100644 index 000000000000..4b761dc51fe9 --- /dev/null +++ b/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) + ] + ] diff --git a/xanthous.cabal b/xanthous.cabal index a8cd8d213d47..b625105b1b03 100644 --- a/xanthous.cabal +++ b/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 -- cgit 1.4.1