refactor(users/glittershark): Rename to grfn r/2485

Rename my //users directory and all places that refer to glittershark to
grfn, including nix references and documentation.

This may require some extra attention inside of gerrit's database after
it lands to allow me to actually push things.

Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: lukegb <lukegb@tvl.fyi>
Reviewed-by: glittershark <grfn@gws.fyi>

8 files changed, 996 insertions, 0 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Data/App.hs b/users/grfn/xanthous/src/Xanthous/Data/App.hs
new file mode 100644
index 000000000000..0361d2a59ed5
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/App.hs
@@ -0,0 +1,39 @@
+--------------------------------------------------------------------------------
+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/grfn/xanthous/src/Xanthous/Data/Entities.hs b/users/grfn/xanthous/src/Xanthous/Data/Entities.hs
new file mode 100644
index 000000000000..39953410f2f3
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/Entities.hs
@@ -0,0 +1,68 @@
+{-# 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/grfn/xanthous/src/Xanthous/Data/EntityChar.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs
new file mode 100644
index 000000000000..855a3462daee
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs
@@ -0,0 +1,56 @@
+{-# 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/grfn/xanthous/src/Xanthous/Data/EntityMap.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs
new file mode 100644
index 000000000000..d24defa841ab
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs
@@ -0,0 +1,272 @@
+{-# 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/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
new file mode 100644
index 000000000000..19e7b0cdf086
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
@@ -0,0 +1,64 @@
+--------------------------------------------------------------------------------
+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/grfn/xanthous/src/Xanthous/Data/Levels.hs b/users/grfn/xanthous/src/Xanthous/Data/Levels.hs
new file mode 100644
index 000000000000..efc0f53acecf
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/Levels.hs
@@ -0,0 +1,170 @@
+{-# 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/grfn/xanthous/src/Xanthous/Data/NestedMap.hs b/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs
new file mode 100644
index 000000000000..1b875d448302
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs
@@ -0,0 +1,227 @@
+{-# 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/grfn/xanthous/src/Xanthous/Data/VectorBag.hs b/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs
new file mode 100644
index 000000000000..2e6d48062a45
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs
@@ -0,0 +1,100 @@
+{-# 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