diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 82c32f05a..d4cc8d2b4 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 468e59217..704b3c6e7 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 e713aff32..926a02a48 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 + , 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 - 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 000000000..21a380a72 --- /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 bd52ae62b..223c8d769 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 faa9964a3..e2ca874dd 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 983772090..5af24a8cd 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 f5301f94a..90fa05315 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 6a4689610..ed65217e6 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 4d3cb15dc..bb6508acd 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 6a2d27839..e399ca5d4 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 cf1f80b82..439f9e8ff 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 000000000..5a174d4f4 --- /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 dd4212c2e..cac474053 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 c08b568d9..00bf15004 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 000000000..4b761dc51 --- /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 a8cd8d213..b625105b1 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