about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
diff options
context:
space:
mode:
authorAspen Smith <grfn@gws.fyi>2024-02-12T03·00-0500
committerclbot <clbot@tvl.fyi>2024-02-14T19·37+0000
commit82ecd61f5c699cf3af6c4eadf47a1c52b1d696c6 (patch)
tree429c5e078528000591742ec3211bc768ae913a78 /users/grfn/xanthous/src/Xanthous/Entities/Common.hs
parent0ba476a4266015f278f18d74094299de74a5a111 (diff)
chore(users): grfn -> aspen r/7511
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Entities/Common.hs')
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Common.hs290
1 files changed, 0 insertions, 290 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
deleted file mode 100644
index 368b03f25bed..000000000000
--- a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
+++ /dev/null
@@ -1,290 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------------------------------
--- |
--- Module      : Xanthous.Entities.Common
--- Description : Common data type definitions and utilities for entities
---
---------------------------------------------------------------------------------
-module Xanthous.Entities.Common
-  ( -- * Inventory
-    Inventory(..)
-  , HasInventory(..)
-  , backpack
-  , wielded
-  , items
-  , InventoryPosition(..)
-  , describeInventoryPosition
-  , inventoryPosition
-  , itemsWithPosition
-  , removeItemFromPosition
-
-    -- ** Wielded items
-  , Wielded(..)
-  , nothingWielded
-  , hands
-  , leftHand
-  , rightHand
-  , inLeftHand
-  , inRightHand
-  , doubleHanded
-  , Hand(..)
-  , itemsInHand
-  , inHand
-  , wieldInHand
-  , describeHand
-  , wieldedItems
-  , WieldedItem(..)
-  , wieldedItem
-  , wieldableItem
-  , asWieldedItem
-  ) where
---------------------------------------------------------------------------------
-import           Xanthous.Prelude
---------------------------------------------------------------------------------
-import           Data.Aeson (ToJSON, FromJSON)
-import           Data.Aeson.Generic.DerivingVia
-import           Test.QuickCheck
-import           Test.QuickCheck.Checkers (EqProp)
---------------------------------------------------------------------------------
-import           Xanthous.Data (Positioned(..), positioned)
-import           Xanthous.Util.QuickCheck
-import           Xanthous.Game.State
-import           Xanthous.Entities.Item
-import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
-import           Xanthous.Util (removeFirst, EqEqProp(..))
---------------------------------------------------------------------------------
-
-data WieldedItem = WieldedItem
-  { _wieldedItem :: Item
-  , _wieldableItem :: WieldableItem
-    -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem
-  }
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving (ToJSON, FromJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           WieldedItem
-makeFieldsNoPrefix ''WieldedItem
-
-asWieldedItem :: Prism' Item WieldedItem
-asWieldedItem = prism' hither yon
- where
-   yon item = WieldedItem item <$> item ^. itemType . wieldable
-   hither (WieldedItem item _) = item
-
-instance Brain WieldedItem where
-  step ticks (Positioned p wi) =
-    over positioned (\i -> WieldedItem i $ wi ^. wieldableItem)
-    <$> step ticks (Positioned p $ wi ^. wieldedItem)
-
-instance Draw WieldedItem where
-  draw = draw . view wieldedItem
-
-instance Entity WieldedItem where
-  entityAttributes = entityAttributes . view wieldedItem
-  description = description . view wieldedItem
-  entityChar = entityChar . view wieldedItem
-
-instance Arbitrary WieldedItem where
-  arbitrary = genericArbitrary <&> \wi ->
-    wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem
-
-data Wielded
-  = DoubleHanded WieldedItem
-  | Hands { _leftHand :: !(Maybe WieldedItem)
-          , _rightHand :: !(Maybe WieldedItem)
-          }
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary Wielded
-  deriving (ToJSON, FromJSON)
-       via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
-           Wielded
-
-
-nothingWielded :: Wielded
-nothingWielded = Hands Nothing Nothing
-
-hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem)
-hands = prism' (uncurry Hands) $ \case
-  Hands l r -> Just (l, r)
-  _ -> Nothing
-
-leftHand :: Traversal' Wielded (Maybe WieldedItem)
-leftHand = hands . _1
-
-inLeftHand :: WieldedItem -> Wielded
-inLeftHand wi = Hands (Just wi) Nothing
-
-rightHand :: Traversal' Wielded (Maybe WieldedItem)
-rightHand = hands . _2
-
-inRightHand :: WieldedItem -> Wielded
-inRightHand wi = Hands Nothing (Just wi)
-
-doubleHanded :: Prism' Wielded WieldedItem
-doubleHanded = prism' DoubleHanded $ \case
-  DoubleHanded i -> Just i
-  _ -> Nothing
-
-wieldedItems :: Traversal' Wielded WieldedItem
-wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
-wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r
-
-
-data Hand
-  = LeftHand
-  | RightHand
-  | BothHands
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary Hand
-
-itemsInHand :: Hand -> Wielded -> [WieldedItem]
-itemsInHand LeftHand (DoubleHanded wi) = [wi]
-itemsInHand LeftHand (Hands lh _) = toList lh
-itemsInHand RightHand (DoubleHanded wi) = [wi]
-itemsInHand RightHand (Hands _ rh) = toList rh
-itemsInHand BothHands (DoubleHanded wi) = [wi]
-itemsInHand BothHands (Hands lh rh) = toList lh <> toList rh
-
-inHand :: Hand -> WieldedItem -> Wielded
-inHand LeftHand = inLeftHand
-inHand RightHand = inRightHand
-inHand BothHands = review doubleHanded
-
-wieldInHand :: Hand -> WieldedItem -> Wielded -> ([WieldedItem], Wielded)
-wieldInHand hand item w = (itemsInHand hand w, doWield)
-  where
-    doWield = case (hand, w) of
-      (LeftHand, Hands _ r) -> Hands (Just item) r
-      (LeftHand, DoubleHanded _) -> inLeftHand item
-      (RightHand, Hands l _) -> Hands l (Just item)
-      (RightHand, DoubleHanded _) -> inRightHand item
-      (BothHands, _) -> DoubleHanded item
-
-describeHand :: Hand -> Text
-describeHand LeftHand = "your left hand"
-describeHand RightHand = "your right hand"
-describeHand BothHands = "both hands"
-
-data Inventory = Inventory
-  { _backpack :: Vector Item
-  , _wielded :: Wielded
-  }
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary Inventory
-  deriving EqProp via EqEqProp Inventory
-  deriving (ToJSON, FromJSON)
-       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
-           Inventory
-makeFieldsNoPrefix ''Inventory
-
-items :: Traversal' Inventory Item
-items k (Inventory bp w) = Inventory
-  <$> traversed k bp
-  <*> (wieldedItems . wieldedItem) k w
-
-type instance Element Inventory = Item
-
-instance MonoFunctor Inventory where
-  omap = over items
-
-instance MonoFoldable Inventory where
-  ofoldMap = foldMapOf items
-  ofoldr = foldrOf items
-  ofoldl' = foldlOf' items
-  otoList = toListOf items
-  oall = allOf items
-  oany = anyOf items
-  onull = nullOf items
-  ofoldr1Ex = foldr1Of items
-  ofoldl1Ex' = foldl1Of' items
-  headEx = headEx . toListOf items
-  lastEx = lastEx . toListOf items
-
-instance MonoTraversable Inventory where
-  otraverse = traverseOf items
-
-instance Semigroup Inventory where
-  inv₁ <> inv₂ =
-    let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack
-        (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of
-          (wielded₁, wielded₂@(DoubleHanded _)) ->
-            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
-          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
-            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
-          (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack')
-          (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack')
-          (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) ->
-            (Hands (Just l₁) (Just r₂), backpack')
-          (wielded₁@(DoubleHanded _), wielded₂) ->
-            (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem))
-          (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) ->
-            (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack')
-          (Hands Nothing r₁, Hands (Just l₂) Nothing) ->
-            (Hands (Just l₂) r₁, backpack')
-          (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) ->
-            (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack')
-          (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) ->
-            (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack')
-          (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) ->
-            (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack')
-    in Inventory backpack'' wielded'
-
-instance Monoid Inventory where
-  mempty = Inventory mempty $ Hands Nothing Nothing
-
-class HasInventory s a | s -> a where
-  inventory :: Lens' s a
-  {-# MINIMAL inventory #-}
-
--- | Representation for where in the inventory an item might be
-data InventoryPosition
-  = Backpack
-  | InHand Hand
-  deriving stock (Eq, Show, Ord, Generic)
-  deriving anyclass (NFData, CoArbitrary, Function)
-  deriving Arbitrary via GenericArbitrary InventoryPosition
-
--- | Return a human-readable description of the given 'InventoryPosition'
-describeInventoryPosition :: InventoryPosition -> Text
-describeInventoryPosition Backpack       = "In backpack"
-describeInventoryPosition (InHand hand)  = "Wielded, in " <> describeHand hand
-
--- | Given a position in the inventory, return a traversal on the inventory over
--- all the items in that position
-inventoryPosition :: InventoryPosition -> Traversal' Inventory Item
-inventoryPosition Backpack = backpack . traversed
-inventoryPosition (InHand LeftHand) = wielded . leftHand . _Just . wieldedItem
-inventoryPosition (InHand RightHand) = wielded . leftHand . _Just . wieldedItem
-inventoryPosition (InHand BothHands) = wielded . doubleHanded . wieldedItem
-
--- | A fold over all the items in the inventory accompanied by their position in
--- the inventory
---
--- Invariant: This will return items in the same order as 'items'
-itemsWithPosition :: Fold Inventory (InventoryPosition, Item)
-itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems
-  where
-    backpackItems = toListOf $ backpack . folded . to (Backpack ,)
-    handItems inv = case inv ^. wielded of
-       DoubleHanded i -> pure (InHand BothHands, i ^. wieldedItem)
-       Hands l r -> (l ^.. folded . wieldedItem . to (InHand LeftHand ,))
-                 <> (r ^.. folded . wieldedItem . to (InHand RightHand ,))
-
--- | Remove the first item equal to 'Item' from the given position in the
--- inventory
-removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory
-removeItemFromPosition Backpack item inv
-  = inv & backpack %~ removeFirst (== item)
-removeItemFromPosition (InHand LeftHand) item inv
-  = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem)
-removeItemFromPosition (InHand RightHand) item inv
-  = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem)
-removeItemFromPosition (InHand BothHands) item inv
-  | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv
-  = inv & wielded .~ nothingWielded
-  | otherwise
-  = inv