diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Data')
8 files changed, 0 insertions, 996 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Data/App.hs b/users/glittershark/xanthous/src/Xanthous/Data/App.hs deleted file mode 100644 index 0361d2a59e..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/App.hs +++ /dev/null @@ -1,39 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.App - ( Panel(..) - , ResourceName(..) - , AppEvent(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - --- | Enum for "panels" displayed in the game's UI. -data Panel - = InventoryPanel -- ^ A panel displaying the character's inventory - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary Panel - - -data ResourceName - = MapViewport -- ^ The main viewport where we display the game content - | Character -- ^ The character - | MessageBox -- ^ The box where we display messages to the user - | Prompt -- ^ The game's prompt - | Panel Panel -- ^ A panel in the game - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary ResourceName - -data AppEvent - = AutoContinue -- ^ Continue whatever autocommand has been requested by the - -- user - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary AppEvent diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs deleted file mode 100644 index 39953410f2..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Data.Entities - ( -- * Collisions - Collision(..) - , _Stop - , _Combat - -- * Entity Attributes - , EntityAttributes(..) - , blocksVision - , blocksObject - , collision - , defaultEntityAttributes - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON(..), FromJSON(..), (.:?), (.!=), withObject) -import Data.Aeson.Generic.DerivingVia -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Test.QuickCheck --------------------------------------------------------------------------------- - -data Collision - = Stop -- ^ Can't move through this - | Combat -- ^ Moving into this equates to hitting it with a stick - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Collision - deriving (ToJSON, FromJSON) - via WithOptions '[ AllNullaryToStringTag 'True ] - Collision -makePrisms ''Collision - --- | Attributes of an entity -data EntityAttributes = EntityAttributes - { _blocksVision :: Bool - -- | Does this entity block a large object from being put in the same tile as - -- it - eg a a door being closed on it - , _blocksObject :: Bool - -- | What type of collision happens when moving into this entity? - , _collision :: Collision - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EntityAttributes - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - EntityAttributes -makeLenses ''EntityAttributes - -instance FromJSON EntityAttributes where - parseJSON = withObject "EntityAttributes" $ \o -> do - _blocksVision <- o .:? "blocksVision" - .!= _blocksVision defaultEntityAttributes - _blocksObject <- o .:? "blocksObject" - .!= _blocksObject defaultEntityAttributes - _collision <- o .:? "collision" - .!= _collision defaultEntityAttributes - pure EntityAttributes {..} - -defaultEntityAttributes :: EntityAttributes -defaultEntityAttributes = EntityAttributes - { _blocksVision = False - , _blocksObject = False - , _collision = Stop - } diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs deleted file mode 100644 index 855a3462da..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.EntityChar - ( EntityChar(..) - , HasChar(..) - , HasStyle(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((.=)) --------------------------------------------------------------------------------- -import qualified Graphics.Vty.Attributes as Vty -import Test.QuickCheck -import Data.Aeson --------------------------------------------------------------------------------- -import Xanthous.Orphans () -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) --------------------------------------------------------------------------------- - - -class HasChar s a | s -> a where - char :: Lens' s a - {-# MINIMAL char #-} - -data EntityChar = EntityChar - { _char :: Char - , _style :: Vty.Attr - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EntityChar -makeFieldsNoPrefix ''EntityChar - -instance FromJSON EntityChar where - parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr - parseJSON (Object o) = do - (EntityChar _char _) <- o .: "char" - _style <- o .:? "style" .!= Vty.defAttr - pure EntityChar {..} - parseJSON _ = fail "Invalid type, expected string or object" - -instance ToJSON EntityChar where - toJSON (EntityChar chr styl) - | styl == Vty.defAttr = String $ chr <| Empty - | otherwise = object - [ "char" .= chr - , "style" .= styl - ] - -instance IsString EntityChar where - fromString [ch] = EntityChar ch Vty.defAttr - fromString _ = error "Entity char must only be a single character" diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs deleted file mode 100644 index d24defa841..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# 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 - , toEIDsAndPositioned - , atPosition - , atPositionWithIDs - , positions - , lookup - , lookupWithPosition - -- , positionedEntities - , neighbors - , Deduplicate(..) - - -- * debug - , byID - , byPosition - , lastID - - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup) -import Xanthous.Data - ( Position - , Positioned(..) - , positioned - , Neighbors(..) - , neighborPositions - ) -import Xanthous.Data.VectorBag -import Xanthous.Orphans () -import Xanthous.Util (EqEqProp(..)) --------------------------------------------------------------------------------- -import Data.Monoid (Endo(..)) -import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function) -import Test.QuickCheck.Checkers (EqProp) -import Test.QuickCheck.Instances.UnorderedContainers () -import Test.QuickCheck.Instances.Vector () -import Text.Show (showString, showParen) -import Data.Aeson --------------------------------------------------------------------------------- - -type EntityID = Word32 -type NonNullSet a = NonNull (Set a) - -data EntityMap a where - EntityMap :: - { _byPosition :: Map Position (NonNullSet EntityID) - , _byID :: HashMap EntityID (Positioned a) - , _lastID :: EntityID - } -> EntityMap a - deriving stock (Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function) -deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a) -makeLenses ''EntityMap - -instance ToJSON a => ToJSON (EntityMap a) where - toJSON = toJSON . toEIDsAndPositioned - - -instance FromJSON a => FromJSON (EntityMap a) where - parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON - -byIDInvariantError :: forall a. a -byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " - <> "must point to entityIDs in byID" - -instance (Ord a, Eq a) => Eq (EntityMap a) where - -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap - (==) = (==) `on` view (_EntityMap . to sort) - -deriving stock instance (Ord a) => Ord (EntityMap a) - -instance Show a => Show (EntityMap a) where - showsPrec pr em - = showParen (pr > 10) - $ showString - . ("fromEIDsAndPositioned " <>) - . show - . toEIDsAndPositioned - $ em - -instance Arbitrary a => Arbitrary (EntityMap a) where - arbitrary = review _EntityMap <$> arbitrary - shrink em = review _EntityMap <$> shrink (em ^. _EntityMap) - -type instance Index (EntityMap a) = EntityID -type instance IxValue (EntityMap a) = (Positioned a) -instance Ixed (EntityMap a) where ix eid = at eid . traverse - -instance At (EntityMap a) where - at eid = lens (view $ byID . at eid) setter - where - setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a - setter m Nothing = fromMaybe m $ do - Positioned pos _ <- m ^. byID . at eid - pure $ m - & removeEIDAtPos pos - & byID . at eid .~ Nothing - setter m (Just pe@(Positioned pos _)) = m - & (case lookupWithPosition eid m of - Nothing -> id - Just (Positioned origPos _) -> removeEIDAtPos origPos - ) - & byID . at eid ?~ pe - & byPosition . at pos %~ \case - Nothing -> Just $ opoint eid - Just es -> Just $ ninsertSet eid es - removeEIDAtPos pos = - byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid) - -instance Semigroup (EntityMap a) where - em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁ - -instance Monoid (EntityMap a) where - mempty = emptyEntityMap - -instance FunctorWithIndex EntityID EntityMap - -instance FoldableWithIndex EntityID EntityMap - -instance TraversableWithIndex EntityID EntityMap where - itraversed = byID . itraversed . rmap sequenceA . distrib - itraverse = itraverseOf itraversed - -type instance Element (EntityMap a) = a -instance MonoFoldable (EntityMap a) - -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 $ ninsertSet eid eids - Nothing -> Just $ opoint eid - _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID - in Deduplicate EntityMap{..} - - --------------------------------------------------------------------------------- - -_EntityMap :: Iso' (EntityMap a) [(Position, a)] -_EntityMap = iso hither yon - where - hither :: EntityMap a -> [(Position, a)] - hither em = do - (pos, eids) <- em ^. byPosition . _Wrapped - eid <- toList eids - ent <- em ^.. byID . at eid . folded . positioned - pure (pos, ent) - yon :: [(Position, a)] -> EntityMap a - yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap - - -insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a) -insertAtReturningID pos e em = - let (eid, em') = em & lastID <+~ 1 - in em' - & byID . at eid ?~ Positioned pos e - & byPosition . at pos %~ \case - Nothing -> Just $ opoint eid - Just es -> Just $ ninsertSet eid es - & (eid, ) - -insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a -insertAt pos e = snd . insertAtReturningID pos e - -atPosition :: forall a. (Ord a, Show a) => Position -> Lens' (EntityMap a) (VectorBag a) -atPosition pos = lens getter setter - where - getter em = - let eids :: VectorBag EntityID - eids = maybe mempty (VectorBag . toVector . toNullable) - $ em ^. byPosition . at pos - in getEIDAssume em <$> eids - setter em Empty = em & byPosition . at pos .~ Nothing - setter em (sort -> entities) = - let origEIDs = maybe Empty toNullable $ em ^. byPosition . at pos - origEntitiesWithIDs = - sortOn snd $ toList origEIDs <&> \eid -> (eid, getEIDAssume em eid) - go alles₁@((eid, e₁) :< es₁) -- orig - (e₂ :< es₂) -- new - | e₁ == e₂ - -- same, do nothing - = let (eids, lastEID, byID') = go es₁ es₂ - in (insertSet eid eids, lastEID, byID') - | otherwise - -- e₂ is new, generate a new ID for it - = let (eids, lastEID, byID') = go alles₁ es₂ - eid' = succ lastEID - in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos e₂) - go Empty Empty = (mempty, em ^. lastID, em ^. byID) - go orig Empty = - let byID' = foldr deleteMap (em ^. byID) $ map fst orig - in (mempty, em ^. lastID, byID') - go Empty (new :< news) = - let (eids, lastEID, byID') = go Empty news - eid' = succ lastEID - in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos new) - go _ _ = error "unreachable" - (eidsAtPosition, newLastID, newByID) = go origEntitiesWithIDs entities - in em & byPosition . at pos .~ fromNullable eidsAtPosition - & byID .~ newByID - & lastID .~ newLastID - -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 (toVector . toNullable) - $ em ^. byPosition . at pos - in (id &&& Positioned pos . getEIDAssume em) <$> eids - -fromEIDsAndPositioned - :: forall mono a. (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 $ ninsertSet eid eids - Nothing -> Just $ opoint eid - ) - newLastID em = em & lastID - .~ fromMaybe 1 - (maximumOf (ifolded . asIndex) (em ^. byID)) - -toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)] -toEIDsAndPositioned = itoListOf $ byID . ifolded - -positions :: EntityMap a -> [Position] -positions = toListOf $ byPosition . to keys . folded - -lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a) -lookupWithPosition eid = view $ byID . at eid - -lookup :: EntityID -> EntityMap a -> Maybe a -lookup eid = fmap (view positioned) . lookupWithPosition eid - --- unlawful :( --- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b) --- positionedEntities = byID . itraversed - -neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a) -neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos - --------------------------------------------------------------------------------- -makeWrapped ''Deduplicate diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs deleted file mode 100644 index 19e7b0cdf0..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ /dev/null @@ -1,64 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap.Graphics - ( visiblePositions - , visibleEntities - , linesOfSight - , canSee - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lines) --------------------------------------------------------------------------------- -import Xanthous.Util (takeWhileInclusive) -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Data.EntityMap -import Xanthous.Game.State -import Xanthous.Util.Graphics (circle, line) --------------------------------------------------------------------------------- - --- | Returns a set of positions that are visible, when taking into account --- 'blocksVision', from the given position, within the given radius. -visiblePositions - :: Entity e - => Position - -> Word -- ^ Vision radius - -> EntityMap e - -> Set Position -visiblePositions pos radius - = setFromList . positions . visibleEntities pos radius - --- | Returns a list of individual lines of sight, each of which is a list of --- entities at positions on that line of sight -linesOfSight - :: forall e. Entity e - => Position - -> Word - -> EntityMap e - -> [[(Position, Vector (EntityID, e))]] -linesOfSight (view _Position -> pos) visionRadius em - = entitiesOnLines - <&> takeWhileInclusive - (none (view blocksVision . entityAttributes . snd) . snd) - where - radius = circle pos $ fromIntegral visionRadius - lines = line pos <$> radius - entitiesOnLines :: [[(Position, Vector (EntityID, e))]] - entitiesOnLines = lines <&> map getPositionedAt - getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e)) - getPositionedAt p = - let ppos = _Position # p - in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em) - --- | 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 :: Entity e => Position -> Word -> EntityMap e -> EntityMap e -visibleEntities pos visionRadius - = fromEIDsAndPositioned - . foldMap (\(p, es) -> over _2 (Positioned p) <$> es) - . fold - . linesOfSight pos visionRadius - -canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool -canSee match pos radius = any match . visibleEntities pos radius --- ^ this might be optimizable diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs deleted file mode 100644 index efc0f53ace..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.Levels - ( Levels - , allLevels - , nextLevel - , prevLevel - , mkLevels1 - , mkLevels - , oneLevel - , current - , ComonadStore(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((<.>), Empty, foldMap) -import Xanthous.Util (between, EqProp, EqEqProp(..)) -import Xanthous.Util.Comonad (current) -import Xanthous.Orphans () --------------------------------------------------------------------------------- -import Control.Comonad.Store -import Control.Comonad.Store.Zipper -import Data.Aeson (ToJSON(..), FromJSON(..)) -import Data.Aeson.Generic.DerivingVia -import Data.Functor.Apply -import Data.Foldable (foldMap) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust) -import Data.Sequence (Seq((:<|), Empty)) -import Data.Semigroup.Foldable.Class -import Data.Text (replace) -import Test.QuickCheck --------------------------------------------------------------------------------- - --- | Collection of levels plus a pointer to the current level --- --- Navigation is via the 'Comonad' instance. We can get the current level with --- 'extract': --- --- extract @Levels :: Levels level -> level --- --- For access to and modification of the level, use --- 'Xanthous.Util.Comonad.current' -newtype Levels a = Levels { levelZipper :: Zipper Seq a } - deriving stock (Generic) - deriving (Functor, Comonad, Foldable) via (Zipper Seq) - deriving (ComonadStore Int) via (Zipper Seq) - -type instance Element (Levels a) = a -instance MonoFoldable (Levels a) -instance MonoFunctor (Levels a) -instance MonoTraversable (Levels a) - -instance Traversable Levels where - traverse f (Levels z) = Levels <$> traverse f z - -instance Foldable1 Levels - -instance Traversable1 Levels where - traverse1 f (Levels z) = seek (pos z) . partialMkLevels <$> go (unzipper z) - where - go Empty = error "empty seq, unreachable" - go (x :<| xs) = (<|) <$> f x <.> go xs - --- | Always takes the position of the latter element -instance Semigroup (Levels a) where - levs₁ <> levs₂ - = seek (pos levs₂) - . partialMkLevels - $ allLevels levs₁ <> allLevels levs₂ - --- | Make Levels from a Seq. Throws an error if the seq is not empty -partialMkLevels :: Seq a -> Levels a -partialMkLevels = Levels . fromJust . zipper - --- | Make Levels from a possibly-empty structure -mkLevels :: Foldable1 f => f level -> Maybe (Levels level) -mkLevels = fmap Levels . zipper . foldMap pure - --- | Make Levels from a non-empty structure -mkLevels1 :: Foldable1 f => f level -> Levels level -mkLevels1 = fromJust . mkLevels - -oneLevel :: a -> Levels a -oneLevel = mkLevels1 . Identity - --- | Get a sequence of all the levels -allLevels :: Levels a -> Seq a -allLevels = unzipper . levelZipper - --- | Step to the next level, generating a new level if necessary using the given --- applicative action -nextLevel - :: Applicative m - => m level -- ^ Generate a new level, if necessary - -> Levels level - -> m (Levels level) -nextLevel genLevel levs - | pos levs + 1 < size (levelZipper levs) - = pure $ seeks succ levs - | otherwise - = genLevel <&> \level -> - seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level - --- | Go to the previous level. Returns Nothing if 'pos' is 0 -prevLevel :: Levels level -> Maybe (Levels level) -prevLevel levs | pos levs == 0 = Nothing - | otherwise = Just $ seeks pred levs - --------------------------------------------------------------------------------- - --- | alternate, slower representation of Levels we can Iso into to perform --- various operations -data AltLevels a = AltLevels - { _levels :: NonEmpty a - , _currentLevel :: Int -- ^ invariant: is within the bounds of _levels - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - (AltLevels a) -makeLenses ''AltLevels - -alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b) -alt = iso hither yon - where - hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs) - yon (AltLevels levs curr) = seek curr $ mkLevels1 levs - -instance Eq a => Eq (Levels a) where - (==) = (==) `on` view alt - -deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a) - -instance Show a => Show (Levels a) where - show = unpack . replace "AltLevels" "Levels" . pack . show . view alt - -instance NFData a => NFData (Levels a) where - rnf = rnf . view alt - -instance ToJSON a => ToJSON (Levels a) where - toJSON = toJSON . view alt - -instance FromJSON a => FromJSON (Levels a) where - parseJSON = fmap (review alt) . parseJSON - -instance Arbitrary a => Arbitrary (AltLevels a) where - arbitrary = do - _levels <- arbitrary - _currentLevel <- choose (0, length _levels - 1) - pure AltLevels {..} - shrink als = do - _levels <- shrink $ als ^. levels - _currentLevel <- filter (between 0 $ length _levels - 1) - $ shrink $ als ^. currentLevel - pure AltLevels {..} - - -instance Arbitrary a => Arbitrary (Levels a) where - arbitrary = review alt <$> arbitrary - shrink = fmap (review alt) . shrink . view alt - -instance CoArbitrary a => CoArbitrary (Levels a) where - coarbitrary = coarbitrary . view alt - -instance Function a => Function (Levels a) where - function = functionMap (view alt) (review alt) diff --git a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs deleted file mode 100644 index 1b875d4483..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PolyKinds #-} --------------------------------------------------------------------------------- -module Xanthous.Data.NestedMap - ( NestedMapVal(..) - , NestedMap(..) - , lookup - , lookupVal - , insert - - -- * - , (:->) - , BifunctorFunctor'(..) - , BifunctorMonad'(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup, foldMap) -import qualified Xanthous.Prelude as P --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson -import Data.Function (fix) -import Data.Foldable (Foldable(..)) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE --------------------------------------------------------------------------------- - --- | Natural transformations on bifunctors -type (:->) p q = forall a b. p a b -> q a b -infixr 0 :-> - -class (forall b. Bifunctor b => Bifunctor (t b)) => BifunctorFunctor' t where - bifmap' :: (Bifunctor p, Bifunctor q) => (p :-> q) -> t p :-> t q - -class BifunctorFunctor' t => BifunctorMonad' t where - bireturn' :: (Bifunctor p) => p :-> t p - - bibind' :: (Bifunctor p, Bifunctor q) => (p :-> t q) -> t p :-> t q - bibind' f = bijoin' . bifmap' f - - bijoin' :: (Bifunctor p) => t (t p) :-> t p - bijoin' = bibind' id - - {-# MINIMAL bireturn', (bibind' | bijoin') #-} - --------------------------------------------------------------------------------- - -data NestedMapVal m k v = Val v | Nested (NestedMap m k v) - -deriving stock instance - ( forall k' v'. (Show k', Show v') => Show (m k' v') - , Show k - , Show v - ) => Show (NestedMapVal m k v) - -deriving stock instance - ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') - , Eq k - , Eq v - ) => Eq (NestedMapVal m k v) - -instance - forall m k v. - ( Arbitrary (m k v) - , Arbitrary (m k (NestedMapVal m k v)) - , Arbitrary k - , Arbitrary v - , IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) => Arbitrary (NestedMapVal m k v) where - arbitrary = sized . fix $ \gen n -> - let nst = fmap (NestedMap . mapFromList) - . listOf - $ (,) <$> arbitrary @k <*> gen (n `div` 2) - in if n == 0 - then Val <$> arbitrary - else oneof [ Val <$> arbitrary - , Nested <$> nst] - shrink (Val v) = Val <$> shrink v - shrink (Nested mkv) = Nested <$> shrink mkv - -instance Functor (m k) => Functor (NestedMapVal m k) where - fmap f (Val v) = Val $ f v - fmap f (Nested m) = Nested $ fmap f m - -instance Bifunctor m => Bifunctor (NestedMapVal m) where - bimap _ g (Val v) = Val $ g v - bimap f g (Nested m) = Nested $ bimap f g m - -instance BifunctorFunctor' NestedMapVal where - bifmap' _ (Val v) = Val v - bifmap' f (Nested m) = Nested $ bifmap' f m - -instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) - => ToJSON (NestedMapVal m k v) where - toJSON (Val v) = toJSON v - toJSON (Nested m) = toJSON m - -instance Foldable (m k) => Foldable (NestedMapVal m k) where - foldMap f (Val v) = f v - foldMap f (Nested m) = foldMap f m - --- _NestedMapVal --- :: forall m k v m' k' v'. --- ( IsMap (m k v), IsMap (m' k' v') --- , IsMap (m [k] v), IsMap (m' [k'] v') --- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' --- , ContainerKey (m [k] v) ~ [k], ContainerKey (m' [k'] v') ~ [k'] --- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' --- , MapValue (m [k] v) ~ v, MapValue (m' [k'] v') ~ v' --- ) --- => Iso (NestedMapVal m k v) --- (NestedMapVal m' k' v') --- (m [k] v) --- (m' [k'] v') --- _NestedMapVal = iso hither yon --- where --- hither :: NestedMapVal m k v -> m [k] v --- hither (Val v) = singletonMap [] v --- hither (Nested m) = bimap _ _ $ m ^. _NestedMap --- yon = _ - --------------------------------------------------------------------------------- - -newtype NestedMap m k v = NestedMap (m k (NestedMapVal m k v)) - -deriving stock instance - ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') - , Eq k - , Eq v - ) => Eq (NestedMap m k v) - -deriving stock instance - ( forall k' v'. (Show k', Show v') => Show (m k' v') - , Show k - , Show v - ) => Show (NestedMap m k v) - -instance Arbitrary (m k (NestedMapVal m k v)) - => Arbitrary (NestedMap m k v) where - arbitrary = NestedMap <$> arbitrary - shrink (NestedMap m) = NestedMap <$> shrink m - -instance Functor (m k) => Functor (NestedMap m k) where - fmap f (NestedMap m) = NestedMap $ fmap (fmap f) m - -instance Bifunctor m => Bifunctor (NestedMap m) where - bimap f g (NestedMap m) = NestedMap $ bimap f (bimap f g) m - -instance BifunctorFunctor' NestedMap where - bifmap' f (NestedMap m) = NestedMap . f $ bimap id (bifmap' f) m - -instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) - => ToJSON (NestedMap m k v) where - toJSON (NestedMap m) = toJSON m - -instance Foldable (m k) => Foldable (NestedMap m k) where - foldMap f (NestedMap m) = foldMap (foldMap f) m - --------------------------------------------------------------------------------- - -lookup - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> NestedMap m k v - -> Maybe (NestedMapVal m k v) -lookup (p :| []) (NestedMap vs) = P.lookup p vs -lookup (p :| (p₁ : ps)) (NestedMap vs) = P.lookup p vs >>= \case - (Val _) -> Nothing - (Nested vs') -> lookup (p₁ :| ps) vs' - -lookupVal - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> NestedMap m k v - -> Maybe v -lookupVal ks m - | Just (Val v) <- lookup ks m = Just v - | otherwise = Nothing - -insert - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> v - -> NestedMap m k v - -> NestedMap m k v -insert (k :| []) v (NestedMap m) = NestedMap $ P.insertMap k (Val v) m -insert (k₁ :| (k₂ : ks)) v (NestedMap m) = NestedMap $ alterMap upd k₁ m - where - upd (Just (Nested nm)) = Just . Nested $ insert (k₂ :| ks) v nm - upd _ = Just $ - let (kΩ :| ks') = NE.reverse (k₂ :| ks) - in P.foldl' - (\m' k -> Nested . NestedMap . singletonMap k $ m') - (Nested . NestedMap . singletonMap kΩ $ Val v) - ks' - --- _NestedMap --- :: ( IsMap (m k v), IsMap (m' k' v') --- , IsMap (m (NonEmpty k) v), IsMap (m' (NonEmpty k') v') --- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' --- , ContainerKey (m (NonEmpty k) v) ~ (NonEmpty k) --- , ContainerKey (m' (NonEmpty k') v') ~ (NonEmpty k') --- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' --- , MapValue (m (NonEmpty k) v) ~ v, MapValue (m' (NonEmpty k') v') ~ v' --- ) --- => Iso (NestedMap m k v) --- (NestedMap m' k' v') --- (m (NonEmpty k) v) --- (m' (NonEmpty k') v') --- _NestedMap = iso undefined yon --- where --- hither (NestedMap m) = undefined . mapToList $ m --- yon mkv = undefined diff --git a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs deleted file mode 100644 index 2e6d48062a..0000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.VectorBag - (VectorBag(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Aeson -import qualified Data.Vector as V -import Test.QuickCheck -import Test.QuickCheck.Instances.Vector () --------------------------------------------------------------------------------- - --- | Acts exactly like a Vector, except ignores order when testing for equality -newtype VectorBag a = VectorBag (Vector a) - deriving stock - ( Traversable - , Generic - ) - deriving newtype - ( Show - , Read - , Foldable - , FromJSON - , FromJSON1 - , ToJSON - , Reversing - , Applicative - , Functor - , Monad - , Monoid - , Semigroup - , Arbitrary - , CoArbitrary - , Filterable - ) -makeWrapped ''VectorBag - -instance Function a => Function (VectorBag a) where - function = functionMap (\(VectorBag v) -> v) VectorBag - -type instance Element (VectorBag a) = a -deriving via (Vector a) instance MonoFoldable (VectorBag a) -deriving via (Vector a) instance GrowingAppend (VectorBag a) -deriving via (Vector a) instance SemiSequence (VectorBag a) -deriving via (Vector a) instance MonoPointed (VectorBag a) -deriving via (Vector a) instance MonoFunctor (VectorBag a) - -instance Cons (VectorBag a) (VectorBag b) a b where - _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) -> - if V.null v - then Left (VectorBag mempty) - else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v) - -instance AsEmpty (VectorBag a) where - _Empty = prism' (const $ VectorBag Empty) $ \case - (VectorBag Empty) -> Just () - _ -> Nothing - -instance Witherable VectorBag where - wither f (VectorBag v) = VectorBag <$> wither f v - witherM f (VectorBag v) = VectorBag <$> witherM f v - filterA p (VectorBag v) = VectorBag <$> filterA p v - -{- - TODO: - , Ixed - , FoldableWithIndex - , FunctorWithIndex - , TraversableWithIndex - , Snoc - , Each --} - -instance Ord a => Eq (VectorBag a) where - (==) = (==) `on` (view _Wrapped . sort) - -instance Ord a => Ord (VectorBag a) where - compare = compare `on` (view _Wrapped . sort) - -instance MonoTraversable (VectorBag a) where - otraverse f (VectorBag v) = VectorBag <$> otraverse f v - -instance IsSequence (VectorBag a) where - fromList = VectorBag . fromList - break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v - span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v - dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v - takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v - splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v - unsafeSplitAt idx (VectorBag v) = - bimap VectorBag VectorBag $ unsafeSplitAt idx v - take n (VectorBag v) = VectorBag $ take n v - unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v - drop n (VectorBag v) = VectorBag $ drop n v - unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v - partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v |