diff options
Diffstat (limited to 'users/aspen/xanthous/src')
69 files changed, 9927 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs b/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs new file mode 100644 index 0000000000..e89fcd6211 --- /dev/null +++ b/users/aspen/xanthous/src/Data/Aeson/Generic/DerivingVia.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ConstraintKinds, DataKinds, DeriveGeneric, DerivingVia #-} +{-# LANGUAGE ExplicitNamespaces, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds, ScopedTypeVariables, StandaloneDeriving #-} +{-# LANGUAGE TypeApplications, TypeFamilies, TypeInType, TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall #-} +-- | https://gist.github.com/konn/27c00f784dd883ec2b90eab8bc84a81d +module Data.Aeson.Generic.DerivingVia + ( StrFun(..), Setting(..), SumEncoding'(..), DefaultOptions, WithOptions(..) + , -- Utility type synonyms to save ticks (') before promoted data constructors + type Drop, type CamelTo2, type UserDefined + , type TaggedObj, type UntaggedVal, type ObjWithSingleField, type TwoElemArr + , type FieldLabelModifier + , type ConstructorTagModifier + , type AllNullaryToStringTag + , type OmitNothingFields + , type SumEnc + , type UnwrapUnaryRecords + , type TagSingleConstructors + ) + where + +import Prelude +import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, + ToJSON (..)) +import Data.Aeson (Options (..), Zero, camelTo2, + genericParseJSON) +import Data.Aeson (defaultOptions, genericToJSON) +import qualified Data.Aeson as Aeson +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (..)) +import Data.Reflection (Reifies (..)) +import GHC.Generics (Generic, Rep) +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, symbolVal) +import GHC.TypeLits (Nat, Symbol) + +newtype WithOptions options a = WithOptions { runWithOptions :: a } + +data StrFun = Drop Nat + | CamelTo2 Symbol + | forall p. UserDefined p + +type Drop = 'Drop +type CamelTo2 = 'CamelTo2 +type UserDefined = 'UserDefined + +type family Demoted a where + Demoted Symbol = String + Demoted StrFun = String -> String + Demoted [a] = [Demoted a] + Demoted Setting = Options -> Options + Demoted SumEncoding' = Aeson.SumEncoding + Demoted a = a + +data SumEncoding' = TaggedObj {tagFieldName' :: Symbol, contentsFieldName :: Symbol } + | UntaggedVal + | ObjWithSingleField + | TwoElemArr + +type TaggedObj = 'TaggedObj +type UntaggedVal = 'UntaggedVal +type ObjWithSingleField = 'ObjWithSingleField +type TwoElemArr = 'TwoElemArr + +data Setting = FieldLabelModifier [StrFun] + | ConstructorTagModifier [StrFun] + | AllNullaryToStringTag Bool + | OmitNothingFields Bool + | SumEnc SumEncoding' + | UnwrapUnaryRecords Bool + | TagSingleConstructors Bool + +type FieldLabelModifier = 'FieldLabelModifier +type ConstructorTagModifier = 'ConstructorTagModifier +-- | If 'True' the constructors of a datatype, with all nullary constructors, +-- will be encoded to just a string with the constructor tag. If 'False' the +-- encoding will always follow the 'SumEncoding'. +type AllNullaryToStringTag = 'AllNullaryToStringTag +type OmitNothingFields = 'OmitNothingFields +type SumEnc = 'SumEnc +-- | Hide the field name when a record constructor has only one field, like a +-- newtype. +type UnwrapUnaryRecords = 'UnwrapUnaryRecords +-- | Encode types with a single constructor as sums, so that +-- 'AllNullaryToStringTag' and 'SumEncoding' apply. +type TagSingleConstructors = 'TagSingleConstructors + +class Demotable (a :: k) where + demote :: proxy a -> Demoted k + +type All :: (Type -> Constraint) -> [Type] -> Constraint +type family All p xs where + All p '[] = () + All p (x ': xs) = (p x, All p xs) + +instance Reifies f (String -> String) => Demotable ('UserDefined f) where + demote _ = reflect @f Proxy + +instance KnownSymbol sym => Demotable sym where + demote = symbolVal + +instance (KnownSymbol s, KnownSymbol t) => Demotable ('TaggedObj s t) where + demote _ = Aeson.TaggedObject (symbolVal @s Proxy) (symbolVal @t Proxy) + +instance Demotable 'UntaggedVal where + demote _ = Aeson.UntaggedValue + +instance Demotable 'ObjWithSingleField where + demote _ = Aeson.ObjectWithSingleField + +instance Demotable 'TwoElemArr where + demote _ = Aeson.TwoElemArray + +instance Demotable xs => Demotable ('FieldLabelModifier xs) where + demote _ o = o { fieldLabelModifier = foldr (.) id (demote (Proxy @xs)) } + +instance Demotable xs => Demotable ('ConstructorTagModifier xs) where + demote _ o = o { constructorTagModifier = foldr (.) id (demote (Proxy @xs)) } + +instance Demotable b => Demotable ('AllNullaryToStringTag b) where + demote _ o = o { allNullaryToStringTag = demote (Proxy @b) } + +instance Demotable b => Demotable ('OmitNothingFields b) where + demote _ o = o { omitNothingFields = demote (Proxy @b) } + +instance Demotable b => Demotable ('UnwrapUnaryRecords b) where + demote _ o = o { unwrapUnaryRecords = demote (Proxy @b) } + +instance Demotable b => Demotable ('TagSingleConstructors b) where + demote _ o = o { tagSingleConstructors = demote (Proxy @b) } + +instance Demotable b => Demotable ('SumEnc b) where + demote _ o = o { sumEncoding = demote (Proxy @b) } + +instance Demotable 'True where + demote _ = True + +instance Demotable 'False where + demote _ = False + +instance KnownNat n => Demotable ('Drop n) where + demote _ = drop (fromIntegral $ natVal (Proxy :: Proxy n)) + +instance KnownSymbol sym => Demotable ('CamelTo2 sym) where + demote _ = camelTo2 $ head $ symbolVal @sym Proxy + +instance {-# OVERLAPPING #-} Demotable ('[] :: [k]) where + demote _ = [] + +instance (Demotable (x :: k), Demotable (xs :: [k])) => Demotable (x ': xs) where + demote _ = demote (Proxy @x) : demote (Proxy @xs) + +type DefaultOptions = ('[] :: [Setting]) + +reflectOptions :: forall xs proxy. Demotable (xs :: [Setting]) => proxy xs -> Options +reflectOptions pxy = foldr (.) id (demote pxy) defaultOptions + +instance (Demotable (options :: [Setting])) => Reifies options Options where + reflect = reflectOptions + +instance (Generic a, GToJSON Zero (Rep a), Reifies (options :: k) Options) + => ToJSON (WithOptions options a) where + toJSON = genericToJSON (reflect (Proxy @options)) . runWithOptions + +instance (Generic a, GFromJSON Zero (Rep a), Reifies (options :: k) Options) + => FromJSON (WithOptions options a) where + parseJSON = fmap WithOptions . genericParseJSON (reflect (Proxy @options)) diff --git a/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs b/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs new file mode 100644 index 0000000000..1f2b513ffe --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/AI/Gormlak.hs @@ -0,0 +1,201 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +module Xanthous.AI.Gormlak + ( HasVisionRadius(..) + , GormlakBrain(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lines) +-------------------------------------------------------------------------------- +import Control.Monad.State +import Control.Monad.Random +import Data.Aeson (object) +import qualified Data.Aeson as A +import Data.Generics.Product.Fields +-------------------------------------------------------------------------------- +import Xanthous.Data + ( Positioned(..), positioned, position, _Position + , diffPositions, stepTowards, isUnit + , Ticks, (|*|), invertedRate + ) +import Xanthous.Data.EntityMap +import Xanthous.Entities.Creature.Hippocampus +import Xanthous.Entities.Character (Character) +import qualified Xanthous.Entities.Character as Character +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Entities.RawTypes + ( CreatureType, HasLanguage(language), getLanguage + , HasAttacks (attacks), creatureAttackMessage + ) +import Xanthous.Entities.Common + ( wielded, Inventory, wieldedItems, WieldedItem (WieldedItem) ) +import Xanthous.Game.State +import Xanthous.Game.Lenses + ( entitiesCollision, collisionAt + , character, characterPosition, positionIsCharacterVisible + , hearingRadius + ) +import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) +import Xanthous.Random +import Xanthous.Monad (say, message) +import Xanthous.Generators.Speech (word) +import qualified Linear.Metric as Metric +import qualified Xanthous.Messages as Messages +-------------------------------------------------------------------------------- + +-- TODO move the following two classes to a more central location + +class HasVisionRadius a where visionRadius :: a -> Word + +type IsCreature entity = + ( HasVisionRadius entity + , HasField "_hippocampus" entity entity Hippocampus Hippocampus + , HasField "_creatureType" entity entity CreatureType CreatureType + , HasField "_inventory" entity entity Inventory Inventory + , A.ToJSON entity + ) + +-------------------------------------------------------------------------------- + +stepGormlak + :: forall entity m. + ( MonadState GameState m, MonadRandom m + , IsCreature entity + ) + => Ticks + -> Positioned entity + -> m (Positioned entity) +stepGormlak ticks pe@(Positioned pos creature) = do + canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision + + let selectDestination pos' creature' = destinationFromPos <$> do + if canSeeCharacter + then do + charPos <- use characterPosition + if isUnit (pos' `diffPositions` charPos) + then attackCharacter $> pos' + else pure $ pos' `stepTowards` charPos + else do + lines <- map (takeWhile (isNothing . entitiesCollision . map snd . snd) + -- the first item on these lines is always the creature itself + . fromMaybe mempty . tailMay) + . linesOfSight pos' (visionRadius creature') + <$> use entities + line <- choose $ weightedBy length lines + pure $ fromMaybe pos' $ fmap fst . headMay =<< line + + pe' <- if canSeeCharacter && not (creature ^. creatureGreeted) + then yellAtCharacter $> (pe & positioned . creatureGreeted .~ True) + else pure pe + + dest <- maybe (selectDestination pos creature) pure + . mfilter (\(Destination p _) -> p /= pos) + $ creature ^. hippocampus . destination + let progress' = + dest ^. destinationProgress + + creature ^. creatureType . Raw.speed . invertedRate |*| ticks + if progress' < 1 + then pure + $ pe' + & positioned . hippocampus . destination + ?~ (dest & destinationProgress .~ progress') + else do + let newPos = dest ^. destinationPosition + remainingSpeed = progress' - 1 + newDest <- selectDestination newPos creature + <&> destinationProgress +~ remainingSpeed + let pe'' = pe' & positioned . hippocampus . destination ?~ newDest + collisionAt newPos >>= \case + Nothing -> pure $ pe'' & position .~ newPos + Just Stop -> pure pe'' + Just Combat -> do + ents <- use $ entities . atPosition newPos + when (any (entityIs @Character) ents) attackCharacter + pure pe' + where + vision = visionRadius creature + attackCharacter = do + dmg <- case creature ^? inventory . wielded . wieldedItems of + Just (WieldedItem item wi) -> do + let msg = fromMaybe + (Messages.lookup ["combat", "creatureAttack", "genericWeapon"]) + $ wi ^. creatureAttackMessage + message msg $ object [ "creature" A..= creature + , "item" A..= item + ] + pure $ wi ^. Raw.damage + Nothing -> do + attack <- choose $ creature ^. creatureType . attacks + attackDescription <- Messages.render (attack ^. Raw.description) + $ object [] + say ["combat", "creatureAttack", "natural"] + $ object [ "creature" A..= creature + , "attackDescription" A..= attackDescription + ] + pure $ attack ^. Raw.damage + + character %= Character.damage dmg + + yellAtCharacter = for_ (creature ^. creatureType . language) + $ \lang -> do + utterance <- fmap (<> "!") . word $ getLanguage lang + creatureSaysText pe utterance + + creatureGreeted :: Lens' entity Bool + creatureGreeted = hippocampus . greetedCharacter + + +-- | A creature sends some text +-- +-- If that creature is visible to the character, its description will be +-- included, otherwise if it's within earshot the character will just hear the +-- sound +creatureSaysText + :: (MonadState GameState m, MonadRandom m, IsCreature entity) + => Positioned entity + -> Text + -> m () +creatureSaysText ent txt = do + let entPos = ent ^. position . _Position . to (fmap fromIntegral) + charPos <- use $ characterPosition . _Position . to (fmap fromIntegral) + let dist :: Int + dist = round $ Metric.distance @_ @Double entPos charPos + audible = dist <= fromIntegral hearingRadius + when audible $ do + visible <- positionIsCharacterVisible $ ent ^. position + let path = ["entities", "say", "creature"] + <> [if visible then "visible" else "invisible"] + params = object [ "creature" A..= (ent ^. positioned) + , "message" A..= txt + ] + say path params + +newtype GormlakBrain entity = GormlakBrain { _unGormlakBrain :: entity } + +instance (IsCreature entity) => Brain (GormlakBrain entity) where + step ticks + = fmap (fmap GormlakBrain) + . stepGormlak ticks + . fmap _unGormlakBrain + entityCanMove = const True + +hippocampus :: HasField "_hippocampus" s t a b => Lens s t a b +hippocampus = field @"_hippocampus" + +creatureType :: HasField "_creatureType" s t a b => Lens s t a b +creatureType = field @"_creatureType" + +inventory :: HasField "_inventory" s t a b => Lens s t a b +inventory = field @"_inventory" + +-------------------------------------------------------------------------------- + +-- instance Brain Creature where +-- step = brainVia GormlakBrain +-- entityCanMove = const True + +-- instance Entity Creature where +-- blocksVision _ = False +-- description = view $ Creature.creatureType . Raw.description +-- entityChar = view $ Creature.creatureType . char diff --git a/users/aspen/xanthous/src/Xanthous/App.hs b/users/aspen/xanthous/src/Xanthous/App.hs new file mode 100644 index 0000000000..426230cdc2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/App.hs @@ -0,0 +1,647 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +{-# OPTIONS_GHC -Wno-deferred-type-errors #-} +module Xanthous.App + ( makeApp + , RunType(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Brick hiding (App, halt, continue, raw) +import qualified Brick +import Graphics.Vty.Attributes (defAttr) +import Graphics.Vty.Input.Events (Event(EvKey)) +import Control.Monad.State (get, gets) +import Control.Monad.State.Class (modify) +import Data.Aeson (object, ToJSON) +import qualified Data.Aeson as A +import qualified Data.Vector as V +import System.Exit +import System.Directory (doesFileExist) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Vector.Lens (toVectorOf) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.App.Time +import Xanthous.App.Prompt +import Xanthous.App.Autocommands +import Xanthous.Command +import Xanthous.Data + ( move + , Dimensions'(Dimensions) + , positioned + , position + , Position + , (|*|) + , Tiles(..), Hitpoints, fromScalar + ) +import Xanthous.Data.App (ResourceName, Panel(..), AppEvent(..)) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Data.Levels (prevLevel, nextLevel) +import qualified Xanthous.Data.Levels as Levels +import Xanthous.Data.Entities (blocksObject) +import Xanthous.Game +import Xanthous.Game.State +import Xanthous.Game.Env +import Xanthous.Game.Draw (drawGame) +import Xanthous.Game.Prompt hiding (Fire) +import qualified Xanthous.Messages as Messages +import Xanthous.Random +import Xanthous.Util (removeVectorIndex, useListOf) +import Xanthous.Util.Inflection (toSentence) +import Xanthous.Physics (throwDistance, bluntThrowDamage) +import Xanthous.Data.EntityMap.Graphics (lineOfSight) +import Xanthous.Data.EntityMap (EntityID) +-------------------------------------------------------------------------------- +import Xanthous.Entities.Common + ( InventoryPosition, describeInventoryPosition, backpack + , wieldableItem, wieldedItems, wielded, itemsWithPosition + , removeItemFromPosition, asWieldedItem + , wieldedItem, items, Hand (..), describeHand, wieldInHand + , WieldedItem, Wielded (..) + ) +import qualified Xanthous.Entities.Character as Character +import Xanthous.Entities.Character hiding (pickUpItem) +import Xanthous.Entities.Item (Item, weight) +import qualified Xanthous.Entities.Item as Item +import Xanthous.Entities.Creature (Creature) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Environment + (Door, open, closed, locked, GroundMessage(..), Staircase(..)) +import Xanthous.Entities.RawTypes + ( edible, eatMessage, hitpointsHealed + , attackMessage + ) +import Xanthous.Generators.Level +import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata +import qualified Xanthous.Generators.Level.Dungeon as Dungeon +-------------------------------------------------------------------------------- + +type App = Brick.App GameState AppEvent ResourceName + +data RunType = NewGame | LoadGame FilePath + deriving stock (Eq) + +makeApp :: GameEnv -> RunType -> IO App +makeApp env rt = pure $ Brick.App + { appDraw = drawGame + , appChooseCursor = const headMay + , appHandleEvent = \game event -> runAppM (handleEvent event) env game + , appStartEvent = case rt of + NewGame -> runAppM (startEvent >> get) env + LoadGame save -> pure . (savefile ?~ save) + , appAttrMap = const $ attrMap defAttr [] + } + +runAppM :: AppM a -> GameEnv -> GameState -> EventM ResourceName a +runAppM appm ge = fmap fst . runAppT appm ge + +startEvent :: AppM () +startEvent = do + initLevel + modify updateCharacterVision + use (character . characterName) >>= \case + Nothing -> prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable + $ \(StringResult s) -> do + character . characterName ?= s + say ["welcome"] =<< use character + Just n -> say ["welcome"] $ object [ "characterName" A..= n ] + +initLevel :: AppM () +initLevel = do + level <- genLevel 0 + entities <>= levelToEntityMap level + characterPosition .= level ^. levelCharacterPosition + +-------------------------------------------------------------------------------- + +handleEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) +handleEvent ev = use promptState >>= \case + NoPrompt -> handleNoPromptEvent ev + WaitingPrompt msg pr -> handlePromptEvent msg pr ev + + +handleNoPromptEvent :: BrickEvent ResourceName AppEvent -> AppM (Next GameState) +handleNoPromptEvent (VtyEvent (EvKey k mods)) + | Just command <- commandFromKey k mods + = do messageHistory %= nextTurn + cancelAutocommand + handleCommand command +handleNoPromptEvent (AppEvent AutoContinue) = do + preuse (autocommand . _ActiveAutocommand . _1) >>= traverse_ autoStep + continue +handleNoPromptEvent _ = continue + +handleCommand :: Command -> AppM (Next GameState) +handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue + +handleCommand Help = showPanel HelpPanel >> continue + +handleCommand (Move dir) = do + newPos <- uses characterPosition $ move dir + collisionAt newPos >>= \case + Nothing -> do + characterPosition .= newPos + stepGameBy =<< uses (character . speed) (|*| Tiles 1) + describeEntitiesAt newPos + Just Combat -> attackAt newPos + Just Stop -> pure () + continue + +handleCommand PickUp = do + pos <- use characterPosition + uses entities (entitiesAtPositionWithType @Item pos) >>= \case + [] -> say_ ["pickUp", "nothingToPickUp"] + [item] -> pickUpItem item + items' -> + menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items') + $ \(MenuResult item) -> pickUpItem item + continue + where + pickUpItem (itemID, item) = do + character %= Character.pickUpItem item + entities . at itemID .= Nothing + say ["pickUp", "pickUp"] $ object [ "item" A..= item ] + stepGameBy 100 -- TODO + +handleCommand Drop = do + takeItemFromInventory_ ["drop", "menu"] Cancellable id + (say_ ["drop", "nothing"]) + $ \(MenuResult item) -> do + entitiesAtCharacter %= (SomeEntity item <|) + say ["drop", "dropped"] $ object [ "item" A..= item ] + continue + +handleCommand PreviousMessage = do + messageHistory %= previousMessage + continue + +handleCommand Open = do + prompt_ @'DirectionPrompt ["open", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- move dir <$> use characterPosition + doors <- uses entities $ entitiesAtPositionWithType @Door pos + if | null doors -> say_ ["open", "nothingToOpen"] + | any (view $ _2 . locked) doors -> say_ ["open", "locked"] + | all (view $ _2 . open) doors -> say_ ["open", "alreadyOpen"] + | otherwise -> do + for_ doors $ \(eid, _) -> + entities . ix eid . positioned . _SomeEntity . open .= True + say_ ["open", "success"] + pure () + stepGame -- TODO + continue + +handleCommand Close = do + prompt_ @'DirectionPrompt ["close", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- move dir <$> use characterPosition + (nonDoors, doors) <- uses entities + $ partitionEithers + . toList + . map ( (matching . aside $ _SomeEntity @Door) + . over _2 (view positioned) + ) + . EntityMap.atPositionWithIDs pos + if | null doors -> say_ ["close", "nothingToClose"] + | all (view $ _2 . closed) doors -> say_ ["close", "alreadyClosed"] + | any (view blocksObject . entityAttributes . snd) nonDoors -> + say ["close", "blocked"] + $ object [ "entityDescriptions" + A..= ( toSentence + . map description + . filter (view blocksObject . entityAttributes) + . map snd + ) nonDoors + , "blockOrBlocks" + A..= ( if length nonDoors == 1 + then "blocks" + else "block" + :: Text) + ] + | otherwise -> do + for_ doors $ \(eid, _) -> + entities . ix eid . positioned . _SomeEntity . closed .= True + for_ nonDoors $ \(eid, _) -> + entities . ix eid . position %= move dir + say_ ["close", "success"] + pure () + stepGame -- TODO + continue + +handleCommand Look = do + prompt_ @'PointOnMap ["look", "prompt"] Cancellable + $ \(PointOnMapResult pos) -> revealedEntitiesAtPosition pos >>= \case + Empty -> say_ ["look", "nothing"] + ents -> describeEntities ents + continue + +handleCommand Wait = stepGame >> continue + +handleCommand Eat = do + uses (character . inventory . backpack) + (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible)) + >>= \case + Empty -> say_ ["eat", "noFood"] + food -> + let foodMenuItem idx (item, edibleItem) + = ( item ^. Item.itemType . char . char + , MenuOption (description item) (idx, item, edibleItem)) + -- TODO refactor to use entityMenu_ + menuItems = mkMenuItems $ imap foodMenuItem food + in menu_ ["eat", "menuPrompt"] Cancellable menuItems + $ \(MenuResult (idx, item, edibleItem)) -> do + character . inventory . backpack %= removeVectorIndex idx + let msg = fromMaybe (Messages.lookup ["eat", "eat"]) + $ edibleItem ^. eatMessage + character . characterHitpoints' += + edibleItem ^. hitpointsHealed . to fromIntegral + message msg $ object ["item" A..= item] + stepGame -- TODO + continue + +handleCommand Read = do + -- TODO allow reading things in the inventory (combo direction+menu prompt?) + prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- uses characterPosition $ move dir + uses entities + (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case + Empty -> say_ ["read", "nothing"] + GroundMessage msg :< Empty -> + say ["read", "result"] $ object ["message" A..= msg] + msgs -> + let readAndContinue Empty = pure () + readAndContinue (msg :< msgs') = + prompt @'Continue + ["read", "result"] + (object ["message" A..= msg]) + Cancellable + . const + $ readAndContinue msgs' + readAndContinue _ = error "this is total" + in readAndContinue msgs + continue + +handleCommand ShowInventory = showPanel InventoryPanel >> continue + +handleCommand DescribeInventory = do + selectItemFromInventory_ ["inventory", "describe", "select"] Cancellable id + (say_ ["inventory", "describe", "nothing"]) + $ \(MenuResult (invPos, item)) -> showPanel . ItemDescriptionPanel + $ Item.fullDescription item + <> "\n\n" <> describeInventoryPosition invPos + continue + + +handleCommand Wield = do + hs <- use $ character . inventory . wielded + selectItem $ \(MenuResult (invPos, (item :: WieldedItem))) -> do + selectHand hs $ \(MenuResult hand) -> do + character . inventory + %= removeItemFromPosition invPos (asWieldedItem # item) + prevItems <- character . inventory . wielded %%= wieldInHand hand item + character . inventory . backpack + <>= fromList (map (view wieldedItem) prevItems) + say ["wield", "wielded"] $ object [ "item" A..= item + , "hand" A..= describeHand hand + ] + continue + where + selectItem = + selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem + (say_ ["wield", "nothing"]) + selectHand hs = menu_ ["wield", "hand"] Cancellable $ handsMenu hs + itemsInHand (Hands i _) LeftHand = toList i + itemsInHand (DoubleHanded _) LeftHand = [] + itemsInHand (Hands _ i) RightHand = toList i + itemsInHand (DoubleHanded _) RightHand = [] + itemsInHand (Hands l r) BothHands = toList l <> toList r + itemsInHand (DoubleHanded i) BothHands = [i] + describeItems [] = "" + describeItems is + = " (currently holding " + <> (intercalate " and" $ map (view $ wieldedItem . to description) is) + <> ")" + handsMenu hs = mapFromList + . map (second $ \hand -> + MenuOption + ( describeHand hand + <> describeItems (itemsInHand hs hand) + ) + hand + ) + $ [ ('l', LeftHand) + , ('r', RightHand) + , ('b', BothHands) + ] + +handleCommand Fire = do + selectItemFromInventory_ ["fire", "menu"] Cancellable id + (say_ ["fire", "nothing"]) + $ \(MenuResult (invPos, item)) -> + let wt = weight item + dist = throwDistance wt + dam = bluntThrowDamage wt + in if dist < fromScalar 1 + then say_ ["fire", "zeroRange"] + else firePrompt_ ["fire", "target"] Cancellable dist $ + \(FireResult targetPos) -> do + charPos <- use characterPosition + mTarget <- uses entities $ firstEnemy . lineOfSight charPos targetPos + case mTarget of + Just target -> do + creature' <- damageCreature target dam + unless (Creature.isDead creature') $ + let msgPath = ["fire", "fired"] <> [if dam == 0 + then "noDamage" + else "someDamage"] + in say msgPath $ object [ "item" A..= item + , "creature" A..= creature' + ] + Nothing -> + say ["fire", "fired", "noTarget"] $ object [ "item" A..= item ] + character . inventory %= removeItemFromPosition invPos item + entities . EntityMap.atPosition targetPos %= (SomeEntity item <|) + stepGame -- TODO(grfn): should this be based on distance? + continue + where + firstEnemy + :: [(Position, Vector (EntityID, SomeEntity))] + -> Maybe (EntityID, Creature) + firstEnemy los = + let enemies = los >>= \(_, es) -> toList $ headMay es + in enemies ^? folded . below _SomeEntity + +handleCommand Save = + view (config . disableSaving) >>= \case + True -> say_ ["save", "disabled"] >> continue + False -> do + -- TODO default save locations / config file? + use savefile >>= \case + Just filepath -> + stringPromptWithDefault_ + ["save", "location"] + Cancellable + (pack filepath) + promptCallback + Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback + continue + where + promptCallback :: PromptResult 'StringPrompt -> AppM () + promptCallback (StringResult filename) = do + sf <- use savefile + exists <- liftIO . doesFileExist $ unpack filename + if exists && sf /= Just (unpack filename) + then confirm ["save", "overwrite"] (object ["filename" A..= filename]) + $ doSave filename + else doSave filename + doSave filename = do + src <- gets saveGame + lift . liftIO $ do + writeFile (unpack filename) $ toStrict src + exitSuccess + +handleCommand GoUp = do + hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity UpStaircase) + if hasStairs + then uses levels prevLevel >>= \case + Just levs' -> do + cEID <- use characterEntityID + pCharacter <- entities . at cEID <<.= Nothing + levels .= levs' + charPos <- use characterPosition + entities . at cEID .= pCharacter + characterPosition .= charPos + Nothing -> + -- TODO in nethack, this leaves the game. Maybe something similar here? + say_ ["cant", "goUp"] + else say_ ["cant", "goUp"] + + continue + +handleCommand GoDown = do + hasStairs <- uses entitiesAtCharacter $ elem (SomeEntity DownStaircase) + + if hasStairs + then do + levs <- use levels + let newLevelNum = Levels.pos levs + 1 + levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs + cEID <- use characterEntityID + pCharacter <- entities . at cEID <<.= Nothing + levels .= levs' + entities . at cEID .= pCharacter + characterPosition .= extract levs' ^. upStaircasePosition + else say_ ["cant", "goDown"] + + continue + +handleCommand (StartAutoMove dir) = do + runAutocommand $ AutoMove dir + continue + +handleCommand Rest = do + say_ ["autocommands", "resting"] + runAutocommand AutoRest + continue + +-- + +handleCommand ToggleRevealAll = do + val <- debugState . allRevealed <%= not + say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ] + continue + +-------------------------------------------------------------------------------- +attackAt :: Position -> AppM () +attackAt pos = + uses entities (entitiesAtPositionWithType @Creature pos) >>= \case + Empty -> say_ ["combat", "nothingToAttack"] + (creature :< Empty) -> attackCreature creature + creatures -> + menu_ ["combat", "menu"] Cancellable (entityMenu_ creatures) + $ \(MenuResult creature) -> attackCreature creature + where + attackCreature creature = do + charDamage <- uses character characterDamage + creature' <- damageCreature creature charDamage + unless (Creature.isDead creature') $ writeAttackMessage creature' + whenM (uses character $ isNothing . weapon) handleFists + stepGame + weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem + writeAttackMessage creature = do + let params = object ["creature" A..= creature] + attackMessages <- uses character getAttackMessages + msg <- intercalate " and " <$> for attackMessages (`Messages.render` params) + writeMessage $ "You " <> msg + getAttackMessages chr = + case chr ^.. inventory . wielded . wieldedItems . wieldableItem of + [] -> [Messages.lookup ["combat", "hit", "fists"]] + is -> + is + <&> \wi -> + fromMaybe (Messages.lookup ["combat", "hit", "generic"]) + $ wi ^. attackMessage + + + handleFists = do + damageChance <- use $ character . body . knuckles . to fistDamageChance + whenM (chance damageChance) $ do + damageAmount <- use $ character . body . knuckles . to fistfightingDamage + say_ [ "combat" , if damageAmount > 1 + then "fistExtraSelfDamage" + else "fistSelfDamage" ] + character %= Character.damage damageAmount + character . body . knuckles %= damageKnuckles + +damageCreature :: (EntityID, Creature) -> Hitpoints -> AppM Creature +damageCreature (creatureID, creature) dam = do + let creature' = Creature.damage dam creature + msgParams = object ["creature" A..= creature'] + if Creature.isDead creature' + then do + say ["combat", "killed"] msgParams + floorItems <- useListOf + $ entities + . ix creatureID + . positioned + . _SomeEntity @Creature + . inventory + . items + mCreaturePos <- preuse $ entities . ix creatureID . position + entities . at creatureID .= Nothing + for_ mCreaturePos $ \creaturePos -> + entities . EntityMap.atPosition creaturePos + %= (<> fromList (SomeEntity <$> floorItems)) + else entities . ix creatureID . positioned .= SomeEntity creature' + pure creature' + + +entityMenu_ + :: (Comonad w, Entity entity) + => [w entity] + -> Map Char (MenuOption (w entity)) +entityMenu_ = mkMenuItems @[_] . map entityMenuItem + where + entityMenuItem wentity + = let entity = extract wentity + in (entityMenuChar entity, MenuOption (description entity) wentity) + + +entityMenuChar :: Entity a => a -> Char +entityMenuChar entity + = let ec = entityChar entity ^. char + in if ec `elem` (['a'..'z'] ++ ['A'..'Z']) + then ec + else 'a' + +-- | Prompt with an item to select out of the inventory and call callback with +-- it +selectItemFromInventory + :: forall item params. + (ToJSON params) + => [Text] -- ^ Menu message + -> params -- ^ Menu message params + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu (InventoryPosition, item)) -> AppM ()) + -> AppM () +selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do + uses (character . inventory) + (V.mapMaybe (_2 $ preview extraInfo) . toVectorOf itemsWithPosition) + >>= \case + Empty -> onEmpty + items' -> menu msgPath msgParams cancellable (itemMenu items') cb + where + itemMenu = mkMenuItems . map itemMenuItem + itemMenuItem (invPos, extraInfoItem) = + let item = extraInfo # extraInfoItem + in ( entityMenuChar item + , MenuOption + (description item <> " (" <> describeInventoryPosition invPos <> ")") + (invPos, extraInfoItem) + ) + +-- | Prompt with an item to select out of the inventory and call callback with +-- it +selectItemFromInventory_ + :: forall item. + [Text] -- ^ Menu message + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu (InventoryPosition, item)) -> AppM ()) + -> AppM () +selectItemFromInventory_ msgPath = selectItemFromInventory msgPath () + +-- | Prompt with an item to select out of the inventory, remove it from the +-- inventory, and call callback with it +takeItemFromInventory + :: forall item params. + (ToJSON params) + => [Text] -- ^ Menu message + -> params -- ^ Menu message params + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu item) -> AppM ()) + -> AppM () +takeItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = + selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty + $ \(MenuResult (invPos, item)) -> do + character . inventory + %= removeItemFromPosition invPos (item ^. re extraInfo) + cb $ MenuResult item + +takeItemFromInventory_ + :: forall item. + [Text] -- ^ Menu message + -> PromptCancellable -- ^ Is the menu cancellable? + -> Prism' Item item -- ^ Attach some extra information to the item, in a + -- recoverable fashion. Prism vs iso so we can discard + -- items. + -> AppM () -- ^ Action to take if there are no items matching + -> (PromptResult ('Menu item) -> AppM ()) + -> AppM () +takeItemFromInventory_ msgPath = takeItemFromInventory msgPath () + +-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) +-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity + +showPanel :: Panel -> AppM () +showPanel panel = do + activePanel ?= panel + prompt_ @'Continue ["generic", "continue"] Uncancellable + . const + $ activePanel .= Nothing + +-------------------------------------------------------------------------------- + +genLevel + :: Word -- ^ Level number, starting at 0 + -> AppM Level +genLevel num = do + let dims = Dimensions 80 80 + generator <- choose $ CaveAutomata :| [Dungeon] + let + doGen = case generator of + CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams + Dungeon -> generateLevel SDungeon Dungeon.defaultParams + level <- doGen dims num + pure $!! level + +levelToGameLevel :: Level -> GameLevel +levelToGameLevel level = + let _levelEntities = levelToEntityMap level + _upStaircasePosition = level ^. levelCharacterPosition + _levelRevealedPositions = mempty + in GameLevel {..} diff --git a/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs b/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs new file mode 100644 index 0000000000..5d4db1a474 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/App/Autocommands.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Autocommands + ( runAutocommand + , autoStep + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Control.Concurrent (threadDelay) +import qualified Data.Aeson as A +import Data.Aeson (object) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE +import Control.Monad.State (gets) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.App.Time +import Xanthous.Data +import Xanthous.Data.App +import Xanthous.Entities.Character (speed, isFullyHealed) +import Xanthous.Entities.Creature (Creature, creatureType) +import Xanthous.Entities.RawTypes (hostile) +import Xanthous.Game.State +-------------------------------------------------------------------------------- + +-- | Step the given autocommand forward once +autoStep :: Autocommand -> AppM () +autoStep (AutoMove dir) = do + newPos <- uses characterPosition $ move dir + collisionAt newPos >>= \case + Nothing -> do + characterPosition .= newPos + stepGameBy =<< uses (character . speed) (|*| (1 :: Tiles)) + describeEntitiesAt newPos + cancelIfDanger + Just _ -> cancelAutocommand + +autoStep AutoRest = do + done <- uses character isFullyHealed + if done + then say_ ["autocommands", "doneResting"] >> cancelAutocommand + else stepGame >> cancelIfDanger + +-- | Cancel the autocommand if the character is in danger +cancelIfDanger :: AppM () +cancelIfDanger = do + maybeVisibleEnemies <- nonEmpty <$> enemiesInSight + for_ maybeVisibleEnemies $ \visibleEnemies -> do + say ["autocommands", "enemyInSight"] + $ object [ "firstEntity" A..= NE.head visibleEnemies ] + cancelAutocommand + where + enemiesInSight :: AppM [Creature] + enemiesInSight = do + ents <- gets characterVisibleEntities + pure $ ents + ^.. folded + . _SomeEntity @Creature + . filtered (view $ creatureType . hostile) + +-------------------------------------------------------------------------------- + +autocommandIntervalμs :: Int +autocommandIntervalμs = 1000 * 50 -- 50 ms + +runAutocommand :: Autocommand -> AppM () +runAutocommand ac = do + env <- ask + tid <- liftIO . async $ runReaderT go env + autocommand .= ActiveAutocommand ac tid + where + go = everyμs autocommandIntervalμs $ sendEvent AutoContinue + +-- | Perform 'act' every μs microseconds forever +everyμs :: MonadIO m => Int -> m () -> m () +everyμs μs act = act >> liftIO (threadDelay μs) >> everyμs μs act diff --git a/users/aspen/xanthous/src/Xanthous/App/Common.hs b/users/aspen/xanthous/src/Xanthous/App/Common.hs new file mode 100644 index 0000000000..69ba6f0e05 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/App/Common.hs @@ -0,0 +1,67 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Common + ( describeEntities + , describeEntitiesAt + , entitiesAtPositionWithType + + -- * Re-exports + , MonadState + , MonadRandom + , EntityMap + , module Xanthous.Game.Lenses + , module Xanthous.Monad + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson (object) +import qualified Data.Aeson as A +import Control.Monad.State (MonadState) +import Control.Monad.Random (MonadRandom) +-------------------------------------------------------------------------------- +import Xanthous.Data (Position, positioned) +import Xanthous.Data.EntityMap (EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Game +import Xanthous.Game.Lenses +import Xanthous.Game.State +import Xanthous.Monad +import Xanthous.Entities.Character (Character) +import Xanthous.Util.Inflection (toSentence) +-------------------------------------------------------------------------------- + +entitiesAtPositionWithType + :: forall a. (Entity a, Typeable a) + => Position + -> EntityMap SomeEntity + -> [(EntityMap.EntityID, a)] +entitiesAtPositionWithType pos em = + let someEnts = EntityMap.atPositionWithIDs pos em + in flip foldMap someEnts $ \(eid, view positioned -> se) -> + case downcastEntity @a se of + Just e -> [(eid, e)] + Nothing -> [] + +describeEntitiesAt :: (MonadState GameState m, MonadRandom m) => Position -> m () +describeEntitiesAt pos = + use ( entities + . EntityMap.atPosition pos + . to (filter (not . entityIs @Character)) + ) >>= \case + Empty -> pure () + ents -> describeEntities ents + +describeEntities + :: ( Entity entity + , MonadRandom m + , MonadState GameState m + , MonoFoldable (f Text) + , Functor f + , Element (f Text) ~ Text + ) + => f entity + -> m () +describeEntities ents = + let descriptions = description <$> ents + in say ["entities", "description"] + $ object ["entityDescriptions" A..= toSentence descriptions] diff --git a/users/aspen/xanthous/src/Xanthous/App/Prompt.hs b/users/aspen/xanthous/src/Xanthous/App/Prompt.hs new file mode 100644 index 0000000000..799281a1c2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/App/Prompt.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE UndecidableInstances #-} +-------------------------------------------------------------------------------- +module Xanthous.App.Prompt + ( handlePromptEvent + , clearPrompt + , prompt + , prompt_ + , stringPromptWithDefault + , stringPromptWithDefault_ + , confirm_ + , confirm + , menu + , menu_ + , firePrompt_ + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick (BrickEvent(..), Next) +import Brick.Widgets.Edit (handleEditorEvent) +import Data.Aeson (ToJSON, object) +import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) +-------------------------------------------------------------------------------- +import Xanthous.App.Common +import Xanthous.Data (move, Tiles, Position, positioned, _Position) +import qualified Xanthous.Data as Data +import Xanthous.Command (directionFromChar) +import Xanthous.Data.App (ResourceName, AppEvent) +import Xanthous.Game.Prompt +import Xanthous.Game.State +import qualified Xanthous.Messages as Messages +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Creature (creatureType, Creature) +import Xanthous.Entities.RawTypes (hostile) +import qualified Linear.Metric as Metric +-------------------------------------------------------------------------------- + +handlePromptEvent + :: Text -- ^ Prompt message + -> Prompt AppM + -> BrickEvent ResourceName AppEvent + -> AppM (Next GameState) + +handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) + = clearPrompt >> continue +handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) + = clearPrompt >> submitPrompt pr >> continue + +handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') [])) + = clearPrompt >> submitPrompt pr >> continue + +handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') [])) + = clearPrompt >> continue + +handlePromptEvent + msg + (Prompt c SStringPrompt (StringPromptState edit) pri cb) + (VtyEvent ev) + = do + edit' <- lift $ handleEditorEvent ev edit + let prompt' = Prompt c SStringPrompt (StringPromptState edit') pri cb + promptState .= WaitingPrompt msg prompt' + continue + +handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = clearPrompt >> cb (DirectionResult dir) >> continue +handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue + +handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) + | Just (MenuOption _ res) <- items' ^. at chr + = clearPrompt >> cb (MenuResult res) >> continue + | otherwise + = continue + +handlePromptEvent + msg + (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = let pos' = move dir pos + prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb + in promptState .= WaitingPrompt msg prompt' + >> continue +handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue + +handlePromptEvent + msg + (Prompt c SFire (FirePromptState pos) pri@(origin, range) cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = do + let pos' = move dir pos + prompt' = Prompt c SFire (FirePromptState pos') pri cb + when (Data.distance origin pos' <= range) $ + promptState .= WaitingPrompt msg prompt' + continue + +handlePromptEvent + _ + (Prompt Cancellable _ _ _ _) + (VtyEvent (EvKey (KChar 'q') [])) + = clearPrompt >> continue +handlePromptEvent _ _ _ = continue + +clearPrompt :: AppM () +clearPrompt = promptState .= NoPrompt + +type PromptParams :: PromptType -> Type +type family PromptParams pt where + PromptParams ('Menu a) = Map Char (MenuOption a) -- Menu items + PromptParams 'Fire = Tiles -- Range + PromptParams _ = () + +prompt + :: forall (pt :: PromptType) (params :: Type). + (ToJSON params, SingPromptType pt, PromptParams pt ~ ()) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +prompt msgPath params cancellable cb = do + let pt = singPromptType @pt + msg <- Messages.message msgPath params + mp :: Maybe (Prompt AppM) <- case pt of + SPointOnMap -> do + charPos <- use characterPosition + pure . Just $ mkPointOnMapPrompt cancellable charPos cb + SStringPrompt -> pure . Just $ mkStringPrompt cancellable cb + SConfirm -> pure . Just $ mkPrompt cancellable pt cb + SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb + SContinue -> pure . Just $ mkPrompt cancellable pt cb + for_ mp $ \p -> promptState .= WaitingPrompt msg p + +prompt_ + :: forall (pt :: PromptType). + (SingPromptType pt, PromptParams pt ~ ()) + => [Text] -- ^ Message key + -> PromptCancellable + -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +prompt_ msg = prompt msg $ object [] + +stringPromptWithDefault + :: forall (params :: Type). (ToJSON params) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> Text -- ^ Prompt default + -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +stringPromptWithDefault msgPath params cancellable def cb = do + msg <- Messages.message msgPath params + let p = mkStringPromptWithDefault cancellable def cb + promptState .= WaitingPrompt msg p + +stringPromptWithDefault_ + :: [Text] -- ^ Message key + -> PromptCancellable + -> Text -- ^ Prompt default + -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler + -> AppM () +stringPromptWithDefault_ msg = stringPromptWithDefault msg $ object [] + +confirm + :: ToJSON params + => [Text] -- ^ Message key + -> params + -> AppM () + -> AppM () +confirm msgPath params + = prompt @'Confirm msgPath params Cancellable . const + +confirm_ :: [Text] -> AppM () -> AppM () +confirm_ msgPath = confirm msgPath $ object [] + +menu :: forall (a :: Type) (params :: Type). + (ToJSON params) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler + -> AppM () +menu msgPath params cancellable items' cb = do + msg <- Messages.message msgPath params + let p = mkMenu cancellable items' cb + promptState .= WaitingPrompt msg p + +menu_ :: forall (a :: Type). + [Text] -- ^ Message key + -> PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler + -> AppM () +menu_ msgPath = menu msgPath $ object [] + +firePrompt_ + :: [Text] -- ^ Message key + -> PromptCancellable + -> Tiles -- ^ Range + -> (PromptResult 'Fire -> AppM ()) -- ^ Promise handler + -> AppM () +firePrompt_ msgPath cancellable range cb = do + msg <- Messages.message msgPath $ object [] + initialPos <- maybe (use characterPosition) pure =<< nearestEnemyPosition + let p = mkFirePrompt cancellable initialPos range cb + promptState .= WaitingPrompt msg p + +-- | Returns the position of the nearest visible hostile creature, if any +nearestEnemyPosition :: AppM (Maybe Position) +nearestEnemyPosition = do + charPos <- use characterPosition + em <- use entities + ps <- characterVisiblePositions + let candidates = toList ps >>= \p -> + let ents = EntityMap.atPositionWithIDs p em + in ents + ^.. folded + . _2 + . positioned + . _SomeEntity @Creature + . creatureType + . filtered (view hostile) + . to (const (distance charPos p, p)) + pure . headMay . fmap snd $ sortOn fst candidates + where + distance :: Position -> Position -> Double + distance = Metric.distance `on` (fmap fromIntegral . view _Position) diff --git a/users/aspen/xanthous/src/Xanthous/App/Time.hs b/users/aspen/xanthous/src/Xanthous/App/Time.hs new file mode 100644 index 0000000000..cca352858d --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/App/Time.hs @@ -0,0 +1,42 @@ +-------------------------------------------------------------------------------- +module Xanthous.App.Time + ( stepGame + , stepGameBy + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import System.Exit +-------------------------------------------------------------------------------- +import Xanthous.Data (Ticks) +import Xanthous.App.Prompt +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Character (isDead) +import Xanthous.Game.State +import Xanthous.Game.Prompt +import Xanthous.Game.Lenses +import Control.Monad.State (modify) +import qualified Xanthous.Game.Memo as Memo +-------------------------------------------------------------------------------- + + +stepGameBy :: Ticks -> AppM () +stepGameBy ticks = do + ents <- uses entities EntityMap.toEIDsAndPositioned + for_ ents $ \(eid, pEntity) -> do + pEntity' <- step ticks pEntity + entities . ix eid .= pEntity' + + clearMemo Memo.characterVisiblePositions + modify updateCharacterVision + + whenM (uses character isDead) + . prompt_ @'Continue ["dead"] Uncancellable + . const . lift . liftIO + $ exitSuccess + +ticksPerTurn :: Ticks +ticksPerTurn = 100 + +stepGame :: AppM () +stepGame = stepGameBy ticksPerTurn diff --git a/users/aspen/xanthous/src/Xanthous/Command.hs b/users/aspen/xanthous/src/Xanthous/Command.hs new file mode 100644 index 0000000000..6e6274a02c --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Command.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Command + ( -- * Commands + Command(..) + , commandIsHidden + -- * Keybindings + , Keybinding(..) + , keybindings + , commands + , commandFromKey + , directionFromChar + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Left, Right, Down, try) +-------------------------------------------------------------------------------- +import Graphics.Vty.Input (Key(..), Modifier(..)) +import qualified Data.Char as Char +import Data.Aeson (FromJSON (parseJSON), FromJSONKey, FromJSONKeyFunction (FromJSONKeyTextParser)) +import qualified Data.Aeson as A +import Data.Aeson.Generic.DerivingVia +import Text.Megaparsec (Parsec, errorBundlePretty, parse, eof, try) +import Text.Megaparsec.Char (string', char', printChar) +import Data.FileEmbed (embedFile) +import qualified Data.Yaml as Yaml +import Test.QuickCheck.Arbitrary +import Data.Aeson.Types (Parser) +-------------------------------------------------------------------------------- +import Xanthous.Data (Direction(..)) +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +-------------------------------------------------------------------------------- + +data Command + = Quit + | Help + | Move !Direction + | StartAutoMove !Direction + | PreviousMessage + | PickUp + | Drop + | Open + | Close + | Wait + | Eat + | Look + | Save + | Read + | ShowInventory + | DescribeInventory + | Wield + | Fire + | GoUp + | GoDown + | Rest + + -- | TODO replace with `:` commands + | ToggleRevealAll + deriving stock (Show, Eq, Generic) + deriving anyclass (Hashable, NFData) + deriving Arbitrary via GenericArbitrary Command + deriving (FromJSON) + via WithOptions '[ SumEnc UntaggedVal ] + Command + +-- | Should the command be hidden from the help menu? +-- +-- Note that this is true for both debug commands and movement commands, as the +-- latter is documented non-automatically +commandIsHidden :: Command -> Bool +commandIsHidden (Move _) = True +commandIsHidden (StartAutoMove _) = True +commandIsHidden ToggleRevealAll = True +commandIsHidden _ = False + +-------------------------------------------------------------------------------- + +data Keybinding = Keybinding !Key ![Modifier] + deriving stock (Show, Eq, Generic) + deriving anyclass (Hashable, NFData) + +parseKeybindingFromText :: Text -> Parser Keybinding +parseKeybindingFromText + = either (fail . errorBundlePretty) pure + . parse keybinding "<JSON>" + where + key :: Parsec Void Text Key + key = KUp <$ string' "<up>" + <|> KDown <$ string' "<down>" + <|> KLeft <$ string' "<left>" + <|> KRight <$ string' "<right>" + <|> KChar <$> printChar + + modifier :: Parsec Void Text Modifier + modifier = modf <* char' '-' + where + modf = MAlt <$ char' 'a' + <|> MMeta <$ char' 'm' + <|> MCtrl <$ char' 'c' + <|> MShift <$ char' 's' + + keybinding :: Parsec Void Text Keybinding + keybinding = do + mods <- many (try modifier) + k <- key + eof + pure $ Keybinding k mods + +instance FromJSON Keybinding where + parseJSON = A.withText "Keybinding" parseKeybindingFromText + +instance FromJSONKey Keybinding where + fromJSONKey = FromJSONKeyTextParser parseKeybindingFromText + +rawKeybindings :: ByteString +rawKeybindings = $(embedFile "src/Xanthous/keybindings.yaml") + +keybindings :: HashMap Keybinding Command +keybindings = either (error . Yaml.prettyPrintParseException) id + $ Yaml.decodeEither' rawKeybindings + +commands :: HashMap Command Keybinding +commands = mapFromList . map swap . itoList $ keybindings + +commandFromKey :: Key -> [Modifier] -> Maybe Command +commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir +commandFromKey (KChar c) [] + | Char.isUpper c + , Just dir <- directionFromChar $ Char.toLower c + = Just $ StartAutoMove dir +commandFromKey k mods = keybindings ^. at keybinding + where keybinding = Keybinding k mods + +-------------------------------------------------------------------------------- + +directionFromChar :: Char -> Maybe Direction +directionFromChar 'h' = Just Left +directionFromChar 'j' = Just Down +directionFromChar 'k' = Just Up +directionFromChar 'l' = Just Right +directionFromChar 'y' = Just UpLeft +directionFromChar 'u' = Just UpRight +directionFromChar 'b' = Just DownLeft +directionFromChar 'n' = Just DownRight +directionFromChar '.' = Just Here +directionFromChar _ = Nothing diff --git a/users/aspen/xanthous/src/Xanthous/Data.hs b/users/aspen/xanthous/src/Xanthous/Data.hs new file mode 100644 index 0000000000..703955206a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Data.hs @@ -0,0 +1,822 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoTypeSynonymInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +-- | Common data types for Xanthous ------------------------------------------------------------------------------ +module Xanthous.Data + ( Opposite(..) + + -- * + , Position'(..) + , Position + , x + , y + + -- ** + , Positioned(..) + , _Positioned + , position + , positioned + , loc + , _Position + , positionFromPair + , positionFromV2 + , addPositions + , diffPositions + , stepTowards + , isUnit + , distance + + -- * Boxes + , Box(..) + , topLeftCorner + , bottomRightCorner + , setBottomRightCorner + , dimensions + , inBox + , boxIntersects + , boxCenter + , boxEdge + , module Linear.V2 + + -- * Unit math + , Scalar(..) + , Per(..) + , invertRate + , invertedRate + , (|+|) + , (|*|) + , (|/|) + , (:+:) + , (:*:) + , (:/:) + , (:**:)(..) + , Ticks(..) + , Tiles(..) + , TicksPerTile + , TilesPerTick + , timesTiles + , Square(..) + , squared + , Cubic(..) + , Grams + , Meters + , Uno(..) + , Unit(..) + , UnitSymbol(..) + + -- * + , Dimensions'(..) + , Dimensions + , HasWidth(..) + , HasHeight(..) + + -- * + , Direction(..) + , move + , asPosition + , directionOf + , Cardinal(..) + + -- * + , Corner(..) + , Edge(..) + , cornerEdges + + -- * + , Neighbors(..) + , edges + , neighborDirections + , neighborPositions + , neighborCells + , arrayNeighbors + , rotations + , HasTopLeft(..) + , HasTop(..) + , HasTopRight(..) + , HasLeft(..) + , HasRight(..) + , HasBottomLeft(..) + , HasBottom(..) + , HasBottomRight(..) + + -- * + , Hitpoints(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements) +-------------------------------------------------------------------------------- +import Linear.V2 hiding (_x, _y) +import qualified Linear.V2 as L +import Linear.V4 hiding (_x, _y) +import Test.QuickCheck (CoArbitrary, Function, elements) +import Test.QuickCheck.Arbitrary.Generic +import Data.Group +import Brick (Location(Location), Edges(..)) +import Data.Monoid (Product(..), Sum(..)) +import Data.Array.IArray +import Data.Aeson.Generic.DerivingVia +import Data.Aeson + ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) +import Data.Random (Distribution) +import Data.Coerce +import Data.Proxy (Proxy(Proxy)) +-------------------------------------------------------------------------------- +import Xanthous.Util (EqEqProp(..), EqProp, between) +import Xanthous.Orphans () +import Xanthous.Util.Graphics +import qualified Linear.Metric as Metric +-------------------------------------------------------------------------------- + +-- | opposite ∘ opposite ≡ id +class Opposite x where + opposite :: x -> x + +-------------------------------------------------------------------------------- + +-- fromScalar ∘ scalar ≡ id +class Scalar a where + scalar :: a -> Double + fromScalar :: Double -> a + +instance Scalar Double where + scalar = id + fromScalar = id + +newtype ScalarIntegral a = ScalarIntegral a + deriving newtype (Eq, Ord, Num, Enum, Real, Integral) +instance Integral a => Scalar (ScalarIntegral a) where + scalar = fromIntegral + fromScalar = floor + +deriving via (ScalarIntegral Integer) instance Scalar Integer +deriving via (ScalarIntegral Word) instance Scalar Word + +-- | Units of measure +class Unit a where + unitSuffix :: Text +type UnitSymbol :: Symbol -> Type -> Type +newtype UnitSymbol suffix a = UnitSymbol a +instance KnownSymbol suffix => Unit (UnitSymbol suffix a) where + unitSuffix = pack $ symbolVal @suffix Proxy + +newtype ShowUnitSuffix a b = ShowUnitSuffix a +instance (Show b, Unit a, Coercible a b) => Show (ShowUnitSuffix a b) where + show a = show (coerce @_ @b a) <> " " <> unpack (unitSuffix @a) + +-------------------------------------------------------------------------------- + +data Position' a where + Position :: { _x :: a + , _y :: a + } -> (Position' a) + deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable) + deriving anyclass (NFData, Hashable, CoArbitrary, Function) + deriving EqProp via EqEqProp (Position' a) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + (Position' a) + +x, y :: Lens' (Position' a) a +x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy) +y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy) + +type Position = Position' Int + +instance (Arbitrary a) => Arbitrary (Position' a) where + arbitrary = genericArbitrary + shrink (Position px py) = Position <$> shrink px <*> shrink py + + +instance Num a => Semigroup (Position' a) where + (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) + +instance Num a => Monoid (Position' a) where + mempty = Position 0 0 + +instance Num a => Group (Position' a) where + invert (Position px py) = Position (negate px) (negate py) + +-- | Positions convert to scalars by discarding their orientation and just +-- measuring the length from the origin +instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where + scalar = fromIntegral . length . line 0 . view _Position + fromScalar n = Position (fromScalar n) (fromScalar n) + +data Positioned a where + Positioned :: Position -> a -> Positioned a + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function) +type role Positioned representational + +_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 + +instance ToJSON a => ToJSON (Positioned a) where + toJSON (Positioned pos val) = object + [ "position" .= pos + , "data" .= val + ] + +instance FromJSON a => FromJSON (Positioned a) where + parseJSON = withObject "Positioned" $ \obj -> + Positioned <$> obj .: "position" <*> obj .: "data" + +position :: Lens' (Positioned a) Position +position = lens + (\(Positioned pos _) -> pos) + (\(Positioned _ a) pos -> Positioned pos a) + +positioned :: Lens (Positioned a) (Positioned b) a b +positioned = lens + (\(Positioned _ x') -> x') + (\(Positioned pos _) x' -> Positioned pos x') + +loc :: Iso' Position Location +loc = iso hither yon + where + hither (Position px py) = Location (px, py) + yon (Location (lx, ly)) = Position lx ly + +_Position :: Iso' (Position' a) (V2 a) +_Position = iso hither yon + where + hither (Position px py) = V2 px py + yon (V2 lx ly) = Position lx ly + +positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a +positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) + +positionFromV2 :: (Num a, Integral i) => V2 i -> Position' a +positionFromV2 (V2 xx yy) = Position (fromIntegral xx) (fromIntegral yy) + +-- | Add two positions +-- +-- Operation for the additive group on positions +addPositions :: Num a => Position' a -> Position' a -> Position' a +addPositions = (<>) + +-- | Subtract two positions. +-- +-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) +diffPositions :: Num a => Position' a -> Position' a -> Position' a +diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂) + +-- | Is this position a unit position? or: When taken as a difference, does this +-- position represent a step of one tile? +-- +-- ∀ dir :: Direction. isUnit ('asPosition' dir) +isUnit :: (Eq a, Num a) => Position' a -> Bool +isUnit (Position px py) = + abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0) + +-------------------------------------------------------------------------------- + +data Dimensions' a = Dimensions + { _width :: a + , _height :: a + } + deriving stock (Show, Eq, Functor, Generic) + deriving anyclass (CoArbitrary, Function) +makeFieldsNoPrefix ''Dimensions' + +instance Arbitrary a => Arbitrary (Dimensions' a) where + arbitrary = Dimensions <$> arbitrary <*> arbitrary + +type Dimensions = Dimensions' Word + +-------------------------------------------------------------------------------- + +data Direction where + Up :: Direction + Down :: Direction + Left :: Direction + Right :: Direction + UpLeft :: Direction + UpRight :: Direction + DownLeft :: Direction + DownRight :: Direction + Here :: Direction + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable) + +deriving via (GenericArbitrary Direction) instance Arbitrary Direction + +instance Opposite Direction where + opposite Up = Down + opposite Down = Up + opposite Left = Right + opposite Right = Left + opposite UpLeft = DownRight + opposite UpRight = DownLeft + opposite DownLeft = UpRight + opposite DownRight = UpLeft + opposite Here = Here + +move :: Num a => Direction -> Position' a -> Position' a +move Up = y -~ 1 +move Down = y +~ 1 +move Left = x -~ 1 +move Right = x +~ 1 +move UpLeft = move Up . move Left +move UpRight = move Up . move Right +move DownLeft = move Down . move Left +move DownRight = move Down . move Right +move Here = id + +asPosition :: Direction -> Position +asPosition dir = move dir mempty + +-- | Returns the direction that a given position is from a given source position +directionOf + :: Position -- ^ Source + -> Position -- ^ Target + -> Direction +directionOf (Position x₁ y₁) (Position x₂ y₂) = + case (x₁ `compare` x₂, y₁ `compare` y₂) of + (EQ, EQ) -> Here + (EQ, LT) -> Down + (EQ, GT) -> Up + (LT, EQ) -> Right + (GT, EQ) -> Left + + (LT, LT) -> DownRight + (GT, LT) -> DownLeft + + (LT, GT) -> UpRight + (GT, GT) -> UpLeft + +-- | Take one (potentially diagonal) step towards the given position +-- +-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`)) +stepTowards + :: Position -- ^ Source + -> Position -- ^ Target + -> Position +stepTowards (view _Position -> p₁) (view _Position -> p₂) + | p₁ == p₂ = _Position # p₁ + | otherwise = + let (_:p:_) = line p₁ p₂ + in _Position # p + +-- | Newtype controlling arbitrary generation to only include cardinal +-- directions ('Up', 'Down', 'Left', 'Right') +newtype Cardinal = Cardinal { getCardinal :: Direction } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, Function, CoArbitrary) + deriving newtype (Opposite) + +instance Arbitrary Cardinal where + arbitrary = Cardinal <$> elements [Up, Down, Left, Right] + +-------------------------------------------------------------------------------- + +data Corner + = TopLeft + | TopRight + | BottomLeft + | BottomRight + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving Arbitrary via GenericArbitrary Corner + +instance Opposite Corner where + opposite TopLeft = BottomRight + opposite TopRight = BottomLeft + opposite BottomLeft = TopRight + opposite BottomRight = TopLeft + +data Edge + = TopEdge + | LeftEdge + | RightEdge + | BottomEdge + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving Arbitrary via GenericArbitrary Edge + +instance Opposite Edge where + opposite TopEdge = BottomEdge + opposite BottomEdge = TopEdge + opposite LeftEdge = RightEdge + opposite RightEdge = LeftEdge + +cornerEdges :: Corner -> (Edge, Edge) +cornerEdges TopLeft = (TopEdge, LeftEdge) +cornerEdges TopRight = (TopEdge, RightEdge) +cornerEdges BottomLeft = (BottomEdge, LeftEdge) +cornerEdges BottomRight = (BottomEdge, RightEdge) + +-------------------------------------------------------------------------------- + +data Neighbors a = Neighbors + { _topLeft + , _top + , _topRight + , _left + , _right + , _bottomLeft + , _bottom + , _bottomRight :: a + } + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function, MonoFoldable) + +deriving via (GenericArbitrary (Neighbors a)) instance (Arbitrary a) => Arbitrary (Neighbors a) + +type instance Element (Neighbors a) = a + +makeFieldsNoPrefix ''Neighbors + +instance Applicative Neighbors where + pure α = Neighbors + { _topLeft = α + , _top = α + , _topRight = α + , _left = α + , _right = α + , _bottomLeft = α + , _bottom = α + , _bottomRight = α + } + nf <*> nx = Neighbors + { _topLeft = nf ^. topLeft $ nx ^. topLeft + , _top = nf ^. top $ nx ^. top + , _topRight = nf ^. topRight $ nx ^. topRight + , _left = nf ^. left $ nx ^. left + , _right = nf ^. right $ nx ^. right + , _bottomLeft = nf ^. bottomLeft $ nx ^. bottomLeft + , _bottom = nf ^. bottom $ nx ^. bottom + , _bottomRight = nf ^. bottomRight $ nx ^. bottomRight + } + +edges :: Neighbors a -> Edges a +edges neighs = Edges + { eTop = neighs ^. top + , eBottom = neighs ^. bottom + , eLeft = neighs ^. left + , eRight = neighs ^. right + } + +neighborDirections :: Neighbors Direction +neighborDirections = Neighbors + { _topLeft = UpLeft + , _top = Up + , _topRight = UpRight + , _left = Left + , _right = Right + , _bottomLeft = DownLeft + , _bottom = Down + , _bottomRight = DownRight + } + +neighborPositions :: Num a => Position' a -> Neighbors (Position' a) +neighborPositions pos = (`move` pos) <$> neighborDirections + +neighborCells :: Num a => V2 a -> Neighbors (V2 a) +neighborCells = map (view _Position) . neighborPositions . review _Position + +arrayNeighbors + :: (IArray a e, Ix i, Num i) + => a (V2 i) e + -> V2 i + -> Neighbors (Maybe e) +arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center) + where + arrLookup (view _Position -> pos) + | inRange (bounds arr) pos = Just $ arr ! pos + | otherwise = Nothing + +-- | Returns a list of all 4 90-degree rotations of the given neighbors +rotations :: Neighbors a -> V4 (Neighbors a) +rotations orig@(Neighbors tl t tr l r bl b br) = V4 + orig -- tl t tr + -- l r + -- bl b br + + (Neighbors bl l tl b t br r tr) -- bl l tl + -- b t + -- br r tr + + (Neighbors br b bl r l tr t tl) -- br b bl + -- r l + -- tr t tl + + (Neighbors tr r br t b tl l bl) -- tr r br + -- t b + -- tl l bl + +-------------------------------------------------------------------------------- + +newtype Per a b = Rate Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) + via Double + deriving (Semigroup, Monoid) via Product Double + deriving Show via ShowUnitSuffix (Per a b) Double +deriving via Double + instance ( Distribution d Double + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (Per a b) + +instance (Unit a, Unit b) => Unit (a `Per` b) where + unitSuffix = unitSuffix @a <> "/" <> unitSuffix @b + +invertRate :: a `Per` b -> b `Per` a +invertRate (Rate p) = Rate $ 1 / p + +invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b') +invertedRate = iso invertRate invertRate + +type (:+:) :: Type -> Type -> Type +type family (:+:) a b where + a :+: a = a + a :+: (Uno b) = a + +infixl 6 |+| +class AddUnit a b where + (|+|) :: a -> b -> a :+: b + +instance Scalar a => AddUnit a a where + x' |+| y' = fromScalar $ scalar x' + scalar y' + +instance (Scalar a, Scalar b) => AddUnit a (Uno b) where + x' |+| y' = fromScalar $ scalar x' + scalar y' + +type (:*:) :: Type -> Type -> Type +type family (:*:) a b where + (a `Per` b) :*: b = a + (Square a) :*: a = Cubic a + a :*: a = Square a + a :*: Uno b = a + a :*: b = a :**: b + +infixl 7 |*| +class MulUnit a b where + (|*|) :: a -> b -> a :*: b + +instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where + (Rate rate) |*| b = fromScalar $ rate * scalar b + +instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where + x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y' + +instance forall a. (Scalar a) => MulUnit (Square a) a where + x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y' + +instance {-# INCOHERENT #-} forall a b. + (Scalar a, Scalar b, Scalar (a :*: Uno b)) + => MulUnit a (Uno b) where + x' |*| y' = fromScalar $ scalar x' * scalar y' + +type (:/:) :: Type -> Type -> Type +type family (:/:) a b where + (Square a) :/: a = a + (Cubic a) :/: a = Square a + (Cubic a) :/: (Square a) = a + (a :**: b) :/: b = a + (a :**: b) :/: a = b + a :/: Uno b = a + a :/: b = a `Per` b + +infixl 7 |/| +class DivUnit a b where + (|/|) :: a -> b -> a :/: b + +instance Scalar a => DivUnit (Square a) a where + (Square a) |/| b = fromScalar $ scalar a / scalar b + +instance Scalar a => DivUnit (Cubic a) a where + (Cubic a) |/| b = fromScalar $ scalar a / scalar b + +instance (Scalar a, Cubic a :/: Square a ~ a) + => DivUnit (Cubic a) (Square a) where + (Cubic a) |/| (Square b) = fromScalar $ scalar a / scalar b + +instance (Scalar a, Scalar b) => DivUnit (a :**: b) b where + (Times a) |/| b = fromScalar $ scalar a / scalar b + +instance (Scalar a, Scalar b) => DivUnit (a :**: b) a where + (Times a) |/| b = fromScalar $ scalar a / scalar b + +instance {-# INCOHERENT #-} forall a b. + (Scalar a, Scalar b, Scalar (a :/: Uno b)) + => DivUnit a (Uno b) where + x' |/| y' = fromScalar $ scalar x' / scalar y' + +-- | Dimensionless quantitites (mass per unit mass, radians, etc) +-- +-- see <https://en.wikipedia.org/wiki/Parts-per_notation#Uno> +newtype Uno a = Uno a + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar, Show + ) + via a + deriving Unit via UnitSymbol "" (Uno a) + +newtype Square a = Square a + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar + ) + via a +deriving via (a :: Type) + instance ( Distribution d a + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (Square a) + +instance Unit a => Unit (Square a) where + unitSuffix = unitSuffix @a <> "²" + +instance Show a => Show (Square a) where + show (Square n) = show n <> "²" + +squared :: (Scalar a, a :*: a ~ Square a) => a -> Square a +squared v = v |*| v + +newtype Cubic a = Cubic a + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar + ) + via a +deriving via (a :: Type) + instance ( Distribution d a + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (Cubic a) + +instance Unit a => Unit (Cubic a) where + unitSuffix = unitSuffix @a <> "³" + +instance Show a => Show (Cubic a) where + show (Cubic n) = show n <> "³" + +newtype (:**:) a b = Times Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) + via Double + deriving (Semigroup, Monoid) via Sum Double + deriving Show via ShowUnitSuffix (a :**: b) Double +deriving via Double + instance ( Distribution d Double + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (a :**: b) + +instance (Unit a, Unit b) => Unit (a :**: b) where + unitSuffix = unitSuffix @a <> " " <> unitSuffix @b + +-------------------------------------------------------------------------------- + +newtype Ticks = Ticks Word + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word + deriving (Semigroup, Monoid) via (Sum Word) + deriving Scalar via ScalarIntegral Ticks + deriving Arbitrary via GenericArbitrary Ticks + deriving Unit via UnitSymbol "ticks" Ticks + deriving Show via ShowUnitSuffix Ticks Word +deriving via Word + instance ( Distribution d Word + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d Ticks + +newtype Tiles = Tiles Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double + deriving (Semigroup, Monoid) via (Sum Double) + deriving Arbitrary via GenericArbitrary Tiles + deriving Unit via UnitSymbol "m" Tiles + deriving Show via ShowUnitSuffix Tiles Double +deriving via Double + instance ( Distribution d Double + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d Tiles + +type TicksPerTile = Ticks `Per` Tiles +type TilesPerTick = Tiles `Per` Ticks + +timesTiles :: TicksPerTile -> Tiles -> Ticks +timesTiles = (|*|) + +-- | Calculate the (cartesian) distance between two 'Position's, floored and +-- represented as a number of 'Tile's +-- +-- Note that this is imprecise, and may be different than the length of a +-- bresenham's line between the points +distance :: Position -> Position -> Tiles +distance + = (fromScalar .) . (Metric.distance `on` (fmap fromIntegral . view _Position)) + +-------------------------------------------------------------------------------- + +newtype Hitpoints = Hitpoints Word + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, Scalar + , ToJSON, FromJSON + ) + via Word + deriving (Semigroup, Monoid) via Sum Word + deriving Unit via UnitSymbol "hp" Hitpoints + deriving Show via ShowUnitSuffix Hitpoints Word + +-------------------------------------------------------------------------------- + +-- | Grams, the fundamental measure of weight in Xanthous. +newtype Grams = Grams Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat + , RealFrac, Scalar, ToJSON, FromJSON + ) + via Double + deriving (Semigroup, Monoid) via Sum Double + deriving Unit via UnitSymbol "g" Grams + deriving Show via ShowUnitSuffix Grams Double + +-- | Every tile is 1 meter +type Meters = Tiles + +-------------------------------------------------------------------------------- + +data Box a = Box + { _topLeftCorner :: V2 a + , _dimensions :: V2 a + } + deriving stock (Show, Eq, Ord, Functor, Generic) +makeFieldsNoPrefix ''Box + +-- It seems to be necessary to have an `Arg (V2 a) a` constraint, as a is passed +-- to V2 internally, in order to make GHC figure out this deriving via correctly. +deriving via (GenericArbitrary (Box a)) instance (Arbitrary a) => Arbitrary (Box a) + +bottomRightCorner :: Num a => Box a -> V2 a +bottomRightCorner box = + V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x) + (box ^. topLeftCorner . L._y + box ^. dimensions . L._y) + +setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a +setBottomRightCorner box br@(V2 brx bry) + | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y + = box & topLeftCorner .~ br + & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx) + & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry) + | otherwise + = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x)) + & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y)) + +inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool +inBox box pt = flip all [L._x, L._y] $ \component -> + between (box ^. topLeftCorner . component) + (box ^. to bottomRightCorner . component) + (pt ^. component) + +boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool +boxIntersects box₁ box₂ + = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂] + +boxCenter :: (Fractional a) => Box a -> V2 a +boxCenter box = V2 cx cy + where + cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2) + cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2) + +boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a] +boxEdge box LeftEdge = + V2 (box ^. topLeftCorner . L._x) + <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y] +boxEdge box RightEdge = + V2 (box ^. to bottomRightCorner . L._x) + <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y] +boxEdge box TopEdge = + flip V2 (box ^. topLeftCorner . L._y) + <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] +boxEdge box BottomEdge = + flip V2 (box ^. to bottomRightCorner . L._y) + <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] diff --git a/users/aspen/xanthous/src/Xanthous/Data/App.hs b/users/aspen/xanthous/src/Xanthous/Data/App.hs new file mode 100644 index 0000000000..13c4b5d610 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Data/App.hs @@ -0,0 +1,47 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.App + ( Panel(..) + , ResourceName(..) + , AppEvent(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Test.QuickCheck.Instances.Text () +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +-- | Enum for "panels" displayed in the game's UI. +data Panel + = -- | A panel providing help with the game's commands + HelpPanel + | -- | A panel displaying the character's inventory + InventoryPanel + | -- | A panel describing an item in the inventory in detail + -- + -- The argument is the full description of the item + ItemDescriptionPanel Text + deriving stock (Show, Eq, Ord, Generic) + 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/aspen/xanthous/src/Xanthous/Data/Entities.hs b/users/aspen/xanthous/src/Xanthous/Data/Entities.hs new file mode 100644 index 0000000000..39953410f2 --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Data/EntityChar.hs b/users/aspen/xanthous/src/Xanthous/Data/EntityChar.hs new file mode 100644 index 0000000000..855a3462da --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Data/EntityMap.hs b/users/aspen/xanthous/src/Xanthous/Data/EntityMap.hs new file mode 100644 index 0000000000..33a98f1ae5 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Data/EntityMap.hs @@ -0,0 +1,276 @@ +{-# 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 + , positionOf + -- , positionedEntities + , neighbors + , Deduplicate(..) + + -- * debug + , byID + , byPosition + , lastID + + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lookup) +import Xanthous.Data + ( Position + , Positioned(..) + , positioned + , Neighbors(..) + , neighborPositions, position + ) +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 + 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 + +-- | Traversal to the position of the entity with the given ID +positionOf :: EntityID -> Traversal' (EntityMap a) Position +positionOf eid = ix eid . position + +-------------------------------------------------------------------------------- +makeWrapped ''Deduplicate diff --git a/users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs new file mode 100644 index 0000000000..1398c611cf --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs @@ -0,0 +1,72 @@ +-------------------------------------------------------------------------------- +module Xanthous.Data.EntityMap.Graphics + ( visiblePositions + , visibleEntities + , lineOfSight + , 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 entities on the *line of sight* from the first position +-- to the second position +lineOfSight + :: forall e. Entity e + => Position -- ^ Origin + -> Position -- ^ Destination + -> EntityMap e + -> [(Position, Vector (EntityID, e))] +lineOfSight (view _Position -> origin) (view _Position -> destination) em = + takeWhileInclusive (none (view blocksVision . entityAttributes . snd) . snd) + $ getPositionedAt <$> line origin destination + where + getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e)) + getPositionedAt (review _Position -> p) = + (p, over _2 (view positioned) <$> atPositionWithIDs p em) + +-- | 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 -- ^ Centerpoint + -> Word -- ^ Radius + -> EntityMap e + -> [[(Position, Vector (EntityID, e))]] +linesOfSight pos visionRadius em = + radius <&> \edge -> lineOfSight pos (_Position # edge) em + where + radius = circle (pos ^. _Position) $ fromIntegral visionRadius + +-- | 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/aspen/xanthous/src/Xanthous/Data/Levels.hs b/users/aspen/xanthous/src/Xanthous/Data/Levels.hs new file mode 100644 index 0000000000..13251d8afd --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Data/Levels.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Data.Levels + ( Levels + , allLevels + , numLevels + , 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) + +type instance Element (Levels a) = a +instance MonoFoldable (Levels a) +instance MonoFunctor (Levels a) +instance MonoTraversable (Levels a) + +instance ComonadStore Word Levels where + pos = toEnum . pos . levelZipper + peek i = peek (fromEnum i) . levelZipper + +instance Traversable Levels where + traverse f (Levels z) = Levels <$> traverse f z + +instance Foldable1 Levels + +instance Traversable1 Levels where + traverse1 f levs@(Levels z) = seek (pos levs) . 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₂ + +-- | The number of levels stored in 'Levels' +-- +-- Equivalent to 'Data.Foldable.length', but likely faster +numLevels :: Levels a -> Word +numLevels = toEnum . size . levelZipper + +-- | 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 + | succ (pos levs) < numLevels 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 :: Word -- ^ 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, pred . toEnum . length $ _levels) + pure AltLevels {..} + shrink als = do + _levels <- shrink $ als ^. levels + _currentLevel <- filter (between 0 $ pred . toEnum . length $ _levels) + $ 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/aspen/xanthous/src/Xanthous/Data/Memo.hs b/users/aspen/xanthous/src/Xanthous/Data/Memo.hs new file mode 100644 index 0000000000..2b2ee0f960 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Data/Memo.hs @@ -0,0 +1,98 @@ +-------------------------------------------------------------------------------- +-- | Memoized values +-------------------------------------------------------------------------------- +module Xanthous.Data.Memo + ( Memoized(UnMemoized) + , memoizeWith + , getMemoized + , runMemoized + , fillWith + , fillWithM + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Data.Aeson (FromJSON, ToJSON) +import Test.QuickCheck (Arbitrary (arbitrary), oneof, CoArbitrary, Function) +import Test.QuickCheck.Checkers (EqProp) +import Xanthous.Util (EqEqProp(EqEqProp)) +import Control.Monad.State.Class (MonadState) +-------------------------------------------------------------------------------- + +-- | A memoized value, keyed by a key +-- +-- If key is different than what is stored here, then val is invalid +data Memoized key val = Memoized key val | UnMemoized + deriving stock (Show, Eq, Generic) + deriving anyclass (Hashable, FromJSON, ToJSON, NFData, CoArbitrary, Function) + deriving EqProp via EqEqProp (Memoized key val) + +instance (Arbitrary k, Arbitrary v) => Arbitrary (Memoized k v) where + arbitrary = oneof [ pure UnMemoized + , Memoized <$> arbitrary <*> arbitrary + ] + +-- | Construct a memoized value with the given key +memoizeWith :: forall key val. key -> val -> Memoized key val +memoizeWith = Memoized +{-# INLINE memoizeWith #-} + +-- | Retrieve a memoized value providing the key. If the value is unmemoized or +-- the keys do not match, returns Nothing. +-- +-- >>> getMemoized 1 (memoizeWith @Int @Int 1 2) +-- Just 2 +-- +-- >>> getMemoized 2 (memoizeWith @Int @Int 1 2) +-- Nothing +-- +-- >>> getMemoized 1 (UnMemoized :: Memoized Int Int) +-- Nothing +getMemoized :: Eq key => key -> Memoized key val -> Maybe val +getMemoized key (Memoized key' v) + | key == key' = Just v + | otherwise = Nothing +getMemoized _ UnMemoized = Nothing +{-# INLINE getMemoized #-} + +-- | Get a memoized value using an applicative action to obtain the key +runMemoized + :: (Eq key, Applicative m) + => Memoized key val + -> m key + -> m (Maybe val) +runMemoized m mk = getMemoized <$> mk <*> pure m + +-- | In a monadic state containing a 'MemoState', look up the current memoized +-- target of some lens keyed by k, filling it with v if not present and +-- returning either the new or old value +fillWith + :: forall m s k v. + (MonadState s m, Eq k) + => Lens' s (Memoized k v) + -> k + -> v + -> m v +fillWith l k v' = do + uses l (getMemoized k) >>= \case + Just v -> pure v + Nothing -> do + l .= memoizeWith k v' + pure v' + +-- | In a monadic state, look up the current memoized target of some lens keyed +-- by k, filling it with the result of some monadic action v if not present and +-- returning either the new or old value +fillWithM + :: forall m s k v. + (MonadState s m, Eq k) + => Lens' s (Memoized k v) + -> k + -> m v + -> m v +fillWithM l k mv = do + uses l (getMemoized k) >>= \case + Just v -> pure v + Nothing -> do + v' <- mv + l .= memoizeWith k v' + pure v' diff --git a/users/aspen/xanthous/src/Xanthous/Data/NestedMap.hs b/users/aspen/xanthous/src/Xanthous/Data/NestedMap.hs new file mode 100644 index 0000000000..1b875d4483 --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Data/VectorBag.hs b/users/aspen/xanthous/src/Xanthous/Data/VectorBag.hs new file mode 100644 index 0000000000..2e6d48062a --- /dev/null +++ b/users/aspen/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 diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Character.hs b/users/aspen/xanthous/src/Xanthous/Entities/Character.hs new file mode 100644 index 0000000000..c8153086f1 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Character.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Character + + ( -- * Character datatype + Character(..) + , characterName + , HasInventory(..) + , characterDamage + , characterHitpoints' + , characterHitpoints + , hitpointRecoveryRate + , speed + , body + + -- *** Body + , Body(..) + , initialBody + , knuckles + , Knuckles(..) + , fistDamageChance + , damageKnuckles + , fistfightingDamage + + -- * Character functions + , mkCharacter + , pickUpItem + , isDead + , isFullyHealed + , damage + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +import Data.Coerce (coerce) +import Test.QuickCheck +import Test.QuickCheck.Instances.Vector () +import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Gen (chooseUpTo) +import Test.QuickCheck.Checkers (EqProp) +import Control.Monad.State.Lazy (execState) +import Control.Monad.Trans.State.Lazy (execStateT) +-------------------------------------------------------------------------------- +import Xanthous.Game.State +import Xanthous.Entities.Item +import Xanthous.Entities.Common +import Xanthous.Data + ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned ) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Util (EqEqProp(EqEqProp), modifyKL) +import Xanthous.Monad (say_) +-------------------------------------------------------------------------------- + +-- | The status of the character's knuckles +-- +-- This struct is used to track the damage and then eventual build-up of +-- calluses when the character is fighting with their fists +data Knuckles = Knuckles + { -- | How damaged are the knuckles currently, from 0 to 5? + -- + -- At 0, no calluses will form + -- At 1 and up, the character will form calluses after a while + -- At 5, continuing to fistfight will deal the character even more damage + _knuckleDamage :: !Word + -- | How built-up are the character's calluses, from 0 to 5? + -- + -- Each level of calluses decreases the likelihood of being damaged when + -- fistfighting by 1%, up to 5 where the character will never be damaged + -- fistfighting + , _knuckleCalluses :: !Word + + -- | Number of turns that have passed since the last time the knuckles were + -- damaged + , _ticksSinceDamaged :: Ticks + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving EqProp via EqEqProp Knuckles + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Knuckles +makeLenses ''Knuckles + +instance Semigroup Knuckles where + (Knuckles d₁ c₁ t₁) <> (Knuckles d₂ c₂ t₂) = Knuckles + (min (d₁ + d₂) 5) + (min (c₁ + c₂) 5) + (max t₁ t₂) + +instance Monoid Knuckles where + mempty = Knuckles 0 0 0 + +instance Arbitrary Knuckles where + arbitrary = do + _knuckleDamage <- fromIntegral <$> chooseUpTo 5 + _knuckleCalluses <- fromIntegral <$> chooseUpTo 5 + _ticksSinceDamaged <- arbitrary + pure Knuckles{..} + +-- | Likelihood that the character fighting with their fists will damage +-- themselves +fistDamageChance :: Knuckles -> Float +fistDamageChance knuckles + | calluses == 5 = 0 + | otherwise = baseChance - (0.01 * fromIntegral calluses) + where + baseChance = 0.08 + calluses = knuckles ^. knuckleCalluses + +-- | Damage the knuckles by a level (capping at the max knuckle damage) +damageKnuckles :: Knuckles -> Knuckles +damageKnuckles = execState $ do + knuckleDamage %= min 5 . succ + ticksSinceDamaged .= 0 + +-- | Damage taken when fistfighting and 'fistDamageChance' has occurred +fistfightingDamage :: Knuckles -> Hitpoints +fistfightingDamage knuckles + | knuckles ^. knuckleDamage == 5 = 2 + | otherwise = 1 + +stepKnuckles :: Ticks -> Knuckles -> AppM Knuckles +stepKnuckles ticks = execStateT . whenM (uses knuckleDamage (> 0)) $ do + ticksSinceDamaged += ticks + whenM (uses ticksSinceDamaged (>= 2000)) $ do + dam <- knuckleDamage <<.= 0 + knuckleCalluses %= min 5 . (+ dam) + ticksSinceDamaged .= 0 + lift $ say_ ["character", "body", "knuckles", "calluses"] + + +-- | Status of the character's body +data Body = Body + { _knuckles :: !Knuckles + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Body + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Body +makeLenses ''Body + +initialBody :: Body +initialBody = Body { _knuckles = mempty } + +-------------------------------------------------------------------------------- + +data Character = Character + { _inventory :: !Inventory + , _characterName :: !(Maybe Text) + , _characterHitpoints' :: !Double + , _speed :: !TicksPerTile + , _body :: !Body + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Character +makeFieldsNoPrefix ''Character + +characterHitpoints :: Character -> Hitpoints +characterHitpoints = views characterHitpoints' floor + +scrollOffset :: Int +scrollOffset = 5 + +instance Draw Character where + draw _ = visibleRegion rloc rreg $ str "@" + where + rloc = Location (negate scrollOffset, negate scrollOffset) + rreg = (2 * scrollOffset, 2 * scrollOffset) + drawPriority = const maxBound -- Character should always be on top, for now + +instance Brain Character where + step ticks = execStateT $ do + positioned . characterHitpoints' %= \hp -> + if hp > fromIntegral initialHitpoints + then hp + else hp + hitpointRecoveryRate |*| ticks + modifyKL (positioned . body . knuckles) $ lift . stepKnuckles ticks + +instance Entity Character where + description _ = "yourself" + entityChar _ = "@" + +instance Arbitrary Character where + arbitrary = genericArbitrary + +initialHitpoints :: Hitpoints +initialHitpoints = 10 + +hitpointRecoveryRate :: Double `Per` Ticks +hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed) + +defaultSpeed :: TicksPerTile +defaultSpeed = 100 + +mkCharacter :: Character +mkCharacter = Character + { _inventory = mempty + , _characterName = Nothing + , _characterHitpoints' = fromIntegral initialHitpoints + , _speed = defaultSpeed + , _body = initialBody + } + +defaultCharacterDamage :: Hitpoints +defaultCharacterDamage = 1 + +-- | Returns the damage that the character currently does with an attack +-- TODO use double-handed/left-hand/right-hand here +characterDamage :: Character -> Hitpoints +characterDamage + = fromMaybe defaultCharacterDamage + . filter (/= 0) + . Just + . sumOf (inventory . wielded . wieldedItems . wieldableItem . Raw.damage) + +-- | Is the character fully healed up to or past their initial hitpoints? +isFullyHealed :: Character -> Bool +isFullyHealed = (>= initialHitpoints) . characterHitpoints + +-- | Is the character dead? +isDead :: Character -> Bool +isDead = (== 0) . characterHitpoints + +pickUpItem :: Item -> Character -> Character +pickUpItem it = inventory . backpack %~ (it <|) + +damage :: Hitpoints -> Character -> Character +damage (fromIntegral -> amount) = characterHitpoints' %~ \case + n | n <= amount -> 0 + | otherwise -> n - amount + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Common.hs b/users/aspen/xanthous/src/Xanthous/Entities/Common.hs new file mode 100644 index 0000000000..368b03f25b --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Common.hs @@ -0,0 +1,290 @@ +{-# 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 diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Creature.hs b/users/aspen/xanthous/src/Xanthous/Entities/Creature.hs new file mode 100644 index 0000000000..3ea610795e --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Creature.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature + ( -- * Creature + Creature(..) + -- ** Lenses + , creatureType + , hitpoints + , hippocampus + , inventory + + -- ** Creature functions + , damage + , isDead + , visionRadius + + -- * Hippocampus + , Hippocampus(..) + -- ** Lenses + , destination + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +-------------------------------------------------------------------------------- +import Xanthous.AI.Gormlak +import Xanthous.Entities.RawTypes hiding + (Creature, description, damage) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Game.State +import Xanthous.Data +import Xanthous.Data.Entities +import Xanthous.Entities.Creature.Hippocampus +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +import Xanthous.Entities.Common (Inventory, HasInventory(..)) +-------------------------------------------------------------------------------- + +data Creature = Creature + { _creatureType :: !CreatureType + , _hitpoints :: !Hitpoints + , _hippocampus :: !Hippocampus + , _inventory :: !Inventory + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature + deriving Arbitrary via GenericArbitrary Creature + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Creature +makeFieldsNoPrefix ''Creature + +instance HasVisionRadius Creature where + visionRadius = const 50 -- TODO + +instance Brain Creature where + step = brainVia GormlakBrain + entityCanMove = const True + +instance Entity Creature where + entityAttributes _ = defaultEntityAttributes + & blocksObject .~ True + description = view $ creatureType . Raw.description + entityChar = view $ creatureType . char + entityCollision = const $ Just Combat + +-------------------------------------------------------------------------------- + +damage :: Hitpoints -> Creature -> Creature +damage amount = hitpoints %~ \hp -> + if hp <= amount + then 0 + else hp - amount + +isDead :: Creature -> Bool +isDead = views hitpoints (== 0) + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs new file mode 100644 index 0000000000..d13ea8055c --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Creature.Hippocampus + (-- * Hippocampus + Hippocampus(..) + , initialHippocampus + -- ** Lenses + , destination + , greetedCharacter + -- ** Destination + , Destination(..) + , destinationFromPos + -- *** Lenses + , destinationPosition + , destinationProgress + ) +where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Data +-------------------------------------------------------------------------------- + + +data Destination = Destination + { _destinationPosition :: !Position + -- | The progress towards the destination, tracked as an offset from the + -- creature's original position. + -- + -- When this value reaches >= 1, the creature has reached their destination + , _destinationProgress :: !Tiles + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Destination +instance Arbitrary Destination where arbitrary = genericArbitrary +makeLenses ''Destination + +destinationFromPos :: Position -> Destination +destinationFromPos _destinationPosition = + let _destinationProgress = 0 + in Destination{..} + +data Hippocampus = Hippocampus + { _destination :: !(Maybe Destination) + , -- | Has this creature greeted the character in any way yet? + -- + -- Some creature types ignore this field + _greetedCharacter :: !Bool + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Hippocampus + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Hippocampus +makeLenses ''Hippocampus + +initialHippocampus :: Hippocampus +initialHippocampus = Hippocampus + { _destination = Nothing + , _greetedCharacter = False + } diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs new file mode 100644 index 0000000000..aa6c5fa4fc --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs @@ -0,0 +1,31 @@ +module Xanthous.Entities.Draw.Util where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.Widgets.Border.Style +import Brick.Types (Edges(..)) +-------------------------------------------------------------------------------- + +borderFromEdges :: BorderStyle -> Edges Bool -> Char +borderFromEdges bstyle edges = ($ bstyle) $ case edges of + Edges False False False False -> const '☐' + + Edges True False False False -> bsVertical + Edges False True False False -> bsVertical + Edges False False True False -> bsHorizontal + Edges False False False True -> bsHorizontal + + Edges True True False False -> bsVertical + Edges True False True False -> bsCornerBR + Edges True False False True -> bsCornerBL + + Edges False True True False -> bsCornerTR + Edges False True False True -> bsCornerTL + Edges False False True True -> bsHorizontal + + Edges False True True True -> bsIntersectT + Edges True False True True -> bsIntersectB + Edges True True False True -> bsIntersectL + Edges True True True False -> bsIntersectR + + Edges True True True True -> bsIntersectFull diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs new file mode 100644 index 0000000000..a0c037a1b4 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Entities () where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import qualified Test.QuickCheck.Gen as Gen +import Data.Aeson +-------------------------------------------------------------------------------- +import Xanthous.Entities.Character +import Xanthous.Entities.Item +import Xanthous.Entities.Creature +import Xanthous.Entities.Environment +import Xanthous.Entities.Marker +import Xanthous.Game.State +import Xanthous.Util.QuickCheck +import Data.Aeson.Generic.DerivingVia +-------------------------------------------------------------------------------- + +instance Arbitrary SomeEntity where + arbitrary = Gen.oneof + [ SomeEntity <$> arbitrary @Character + , SomeEntity <$> arbitrary @Item + , SomeEntity <$> arbitrary @Creature + , SomeEntity <$> arbitrary @Wall + , SomeEntity <$> arbitrary @Door + , SomeEntity <$> arbitrary @GroundMessage + , SomeEntity <$> arbitrary @Staircase + , SomeEntity <$> arbitrary @Marker + ] + +instance FromJSON SomeEntity where + parseJSON = withObject "Entity" $ \obj -> do + (entityType :: Text) <- obj .: "type" + case entityType of + "Character" -> SomeEntity @Character <$> obj .: "data" + "Item" -> SomeEntity @Item <$> obj .: "data" + "Creature" -> SomeEntity @Creature <$> obj .: "data" + "Wall" -> SomeEntity @Wall <$> obj .: "data" + "Door" -> SomeEntity @Door <$> obj .: "data" + "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data" + "Staircase" -> SomeEntity @Staircase <$> obj .: "data" + "Marker" -> SomeEntity @Marker <$> obj .: "data" + _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\"" + +deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel + instance FromJSON GameLevel +deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState + instance FromJSON GameState + +instance Entity SomeEntity where + entityAttributes (SomeEntity ent) = entityAttributes ent + description (SomeEntity ent) = description ent + entityChar (SomeEntity ent) = entityChar ent + entityCollision (SomeEntity ent) = entityCollision ent + +instance Function SomeEntity where + function = functionJSON + +instance CoArbitrary SomeEntity where + coarbitrary = coarbitrary . encode diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot new file mode 100644 index 0000000000..519a862c6a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Xanthous.Entities.Entities where + +import Test.QuickCheck +import Data.Aeson +import Xanthous.Game.State (SomeEntity, GameState, Entity) + +instance Arbitrary SomeEntity +instance Function SomeEntity +instance CoArbitrary SomeEntity +instance FromJSON SomeEntity +instance Entity SomeEntity + +instance FromJSON GameState diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Environment.hs b/users/aspen/xanthous/src/Xanthous/Entities/Environment.hs new file mode 100644 index 0000000000..b45a91eabe --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Environment.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TemplateHaskell #-} +module Xanthous.Entities.Environment + ( + -- * Walls + Wall(..) + + -- * Doors + , Door(..) + , open + , closed + , locked + , unlockedDoor + + -- * Messages + , GroundMessage(..) + + -- * Stairs + , Staircase(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Test.QuickCheck +import Brick (str) +import Brick.Widgets.Border.Style (unicode) +import Brick.Types (Edges(..)) +import Data.Aeson +import Data.Aeson.Generic.DerivingVia +-------------------------------------------------------------------------------- +import Xanthous.Entities.Draw.Util +import Xanthous.Data +import Xanthous.Data.Entities +import Xanthous.Game.State +import Xanthous.Util.QuickCheck +-------------------------------------------------------------------------------- + +data Wall = Wall + deriving stock (Show, Eq, Ord, Generic, Enum) + deriving anyclass (NFData, CoArbitrary, Function) + +instance ToJSON Wall where + toJSON = const $ String "Wall" + +instance FromJSON Wall where + parseJSON = withText "Wall" $ \case + "Wall" -> pure Wall + _ -> fail "Invalid Wall: expected Wall" + +instance Brain Wall where step = brainVia Brainless + +instance Entity Wall where + entityAttributes _ = defaultEntityAttributes + & blocksVision .~ True + & blocksObject .~ True + description _ = "a wall" + entityChar _ = "┼" + +instance Arbitrary Wall where + arbitrary = pure Wall + +wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity) + => Neighbors mono -> Edges Bool +wallEdges neighs = any (entityIs @Wall) <$> edges neighs + +instance Draw Wall where + drawWithNeighbors neighs _wall = + str . pure . borderFromEdges unicode $ wallEdges neighs + +data Door = Door + { _open :: Bool + , _locked :: Bool + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary Door +makeLenses ''Door + +instance Draw Door where + drawWithNeighbors neighs door + = str . pure . ($ door ^. open) $ case wallEdges neighs of + Edges True False False False -> vertDoor + Edges False True False False -> vertDoor + Edges True True False False -> vertDoor + Edges False False True False -> horizDoor + Edges False False False True -> horizDoor + Edges False False True True -> horizDoor + _ -> allsidesDoor + where + horizDoor True = '␣' + horizDoor False = 'ᚔ' + vertDoor True = '[' + vertDoor False = 'ǂ' + allsidesDoor True = '+' + allsidesDoor False = '▥' + +instance Brain Door where step = brainVia Brainless + +instance Entity Door where + entityAttributes door = defaultEntityAttributes + & blocksVision .~ not (door ^. open) + description door | door ^. open = "an open door" + | otherwise = "a closed door" + entityChar _ = "d" + entityCollision door | door ^. open = Nothing + | otherwise = Just Stop + +closed :: Lens' Door Bool +closed = open . involuted not + +-- | A closed, unlocked door +unlockedDoor :: Door +unlockedDoor = Door + { _open = False + , _locked = False + } + +-------------------------------------------------------------------------------- + +newtype GroundMessage = GroundMessage Text + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary GroundMessage + deriving (ToJSON, FromJSON) + via WithOptions '[ 'TagSingleConstructors 'True + , 'SumEnc 'ObjWithSingleField + ] + GroundMessage + deriving Draw + via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈" + GroundMessage +instance Brain GroundMessage where step = brainVia Brainless + +instance Entity GroundMessage where + description = const "a message on the ground. Press r. to read it." + entityChar = const "≈" + entityCollision = const Nothing + +-------------------------------------------------------------------------------- + +data Staircase = UpStaircase | DownStaircase + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Staircase + deriving (ToJSON, FromJSON) + via WithOptions '[ 'TagSingleConstructors 'True + , 'SumEnc 'ObjWithSingleField + ] + Staircase +instance Brain Staircase where step = brainVia Brainless + +instance Draw Staircase where + draw UpStaircase = str "<" + draw DownStaircase = str ">" + +instance Entity Staircase where + description UpStaircase = "a staircase leading upwards" + description DownStaircase = "a staircase leading downwards" + entityChar UpStaircase = "<" + entityChar DownStaircase = ">" + entityCollision = const Nothing diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Item.hs b/users/aspen/xanthous/src/Xanthous/Entities/Item.hs new file mode 100644 index 0000000000..eadd625696 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Item.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Item + ( Item(..) + , itemType + , density + , volume + , newWithType + , isEdible + , weight + , fullDescription + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck (Arbitrary, CoArbitrary, Function) +import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson.Generic.DerivingVia +import Control.Monad.Random (MonadRandom) +-------------------------------------------------------------------------------- +import Xanthous.Entities.RawTypes (ItemType) +import qualified Xanthous.Entities.RawTypes as Raw +import Xanthous.Game.State +import Xanthous.Data (Grams, Per, Cubic, Meters, (|*|)) +import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary)) +import Xanthous.Random (choose, FiniteInterval(..)) +-------------------------------------------------------------------------------- + +data Item = Item + { _itemType :: ItemType + , _density :: Grams `Per` Cubic Meters + , _volume :: Cubic Meters + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Draw via DrawRawChar "_itemType" Item + deriving Arbitrary via GenericArbitrary Item + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Item +makeLenses ''Item + +-- deriving via (Brainless Item) instance Brain Item +instance Brain Item where step = brainVia Brainless + +instance Entity Item where + description = view $ itemType . Raw.description + entityChar = view $ itemType . Raw.char + entityCollision = const Nothing + +newWithType :: MonadRandom m => ItemType -> m Item +newWithType _itemType = do + _density <- choose . FiniteInterval $ _itemType ^. Raw.density + _volume <- choose . FiniteInterval $ _itemType ^. Raw.volume + pure Item {..} + +isEdible :: Item -> Bool +isEdible = Raw.isEdible . view itemType + +-- | The weight of this item, calculated by multiplying its volume by the +-- density of its material +weight :: Item -> Grams +weight item = (item ^. density) |*| (item ^. volume) + +-- | Describe the item in full detail +fullDescription :: Item -> Text +fullDescription item = unlines + [ item ^. itemType . Raw.description + , "" + , item ^. itemType . Raw.longDescription + , "" + , "volume: " <> tshow (item ^. volume) + , "density: " <> tshow (item ^. density) + , "weight: " <> tshow (weight item) + ] diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Marker.hs b/users/aspen/xanthous/src/Xanthous/Entities/Marker.hs new file mode 100644 index 0000000000..14d02872ed --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Marker.hs @@ -0,0 +1,41 @@ +-------------------------------------------------------------------------------- +module Xanthous.Entities.Marker ( Marker(..) ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson +import Test.QuickCheck +import qualified Graphics.Vty.Attributes as Vty +import qualified Graphics.Vty.Image as Vty +import Brick.Widgets.Core (raw) +-------------------------------------------------------------------------------- +import Xanthous.Game.State +import Xanthous.Data.Entities (EntityAttributes(..)) +-------------------------------------------------------------------------------- + +-- | Mark on the map - for use in debugging / development only. +newtype Marker = Marker Text + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Semigroup, Monoid, ToJSON, FromJSON, Arbitrary) via Text + +instance Brain Marker where step = brainVia Brainless + +instance Entity Marker where + entityAttributes = const EntityAttributes + { _blocksVision = False + , _blocksObject = False + , _collision = Stop + } + description (Marker m) = "[M] " <> m + entityChar = const $ "X" & style .~ markerStyle + entityCollision = const Nothing + +instance Draw Marker where + draw = const . raw $ Vty.char markerStyle 'X' + drawPriority = const maxBound + +markerStyle :: Vty.Attr +markerStyle = Vty.defAttr + `Vty.withForeColor` Vty.red + `Vty.withBackColor` Vty.black diff --git a/users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs new file mode 100644 index 0000000000..a7021d76cf --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.RawTypes + ( + EntityRaw(..) + , _Creature + , _Item + + -- * Creatures + , CreatureType(..) + , hostile + -- ** Generation parameters + , CreatureGenerateParams(..) + , canGenerate + -- ** Language + , LanguageName(..) + , getLanguage + -- ** Attacks + , Attack(..) + + -- * Items + , ItemType(..) + -- ** Item sub-types + -- *** Edible + , EdibleItem(..) + , isEdible + -- *** Wieldable + , WieldableItem(..) + , isWieldable + + -- * Lens classes + , HasAttackMessage(..) + , HasAttacks(..) + , HasChance(..) + , HasChar(..) + , HasCreatureAttackMessage(..) + , HasDamage(..) + , HasDensity(..) + , HasDescription(..) + , HasEatMessage(..) + , HasEdible(..) + , HasEntityName(..) + , HasEquippedItem(..) + , HasFriendly(..) + , HasGenerateParams(..) + , HasHitpointsHealed(..) + , HasLanguage(..) + , HasLevelRange(..) + , HasLongDescription(..) + , HasMaxHitpoints(..) + , HasName(..) + , HasSayVerb(..) + , HasSpeed(..) + , HasVolume(..) + , HasWieldable(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) +import Data.Interval (Interval, lowerBound', upperBound') +import qualified Data.Interval as Interval +-------------------------------------------------------------------------------- +import Xanthous.Messages (Message(..)) +import Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters) +import Xanthous.Data.EntityChar +import Xanthous.Util.QuickCheck +import Xanthous.Generators.Speech (Language, gormlak, english) +import Xanthous.Orphans () +import Xanthous.Util (EqProp, EqEqProp(..)) +-------------------------------------------------------------------------------- + +-- | Identifiers for languages that creatures can speak. +-- +-- Non-verbal or non-sentient creatures have Nothing as their language +-- +-- At some point, we will likely want to make languages be defined in data files +-- somewhere, and reference them that way instead. +data LanguageName = Gormlak | English + deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary LanguageName + deriving (ToJSON, FromJSON) + via WithOptions '[ AllNullaryToStringTag 'True ] + LanguageName + +-- | Resolve a 'LanguageName' into an actual 'Language' +getLanguage :: LanguageName -> Language +getLanguage Gormlak = gormlak +getLanguage English = english + +-- | Natural attacks for creature types +data Attack = Attack + { -- | the @{{creature}}@ @{{description}}@ + _description :: !Message + -- | Damage dealt + , _damage :: !Hitpoints + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Attack + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] + , OmitNothingFields 'True + ] + Attack +makeFieldsNoPrefix ''Attack + +-- | Description for generating an item equipped to a creature +data CreatureEquippedItem = CreatureEquippedItem + { -- | Name of the entity type to generate + _entityName :: !Text + -- | Chance of generating the item when generating the creature + -- + -- A chance of 1.0 will always generate the item + , _chance :: !Double + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary CreatureEquippedItem + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] + , OmitNothingFields 'True + ] + CreatureEquippedItem +makeFieldsNoPrefix ''CreatureEquippedItem + + +data CreatureGenerateParams = CreatureGenerateParams + { -- | Range of dungeon levels at which to generate this creature + _levelRange :: !(Interval Word) + -- | Item equipped to the creature + , _equippedItem :: !(Maybe CreatureEquippedItem) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary CreatureGenerateParams + deriving EqProp via EqEqProp CreatureGenerateParams + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + CreatureGenerateParams +makeFieldsNoPrefix ''CreatureGenerateParams + +instance Ord CreatureGenerateParams where + compare + = (compare `on` lowerBound' . _levelRange) + <> (compare `on` upperBound' . _levelRange) + <> (compare `on` _equippedItem) + +-- | Can a creature with these generate params be generated on this level? +canGenerate + :: Word -- ^ Level number + -> CreatureGenerateParams + -> Bool +canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange + +data CreatureType = CreatureType + { _name :: !Text + , _description :: !Text + , _char :: !EntityChar + , _maxHitpoints :: !Hitpoints + , _friendly :: !Bool + , _speed :: !TicksPerTile + , _language :: !(Maybe LanguageName) + , -- | The verb, in present tense, for when the creature says something + _sayVerb :: !(Maybe Text) + , -- | The creature's natural attacks + _attacks :: !(NonNull (Vector Attack)) + -- | Parameters for generating the creature in levels + , _generateParams :: !(Maybe CreatureGenerateParams) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary CreatureType + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] + , OmitNothingFields 'True + ] + CreatureType +makeFieldsNoPrefix ''CreatureType + +hostile :: Lens' CreatureType Bool +hostile = friendly . involuted not + +-------------------------------------------------------------------------------- + +data EdibleItem = EdibleItem + { _hitpointsHealed :: !Int + , _eatMessage :: !(Maybe Message) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary EdibleItem + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + EdibleItem +makeFieldsNoPrefix ''EdibleItem + +data WieldableItem = WieldableItem + { _damage :: !Hitpoints + -- | Message to use when the character is using this item to attack a + -- creature. + -- + -- Grammatically, this should be of the form "slash at the + -- {{creature.creatureType.name}} with your dagger" + -- + -- = Parameters + -- + -- [@creature@ (type: 'Creature')] The creature being attacked + , _attackMessage :: !(Maybe Message) + -- | Message to use when a creature is using this item to attack the + -- character. + -- + -- Grammatically, should be of the form "The creature slashes you with its + -- dagger". + -- + -- = Parameters + -- + -- [@creature@ (type: 'Creature')] The creature doing the attacking + -- [@item@ (type: 'Item')] The item itself + , _creatureAttackMessage :: !(Maybe Message) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary WieldableItem + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + WieldableItem +makeFieldsNoPrefix ''WieldableItem + +-------------------------------------------------------------------------------- + +data ItemType = ItemType + { _name :: !Text + , _description :: !Text + , _longDescription :: !Text + , _char :: !EntityChar + , _density :: !(Interval (Grams `Per` Cubic Meters)) + , _volume :: !(Interval (Cubic Meters)) + , _edible :: !(Maybe EdibleItem) + , _wieldable :: !(Maybe WieldableItem) + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary ItemType + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + ItemType +makeFieldsNoPrefix ''ItemType + +instance Ord ItemType where + compare x y + = compareOf name x y + <> compareOf description x y + <> compareOf longDescription x y + <> compareOf char x y + <> compareOf (density . to extractInterval) x y + <> compareOf (volume . to extractInterval) x y + <> compareOf edible x y + <> compareOf wieldable x y + where + compareOf l = comparing (view l) + extractInterval = lowerBound' &&& upperBound' + +-- | Can this item be eaten? +isEdible :: ItemType -> Bool +isEdible = has $ edible . _Just + +-- | Can this item be used as a weapon? +isWieldable :: ItemType -> Bool +isWieldable = has $ wieldable . _Just + +-------------------------------------------------------------------------------- + +data EntityRaw + = Creature !CreatureType + | Item !ItemType + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving Arbitrary via GenericArbitrary EntityRaw + deriving (FromJSON) + via WithOptions '[ SumEnc ObjWithSingleField ] + EntityRaw +makePrisms ''EntityRaw diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws.hs b/users/aspen/xanthous/src/Xanthous/Entities/Raws.hs new file mode 100644 index 0000000000..10f0d83193 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Entities.Raws + ( raws + , raw + , RawType(..) + , rawsWithType + ) where +-------------------------------------------------------------------------------- +import Data.FileEmbed +import qualified Data.Yaml as Yaml +import Xanthous.Prelude +import System.FilePath.Posix +-------------------------------------------------------------------------------- +import Xanthous.Entities.RawTypes +import Xanthous.AI.Gormlak () +-------------------------------------------------------------------------------- +rawRaws :: [(FilePath, ByteString)] +rawRaws = $(embedDir "src/Xanthous/Entities/Raws") + +raws :: HashMap Text EntityRaw +raws + = mapFromList + . map (bimap + (pack . takeBaseName) + (either (error . Yaml.prettyPrintParseException) id + . Yaml.decodeEither')) + $ rawRaws + +raw :: Text -> Maybe EntityRaw +raw n = raws ^. at n + +class RawType (a :: Type) where + _RawType :: Prism' EntityRaw a + +instance RawType CreatureType where + _RawType = prism' Creature $ \case + Creature c -> Just c + _ -> Nothing + +instance RawType ItemType where + _RawType = prism' Item $ \case + Item i -> Just i + _ -> Nothing + +rawsWithType :: forall a. RawType a => HashMap Text a +rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws + +-------------------------------------------------------------------------------- diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml new file mode 100644 index 0000000000..12c76fc14b --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml @@ -0,0 +1,24 @@ +Item: + name: broken dagger + description: a short, broken dagger + longDescription: A short dagger with a twisted, chipped blade + char: + char: † + style: + foreground: black + wieldable: + damage: 3 + attackMessage: + - slash at the {{creature.creatureType.name}} with your dagger + - stab the {{creature.creatureType.name}} with your dagger + creatureAttackMessage: + - The {{creature.creatureType.name}} slashes at you with its dagger. + - The {{creature.creatureType.name}} stabs you with its dagger. + # Just the steel, not the handle, for now + density: [7750 , 8050000] + # 15cm – 45cm + # × + # 2cm – 3cm + # × + # .5cm – 1cm + volume: [0.15, 1.35] diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml new file mode 100644 index 0000000000..ad3d9cb147 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml @@ -0,0 +1,20 @@ +Creature: + name: gormlak + description: a gormlak + longDescription: | + A chittering imp-like creature with bright yellow horns and sharp claws. It + adores shiny objects and gathers in swarms. + char: + char: g + style: + foreground: red + maxHitpoints: 5 + speed: 125 + friendly: false + language: Gormlak + sayVerb: yells + attacks: + - description: + - claws you + - slashes you with its claws + damage: 1 diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml new file mode 100644 index 0000000000..cdfcde616d --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml @@ -0,0 +1,26 @@ +Creature: + name: husk + description: an empty husk of some humanoid creature + longDescription: | + An empty husk of a humanoid creature. All semblance of sentience has long + left its eyes; instead it shambles about aimlessly, always hungering for the + warmth of life. + char: + char: h + style: + foreground: black + maxHitpoints: 6 + speed: 110 + friendly: false + attacks: + - description: + - swings its arms at you + - elbows you + damage: 1 + - description: kicks you + damage: 2 + generateParams: + levelRange: [1, PosInf] + equippedItem: + entityName: broken-dagger + chance: 0.9 diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml new file mode 100644 index 0000000000..c0501a18a8 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml @@ -0,0 +1,14 @@ +Item: + name: noodles + description: "a big bowl o' noodles" + longDescription: You know exactly what kind of noodles + char: + char: 'n' + style: + foreground: yellow + edible: + hitpointsHealed: 2 + eatMessage: + - You slurp up the noodles. Yumm! + density: 500000 + volume: 0.001 diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml new file mode 100644 index 0000000000..fe427c94ab --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml @@ -0,0 +1,15 @@ +Creature: + name: ooze + description: an ooze + longDescription: | + A jiggling, amorphous, bright green caustic blob + char: + char: o + style: + foreground: green + maxHitpoints: 3 + speed: 100 + friendly: false + attacks: + - description: slams into you + damage: 1 diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml new file mode 100644 index 0000000000..3f4e133fe2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml @@ -0,0 +1,10 @@ +Item: + name: rock + description: a rock + longDescription: a medium-sized rock made out of some unknown stone + char: . + wieldable: + damage: 1 + attackMessage: hit the {{creature.creatureType.name}} in the head with your rock + density: [ 1500000, 2500000 ] + volume: [ 0.000125, 0.001 ] diff --git a/users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml new file mode 100644 index 0000000000..7f9e1faffe --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml @@ -0,0 +1,22 @@ +Item: + name: stick + description: a wooden stick + longDescription: A sturdy branch broken off from some sort of tree + char: + char: ∤ + style: + foreground: yellow + wieldable: + damage: 2 + attackMessage: + - bonk the {{creature.creatureType.name}} over the head with your stick + - bash the {{creature.creatureType.name}} on the noggin with your stick + - whack the {{creature.creatureType.name}} with your stick + creatureAttackMessage: + - The {{creature.creatureType.name}} bonks you over the head with its stick. + - The {{creature.creatureType.name}} bashes you on the noggin with its stick. + - The {{creature.creatureType.name}} whacks you with its stick. + # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density + # it's a hard stick. so it's dense wood. + density: 890000 # g/m³ + volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length diff --git a/users/aspen/xanthous/src/Xanthous/Game.hs b/users/aspen/xanthous/src/Xanthous/Game.hs new file mode 100644 index 0000000000..89c23f0de8 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game.hs @@ -0,0 +1,73 @@ +module Xanthous.Game + ( GameState(..) + , levels + , entities + , revealedPositions + , messageHistory + , randomGen + , promptState + , GamePromptState(..) + + , getInitialState + , initialStateFromSeed + + , positionedCharacter + , character + , characterPosition + , updateCharacterVision + , characterVisiblePositions + , entitiesAtCharacter + , revealedEntitiesAtPosition + + -- * Messages + , MessageHistory(..) + , HasMessages(..) + , HasTurn(..) + , HasDisplayedTurn(..) + , pushMessage + , previousMessage + , nextTurn + + -- * Collisions + , Collision(..) + , collisionAt + + -- * App monad + , AppT(..) + + -- * Saving the game + , saveGame + , loadGame + , saved + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed + ) where +-------------------------------------------------------------------------------- +import qualified Codec.Compression.Zlib as Zlib +import Codec.Compression.Zlib.Internal (DecompressError) +import qualified Data.Aeson as JSON +import System.IO.Unsafe +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Xanthous.Game.State +import Xanthous.Game.Lenses +import Xanthous.Game.Arbitrary () +import Xanthous.Entities.Entities () +-------------------------------------------------------------------------------- + +saveGame :: GameState -> LByteString +saveGame = Zlib.compress . JSON.encode + +loadGame :: LByteString -> Maybe GameState +loadGame = JSON.decode <=< decompressZlibMay + where + decompressZlibMay bs + = unsafeDupablePerformIO + $ (let r = Zlib.decompress bs in r `seq` pure (Just r)) + `catch` \(_ :: DecompressError) -> pure Nothing + +saved :: Prism' LByteString GameState +saved = prism' saveGame loadGame diff --git a/users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs new file mode 100644 index 0000000000..679bfe5459 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Arbitrary.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Arbitrary where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (foldMap) +-------------------------------------------------------------------------------- +import Test.QuickCheck +import System.Random +import Data.Foldable (foldMap) +-------------------------------------------------------------------------------- +import Xanthous.Data.Levels +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Entities () +import Xanthous.Entities.Character +import Xanthous.Game.State +import Xanthous.Orphans () +import Xanthous.Util.QuickCheck (GenericArbitrary(..)) +-------------------------------------------------------------------------------- + +deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel + +instance Arbitrary GameState where + arbitrary = do + chr <- arbitrary @Character + _upStaircasePosition <- arbitrary + _messageHistory <- arbitrary + levs <- arbitrary @(Levels GameLevel) + _levelRevealedPositions <- + fmap setFromList + . sublistOf + . foldMap (EntityMap.positions . _levelEntities) + $ levs + let (_characterEntityID, _levelEntities) = + EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr) + $ levs ^. current . levelEntities + _levels = levs & current .~ GameLevel {..} + _randomGen <- mkStdGen <$> arbitrary + let _promptState = NoPrompt -- TODO + _activePanel <- arbitrary + _debugState <- arbitrary + let _autocommand = NoAutocommand + _memo <- arbitrary + _savefile <- arbitrary + pure $ GameState {..} + + +instance CoArbitrary GameLevel +instance Function GameLevel +instance CoArbitrary GameState +instance Function GameState diff --git a/users/aspen/xanthous/src/Xanthous/Game/Draw.hs b/users/aspen/xanthous/src/Xanthous/Game/Draw.hs new file mode 100644 index 0000000000..291dfd8b5e --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Draw.hs @@ -0,0 +1,224 @@ +-------------------------------------------------------------------------------- +module Xanthous.Game.Draw + ( drawGame + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick hiding (loc, on) +import Brick.Widgets.Border +import Brick.Widgets.Border.Style +import Brick.Widgets.Edit +import Control.Monad.State.Lazy (evalState) +import Control.Monad.State.Class ( get, MonadState, gets ) +-------------------------------------------------------------------------------- +import Xanthous.Data +import Xanthous.Data.App (ResourceName, Panel(..)) +import qualified Xanthous.Data.App as Resource +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Game.State +import Xanthous.Entities.Common (Wielded(..), wielded, backpack) +import Xanthous.Entities.Character +import Xanthous.Entities.Item (Item) +import Xanthous.Game + ( characterPosition + , character + , revealedEntitiesAtPosition + ) +import Xanthous.Game.Prompt +import Xanthous.Orphans () +import Brick.Widgets.Center (hCenter) +import Xanthous.Command (Keybinding (..), keybindings, Command, commandIsHidden) +import Graphics.Vty.Input.Events (Modifier(..)) +import Graphics.Vty.Input (Key(..)) +import Brick.Widgets.Table +-------------------------------------------------------------------------------- + +cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName +cursorPosition game + | WaitingPrompt _ (Prompt _ _ (preview promptStatePosition -> Just pos) _ _) + <- game ^. promptState + = showCursor Resource.Prompt (pos ^. loc) + | otherwise + = showCursor Resource.Character (game ^. characterPosition . loc) + +drawMessages :: MessageHistory -> Widget ResourceName +drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract + +drawPromptState :: GamePromptState m -> Widget ResourceName +drawPromptState NoPrompt = emptyWidget +drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = + case (pt, ps, pri) of + (SStringPrompt, StringPromptState edit, mDef) -> + txt msg + <+> txt (maybe "" (\def -> "(default: " <> def <> ") ") mDef) + <+> renderEditor (txt . fold) True edit + (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg + (SMenu, _, menuItems) -> + txtWrap msg + <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) + _ -> txtWrap msg + where + drawMenuItem (chr, MenuOption m _) = + str ("[" <> pure chr <> "] ") <+> txtWrap m + +drawEntities + :: forall m. MonadState GameState m + => m (Widget ResourceName) +drawEntities = do + allEnts <- use entities + let entityPositions = EntityMap.positions allEnts + maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions + maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions + rows = traverse mkRow [0..maxY] + mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX] + renderEntityAt pos + = renderTopEntity pos <$> revealedEntitiesAtPosition pos + renderTopEntity pos ents + = let neighbors = EntityMap.neighbors pos allEnts + in maybe (str " ") (drawWithNeighbors neighbors) + $ maximumBy (compare `on` drawPriority) + <$> fromNullable ents + vBox <$> rows + +drawMap :: MonadState GameState m => m (Widget ResourceName) +drawMap = do + cursorPos <- gets cursorPosition + viewport Resource.MapViewport Both . cursorPos <$> drawEntities + +bullet :: Char +bullet = '•' + +drawInventoryPanel :: GameState -> Widget ResourceName +drawInventoryPanel game + = drawWielded (game ^. character . inventory . wielded) + <=> drawBackpack (game ^. character . inventory . backpack) + where + drawWielded (Hands Nothing Nothing) = emptyWidget + drawWielded (DoubleHanded i) = + txtWrap $ "You are holding " <> description i <> " in both hands" + drawWielded (Hands l r) = drawHand "left" l <=> drawHand "right" r + drawHand side = maybe emptyWidget $ \i -> + txtWrap ( "You are holding " + <> description i + <> " in your " <> side <> " hand" + ) + <=> txt " " + + drawBackpack :: Vector Item -> Widget ResourceName + drawBackpack Empty = txtWrap "Your backpack is empty right now." + drawBackpack backpackItems + = txtWrap ( "You are currently carrying the following items in your " + <> "backpack:") + <=> txt " " + <=> foldl' (<=>) emptyWidget + (map + (txtWrap . ((bullet <| " ") <>) . description) + backpackItems) + +drawHelpPanel :: Widget ResourceName +drawHelpPanel + = txtWrap "To move in a direction or attack, use vi keys (hjklyubn):" + <=> txt " " + <=> hCenter keyStar + <=> txt " " + <=> cmds + where + keyStar + = txt "y k u" + <=> txt " \\|/" + <=> txt "h-.-l" + <=> txt " /|\\" + <=> txt "b j n" + + cmds + = renderTable + . alignRight 0 + . setDefaultRowAlignment AlignTop + . surroundingBorder False + . rowBorders False + . columnBorders False + . table $ help <&> \(key, cmd) -> [ txt $ key <> " : " + , hLimitPercent 100 $ txtWrap cmd] + + help = + extraHelp <> + keybindings + ^.. ifolded + . filtered (not . commandIsHidden) + . withIndex + . to (bimap displayKeybinding displayCommand) + extraHelp + = [("Shift-Dir", "Auto-move")] + + displayCommand = tshow @Command + displayKeybinding (Keybinding k mods) = foldMap showMod mods <> showKey k + + showMod MCtrl = "Ctrl-" + showMod MShift = "Shift-" + showMod MAlt = "Alt-" + showMod MMeta = "Meta-" + + showKey (KChar c) = pack [c] + showKey KEsc = "<Esc>" + showKey KBS = "<Backspace>" + showKey KEnter = "<Enter>" + showKey KLeft = "<Left>" + showKey KRight = "<Right>" + showKey KUp = "<Up>" + showKey KDown = "<Down>" + showKey KUpLeft = "<UpLeft>" + showKey KUpRight = "<UpRight>" + showKey KDownLeft = "<DownLeft>" + showKey KDownRight = "<DownRight>" + showKey KCenter = "<Center>" + showKey (KFun n) = "<F" <> tshow n <> ">" + showKey KBackTab = "<BackTab>" + showKey KPrtScr = "<PrtScr>" + showKey KPause = "<Pause>" + showKey KIns = "<Ins>" + showKey KHome = "<Home>" + showKey KPageUp = "<PageUp>" + showKey KDel = "<Del>" + showKey KEnd = "<End>" + showKey KPageDown = "<PageDown>" + showKey KBegin = "<Begin>" + showKey KMenu = "<Menu>" + +drawPanel :: GameState -> Panel -> Widget ResourceName +drawPanel game panel + = border + . hLimit 35 + . viewport (Resource.Panel panel) Vertical + $ case panel of + HelpPanel -> drawHelpPanel + InventoryPanel -> drawInventoryPanel game + ItemDescriptionPanel desc -> txtWrap desc + +drawCharacterInfo :: Character -> Widget ResourceName +drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints + where + charName | Just n <- ch ^. characterName + = txt $ n <> " " + | otherwise + = emptyWidget + charHitpoints + = txt "Hitpoints: " + <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) + +drawGame :: GameState -> [Widget ResourceName] +drawGame = evalState $ do + game <- get + drawnMap <- drawMap + pure + . pure + . withBorderStyle unicode + $ case game ^. promptState of + NoPrompt -> drawMessages (game ^. messageHistory) + _ -> emptyWidget + <=> drawPromptState (game ^. promptState) + <=> + (maybe emptyWidget (drawPanel game) (game ^. activePanel) + <+> border drawnMap + ) + <=> drawCharacterInfo (game ^. character) diff --git a/users/aspen/xanthous/src/Xanthous/Game/Env.hs b/users/aspen/xanthous/src/Xanthous/Game/Env.hs new file mode 100644 index 0000000000..5d7b275c8a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Env.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Env + ( Config(..) + , defaultConfig + , disableSaving + , GameEnv(..) + , eventChan + , config + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.BChan (BChan) +import Xanthous.Data.App (AppEvent) +-------------------------------------------------------------------------------- + +data Config = Config + { _disableSaving :: Bool + } + deriving stock (Generic, Show, Eq) +makeLenses ''Config +{-# ANN Config ("HLint: ignore Use newtype instead of data" :: String) #-} + +defaultConfig :: Config +defaultConfig = Config + { _disableSaving = False + } + +-------------------------------------------------------------------------------- + +data GameEnv = GameEnv + { _eventChan :: BChan AppEvent + , _config :: Config + } + deriving stock (Generic) +makeLenses ''GameEnv diff --git a/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs b/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs new file mode 100644 index 0000000000..c692a3b479 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Lenses.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Lenses + ( clearMemo + , positionedCharacter + , character + , characterPosition + , updateCharacterVision + , characterVisiblePositions + , characterVisibleEntities + , positionIsCharacterVisible + , getInitialState + , initialStateFromSeed + , entitiesAtCharacter + , revealedEntitiesAtPosition + , hearingRadius + + -- * Collisions + , Collision(..) + , entitiesCollision + , collisionAt + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import System.Random +import Control.Monad.State +import Control.Monad.Random (getRandom) +-------------------------------------------------------------------------------- +import Xanthous.Game.State +import qualified Xanthous.Game.Memo as Memo +import Xanthous.Data +import Xanthous.Data.Levels +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Data.EntityMap.Graphics + (visiblePositions, visibleEntities) +import Xanthous.Data.VectorBag +import Xanthous.Entities.Character (Character, mkCharacter) +import {-# SOURCE #-} Xanthous.Entities.Entities () +import Xanthous.Game.Memo (emptyMemoState, MemoState) +import Xanthous.Data.Memo (fillWithM, Memoized) +-------------------------------------------------------------------------------- + +getInitialState :: IO GameState +getInitialState = initialStateFromSeed <$> getRandom + +initialStateFromSeed :: Int -> GameState +initialStateFromSeed seed = + let _randomGen = mkStdGen seed + chr = mkCharacter + _upStaircasePosition = Position 0 0 + (_characterEntityID, _levelEntities) + = EntityMap.insertAtReturningID + _upStaircasePosition + (SomeEntity chr) + mempty + _levelRevealedPositions = mempty + level = GameLevel {..} + _levels = oneLevel level + _messageHistory = mempty + _promptState = NoPrompt + _activePanel = Nothing + _debugState = DebugState + { _allRevealed = False + } + _savefile = Nothing + _autocommand = NoAutocommand + _memo = emptyMemoState + in GameState {..} + +clearMemo :: MonadState GameState m => Lens' MemoState (Memoized k v) -> m () +clearMemo l = memo %= Memo.clear l + +positionedCharacter :: Lens' GameState (Positioned Character) +positionedCharacter = lens getPositionedCharacter setPositionedCharacter + where + setPositionedCharacter :: GameState -> Positioned Character -> GameState + setPositionedCharacter game chr + = game + & entities . at (game ^. characterEntityID) + ?~ fmap SomeEntity chr + + getPositionedCharacter :: GameState -> Positioned Character + getPositionedCharacter game + = over positioned + ( fromMaybe (error "Invariant error: Character was not a character!") + . downcastEntity + ) + . fromMaybe (error "Invariant error: Character not found!") + $ EntityMap.lookupWithPosition + (game ^. characterEntityID) + (game ^. entities) + + +character :: Lens' GameState Character +character = positionedCharacter . positioned + +characterPosition :: Lens' GameState Position +characterPosition = positionedCharacter . position + +-- TODO make this dynamic +visionRadius :: Word +visionRadius = 12 + +-- TODO make this dynamic +hearingRadius :: Word +hearingRadius = 12 + +-- | Update the revealed entities at the character's position based on their +-- vision +updateCharacterVision :: GameState -> GameState +updateCharacterVision = execState $ do + positions <- characterVisiblePositions + revealedPositions <>= positions + +characterVisiblePositions :: MonadState GameState m => m (Set Position) +characterVisiblePositions = do + charPos <- use characterPosition + fillWithM + (memo . Memo.characterVisiblePositions) + charPos + (uses entities $ visiblePositions charPos visionRadius) + +characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity +characterVisibleEntities game = + let charPos = game ^. characterPosition + in visibleEntities charPos visionRadius $ game ^. entities + +positionIsCharacterVisible :: MonadState GameState m => Position -> m Bool +positionIsCharacterVisible p = (p `elem`) <$> characterVisiblePositions +-- ^ TODO optimize + +entitiesCollision + :: ( Functor f + , forall xx. MonoFoldable (f xx) + , Element (f SomeEntity) ~ SomeEntity + , Element (f (Maybe Collision)) ~ Maybe Collision + , Show (f (Maybe Collision)) + , Show (f SomeEntity) + ) + => f SomeEntity + -> Maybe Collision +entitiesCollision = join . maximumMay . fmap entityCollision + +collisionAt :: MonadState GameState m => Position -> m (Maybe Collision) +collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision + +entitiesAtCharacter :: Lens' GameState (VectorBag SomeEntity) +entitiesAtCharacter = lens getter setter + where + getter gs = gs ^. entities . EntityMap.atPosition (gs ^. characterPosition) + setter gs ents = gs + & entities . EntityMap.atPosition (gs ^. characterPosition) .~ ents + +-- | Returns all entities at the given position that are revealed to the +-- character. +-- +-- Concretely, this is either entities that are *currently* visible to the +-- character, or entities, that are immobile and that the character has seen +-- before +revealedEntitiesAtPosition + :: MonadState GameState m + => Position + -> m (VectorBag SomeEntity) +revealedEntitiesAtPosition p = do + allRev <- use $ debugState . allRevealed + cvps <- characterVisiblePositions + entitiesAtPosition <- use $ entities . EntityMap.atPosition p + revealed <- use revealedPositions + let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition + pure $ if | allRev || p `member` cvps + -> entitiesAtPosition + | p `member` revealed + -> immobileEntitiesAtPosition + | otherwise + -> mempty diff --git a/users/aspen/xanthous/src/Xanthous/Game/Memo.hs b/users/aspen/xanthous/src/Xanthous/Game/Memo.hs new file mode 100644 index 0000000000..154063b5dd --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Memo.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +-- | Memoized versions of calculations +-------------------------------------------------------------------------------- +module Xanthous.Game.Memo + ( MemoState + , emptyMemoState + , clear + -- ** Memo lenses + , characterVisiblePositions + + -- * Memoized values + , Memoized(UnMemoized) + , memoizeWith + , getMemoized + , runMemoized + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson.Generic.DerivingVia +import Test.QuickCheck (CoArbitrary, Function, Arbitrary) +-------------------------------------------------------------------------------- +import Xanthous.Data (Position) +import Xanthous.Data.Memo +import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary)) +-------------------------------------------------------------------------------- + +-- | Memoized calculations on the game state +data MemoState = MemoState + { -- | Memoized version of 'Xanthous.Game.Lenses.characterVisiblePositions', + -- memoized with the position of the character + _characterVisiblePositions :: Memoized Position (Set Position) + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary MemoState + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + MemoState +makeLenses ''MemoState + +emptyMemoState :: MemoState +emptyMemoState = MemoState { _characterVisiblePositions = UnMemoized } +{-# INLINE emptyMemoState #-} + +clear :: ASetter' MemoState (Memoized key val) -> MemoState -> MemoState +clear = flip set UnMemoized +{-# INLINE clear #-} + +{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs b/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs new file mode 100644 index 0000000000..2d6c0a280f --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/Prompt.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Prompt + ( PromptType(..) + , SPromptType(..) + , SingPromptType(..) + , PromptCancellable(..) + , PromptResult(..) + , PromptState(..) + , promptStatePosition + , MenuOption(..) + , mkMenuItems + , PromptInput + , Prompt(..) + , mkPrompt + , mkStringPrompt + , mkStringPromptWithDefault + , mkMenu + , mkPointOnMapPrompt + , mkFirePrompt + , isCancellable + , submitPrompt + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.Widgets.Edit (Editor, editorText, getEditContents) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Util (smallestNotIn, AlphaChar (..)) +import Xanthous.Data (Direction, Position, Tiles) +import Xanthous.Data.App (ResourceName) +import qualified Xanthous.Data.App as Resource +-------------------------------------------------------------------------------- + +data PromptType where + StringPrompt :: PromptType + Confirm :: PromptType + Menu :: Type -> PromptType + DirectionPrompt :: PromptType + PointOnMap :: PromptType + -- | Throw an item or fire a projectile weapon. Prompt is to select the + -- direction + Fire :: PromptType + Continue :: PromptType + deriving stock (Generic) + +instance Show PromptType where + show StringPrompt = "StringPrompt" + show Confirm = "Confirm" + show (Menu _) = "Menu" + show DirectionPrompt = "DirectionPrompt" + show PointOnMap = "PointOnMap" + show Continue = "Continue" + show Fire = "Fire" + +data SPromptType :: PromptType -> Type where + SStringPrompt :: SPromptType 'StringPrompt + SConfirm :: SPromptType 'Confirm + SMenu :: SPromptType ('Menu a) + SDirectionPrompt :: SPromptType 'DirectionPrompt + SPointOnMap :: SPromptType 'PointOnMap + SContinue :: SPromptType 'Continue + SFire :: SPromptType 'Fire + +instance NFData (SPromptType pt) where + rnf SStringPrompt = () + rnf SConfirm = () + rnf SMenu = () + rnf SDirectionPrompt = () + rnf SPointOnMap = () + rnf SContinue = () + rnf SFire = () + +class SingPromptType pt where singPromptType :: SPromptType pt +instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt +instance SingPromptType 'Confirm where singPromptType = SConfirm +instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt +instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap +instance SingPromptType 'Continue where singPromptType = SContinue +instance SingPromptType 'Fire where singPromptType = SFire + +instance Show (SPromptType pt) where + show SStringPrompt = "SStringPrompt" + show SConfirm = "SConfirm" + show SMenu = "SMenu" + show SDirectionPrompt = "SDirectionPrompt" + show SPointOnMap = "SPointOnMap" + show SContinue = "SContinue" + show SFire = "SFire" + +data PromptCancellable + = Cancellable + | Uncancellable + deriving stock (Show, Eq, Ord, Enum, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Arbitrary PromptCancellable where + arbitrary = genericArbitrary + +data PromptResult (pt :: PromptType) where + StringResult :: Text -> PromptResult 'StringPrompt + ConfirmResult :: Bool -> PromptResult 'Confirm + MenuResult :: forall a. a -> PromptResult ('Menu a) + DirectionResult :: Direction -> PromptResult 'DirectionPrompt + PointOnMapResult :: Position -> PromptResult 'PointOnMap + FireResult :: Position -> PromptResult 'Fire + ContinueResult :: PromptResult 'Continue + +instance Arbitrary (PromptResult 'StringPrompt) where + arbitrary = StringResult <$> arbitrary + +instance Arbitrary (PromptResult 'Confirm) where + arbitrary = ConfirmResult <$> arbitrary + +instance Arbitrary a => Arbitrary (PromptResult ('Menu a)) where + arbitrary = MenuResult <$> arbitrary + +instance Arbitrary (PromptResult 'DirectionPrompt) where + arbitrary = DirectionResult <$> arbitrary + +instance Arbitrary (PromptResult 'PointOnMap) where + arbitrary = PointOnMapResult <$> arbitrary + +instance Arbitrary (PromptResult 'Continue) where + arbitrary = pure ContinueResult + +instance Arbitrary (PromptResult 'Fire) where + arbitrary = FireResult <$> arbitrary + +-------------------------------------------------------------------------------- + +data PromptState pt where + StringPromptState + :: Editor Text ResourceName -> PromptState 'StringPrompt + DirectionPromptState :: PromptState 'DirectionPrompt + ContinuePromptState :: PromptState 'Continue + ConfirmPromptState :: PromptState 'Confirm + MenuPromptState :: forall a. PromptState ('Menu a) + PointOnMapPromptState :: Position -> PromptState 'PointOnMap + FirePromptState :: Position -> PromptState 'Fire + +instance NFData (PromptState pt) where + rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` () + rnf DirectionPromptState = () + rnf ContinuePromptState = () + rnf ConfirmPromptState = () + rnf MenuPromptState = () + rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` () + rnf fps@(FirePromptState pos) = fps `deepseq` pos `deepseq` () + +instance Arbitrary (PromptState 'StringPrompt) where + arbitrary = StringPromptState <$> arbitrary + +instance Arbitrary (PromptState 'DirectionPrompt) where + arbitrary = pure DirectionPromptState + +instance Arbitrary (PromptState 'Continue) where + arbitrary = pure ContinuePromptState + +instance Arbitrary (PromptState ('Menu a)) where + arbitrary = pure MenuPromptState + +instance Arbitrary (PromptState 'Fire) where + arbitrary = FirePromptState <$> arbitrary + +instance CoArbitrary (PromptState 'StringPrompt) where + coarbitrary (StringPromptState ed) = coarbitrary ed + +instance CoArbitrary (PromptState 'DirectionPrompt) where + coarbitrary DirectionPromptState = coarbitrary () + +instance CoArbitrary (PromptState 'Continue) where + coarbitrary ContinuePromptState = coarbitrary () + +instance CoArbitrary (PromptState ('Menu a)) where + coarbitrary MenuPromptState = coarbitrary () + +instance CoArbitrary (PromptState 'Fire) where + coarbitrary (FirePromptState pos) = coarbitrary pos + +deriving stock instance Show (PromptState pt) + +-- | Traversal over the position for the prompt types with positions in their +-- prompt state (currently 'Fire' and 'PointOnMap') +promptStatePosition :: forall pt. Traversal' (PromptState pt) Position +promptStatePosition _ ps@(StringPromptState _) = pure ps +promptStatePosition _ DirectionPromptState = pure DirectionPromptState +promptStatePosition _ ContinuePromptState = pure ContinuePromptState +promptStatePosition _ ConfirmPromptState = pure ConfirmPromptState +promptStatePosition _ MenuPromptState = pure MenuPromptState +promptStatePosition f (PointOnMapPromptState p) = PointOnMapPromptState <$> f p +promptStatePosition f (FirePromptState p) = FirePromptState <$> f p + +data MenuOption a = MenuOption Text a + deriving stock (Eq, Generic, Functor) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Comonad MenuOption where + extract (MenuOption _ x) = x + extend cok mo@(MenuOption text _) = MenuOption text (cok mo) + +mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a)) + => f + -> Map Char (MenuOption a) +mkMenuItems = flip foldl' mempty $ \items (chr, option) -> + let chr' = if has (ix chr) items + then getAlphaChar . smallestNotIn . map AlphaChar $ keys items + else chr + in items & at chr' ?~ option + +instance Show (MenuOption a) where + show (MenuOption m _) = show m + +type family PromptInput (pt :: PromptType) :: Type where + PromptInput ('Menu a) = Map Char (MenuOption a) + PromptInput 'PointOnMap = Position -- Character pos + PromptInput 'Fire = (Position, Tiles) -- Nearest enemy, range + PromptInput 'StringPrompt = Maybe Text -- Default value + PromptInput _ = () + +data Prompt (m :: Type -> Type) where + Prompt + :: forall (pt :: PromptType) + (m :: Type -> Type). + PromptCancellable + -> SPromptType pt + -> PromptState pt + -> PromptInput pt + -> (PromptResult pt -> m ()) + -> Prompt m + +instance Show (Prompt m) where + show (Prompt c pt ps pri _) + = "(Prompt " + <> show c <> " " + <> show pt <> " " + <> show ps <> " " + <> showPri + <> " <function>)" + where showPri = case pt of + SMenu -> show pri + _ -> "()" + +instance NFData (Prompt m) where + rnf (Prompt c SMenu ps pri cb) + = c + `deepseq` ps + `deepseq` pri + `seq` cb + `seq` () + rnf (Prompt c spt ps pri cb) + = c + `deepseq` spt + `deepseq` ps + `deepseq` pri + `seq` cb + `seq` () + +instance CoArbitrary (m ()) => CoArbitrary (Prompt m) where + coarbitrary (Prompt c SStringPrompt ps pri cb) = + variant @Int 1 . coarbitrary (c, ps, pri, cb) + coarbitrary (Prompt c SConfirm _ pri cb) = -- TODO fill in prompt state + variant @Int 2 . coarbitrary (c, pri, cb) + coarbitrary (Prompt c SMenu _ps _pri _cb) = + variant @Int 3 . coarbitrary c {-, ps, pri, cb -} + coarbitrary (Prompt c SDirectionPrompt ps pri cb) = + variant @Int 4 . coarbitrary (c, ps, pri, cb) + coarbitrary (Prompt c SPointOnMap _ pri cb) = -- TODO fill in prompt state + variant @Int 5 . coarbitrary (c, pri, cb) + coarbitrary (Prompt c SContinue ps pri cb) = + variant @Int 6 . coarbitrary (c, ps, pri, cb) + coarbitrary (Prompt c SFire ps pri cb) = + variant @Int 7 . coarbitrary (c, ps, pri, cb) + +-- instance Function (Prompt m) where +-- function = functionMap toTuple _fromTuple +-- where +-- toTuple (Prompt c pt ps pri cb) = (c, pt, ps, pri, cb) + + +mkPrompt + :: (PromptInput pt ~ ()) + => PromptCancellable -- ^ Is the prompt cancellable or not? + -> SPromptType pt -- ^ The type of the prompt + -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete + -> Prompt m +mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb +mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb +mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb + +mkStringPrompt + :: PromptCancellable -- ^ Is the prompt cancellable or not? + -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete + -> Prompt m +mkStringPrompt c = + let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" + in Prompt c SStringPrompt ps Nothing + +mkStringPromptWithDefault + :: PromptCancellable -- ^ Is the prompt cancellable or not? + -> Text -- ^ Default value for the prompt + -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete + -> Prompt m +mkStringPromptWithDefault c def = + let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" + in Prompt c SStringPrompt ps (Just def) + +mkMenu + :: forall a m. + PromptCancellable + -> Map Char (MenuOption a) -- ^ Menu items + -> (PromptResult ('Menu a) -> m ()) + -> Prompt m +mkMenu c = Prompt c SMenu MenuPromptState + +mkPointOnMapPrompt + :: PromptCancellable + -> Position + -> (PromptResult 'PointOnMap -> m ()) + -> Prompt m +mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos + +mkFirePrompt + :: PromptCancellable + -> Position -- ^ Initial position + -> Tiles -- ^ Range + -> (PromptResult 'Fire -> m ()) + -> Prompt m +mkFirePrompt c pos range = Prompt c SFire (FirePromptState pos) (pos, range) + +isCancellable :: Prompt m -> Bool +isCancellable (Prompt Cancellable _ _ _ _) = True +isCancellable (Prompt Uncancellable _ _ _ _) = False + +submitPrompt :: Applicative m => Prompt m -> m () +submitPrompt (Prompt _ pt ps pri cb) = + case (pt, ps, pri) of + (SStringPrompt, StringPromptState edit, mDef) -> + let inputVal = mconcat . getEditContents $ edit + val | null inputVal, Just def <- mDef = def + | otherwise = inputVal + in cb $ StringResult val + (SDirectionPrompt, DirectionPromptState, _) -> + pure () -- Don't use submit with a direction prompt + (SContinue, ContinuePromptState, _) -> + cb ContinueResult + (SMenu, MenuPromptState, _) -> + pure () -- Don't use submit with a menu prompt + (SPointOnMap, PointOnMapPromptState pos, _) -> + cb $ PointOnMapResult pos + (SConfirm, ConfirmPromptState, _) -> + cb $ ConfirmResult True + (SFire, FirePromptState pos, _) -> + cb $ FireResult pos diff --git a/users/aspen/xanthous/src/Xanthous/Game/State.hs b/users/aspen/xanthous/src/Xanthous/Game/State.hs new file mode 100644 index 0000000000..13b1ba1588 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Game/State.hs @@ -0,0 +1,572 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.State + ( GameState(..) + , entities + , levels + , revealedPositions + , messageHistory + , randomGen + , activePanel + , promptState + , characterEntityID + , autocommand + , savefile + , memo + , GamePromptState(..) + + -- * Game Level + , GameLevel(..) + , levelEntities + , upStaircasePosition + , levelRevealedPositions + + -- * Messages + , MessageHistory(..) + , HasMessages(..) + , HasTurn(..) + , HasDisplayedTurn(..) + , pushMessage + , previousMessage + , nextTurn + + -- * Autocommands + , Autocommand(..) + , AutocommandState(..) + , _NoAutocommand + , _ActiveAutocommand + + -- * App monad + , AppT(..) + , AppM + , runAppT + + -- * Entities + , Draw(..) + , Brain(..) + , Brainless(..) + , brainVia + , Collision(..) + , Entity(..) + , SomeEntity(..) + , downcastEntity + , _SomeEntity + , entityIs + , entityTypeName + + -- ** Vias + , Color(..) + , DrawNothing(..) + , DrawRawChar(..) + , DrawRawCharPriority(..) + , DrawCharacter(..) + , DrawStyledCharacter(..) + , DeriveEntity(..) + -- ** Field classes + , HasChar(..) + , HasStyle(..) + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.List.NonEmpty ( NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Typeable +import Data.Coerce +import System.Random +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +import Control.Monad.Random.Class +import Control.Monad.State +import Control.Monad.Trans.Control (MonadTransControl(..)) +import Control.Monad.Trans.Compose +import Control.Monad.Morph (MFunctor(..)) +import Brick (EventM, Widget, raw, str, emptyWidget) +import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) +import qualified Data.Aeson as JSON +import Data.Aeson.Generic.DerivingVia +import Data.Generics.Product.Fields +import qualified Graphics.Vty.Attributes as Vty +import qualified Graphics.Vty.Image as Vty +-------------------------------------------------------------------------------- +import Xanthous.Util (KnownBool(..)) +import Xanthous.Data +import Xanthous.Data.App +import Xanthous.Data.Levels +import Xanthous.Data.EntityMap (EntityMap, EntityID) +import Xanthous.Data.EntityChar +import Xanthous.Data.VectorBag +import Xanthous.Data.Entities +import Xanthous.Orphans () +import Xanthous.Game.Prompt +import Xanthous.Game.Env +import Xanthous.Game.Memo (MemoState) +-------------------------------------------------------------------------------- + +data MessageHistory + = MessageHistory + { _messages :: Map Word (NonEmpty Text) + , _turn :: Word + , _displayedTurn :: Maybe Word + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary MessageHistory + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + MessageHistory +makeFieldsNoPrefix ''MessageHistory + +instance Semigroup MessageHistory where + (MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) = + MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of + (_, Nothing) -> Nothing + (Just t, _) -> Just t + (Nothing, Just t) -> Just t + +instance Monoid MessageHistory where + mempty = MessageHistory mempty 0 Nothing + +type instance Element MessageHistory = [Text] +instance MonoFunctor MessageHistory where + omap f mh@(MessageHistory _ t _) = + mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<) + +instance MonoComonad MessageHistory where + oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt) + oextend cok mh@(MessageHistory _ t dt) = + mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh) + +pushMessage :: Text -> MessageHistory -> MessageHistory +pushMessage msg mh@(MessageHistory _ turn' _) = + mh + & messages . at turn' %~ \case + Nothing -> Just $ msg :| mempty + Just msgs -> Just $ msg <| msgs + & displayedTurn .~ Nothing + +nextTurn :: MessageHistory -> MessageHistory +nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing) + +previousMessage :: MessageHistory -> MessageHistory +previousMessage mh = mh & displayedTurn .~ maximumOf + (messages . ifolded . asIndex . filtered (< mh ^. turn)) + mh + + +-------------------------------------------------------------------------------- + +data GamePromptState m where + NoPrompt :: GamePromptState m + WaitingPrompt :: Text -> Prompt m -> GamePromptState m + deriving stock (Show, Generic) + deriving anyclass (NFData) + +-- | Non-injective! We never try to serialize waiting prompts, since: +-- +-- * they contain callback functions +-- * we can't save the game when in a prompt anyway +instance ToJSON (GamePromptState m) where + toJSON _ = Null + +-- | Always expects Null +instance FromJSON (GamePromptState m) where + parseJSON Null = pure NoPrompt + parseJSON _ = fail "Invalid GamePromptState; expected null" + +instance CoArbitrary (GamePromptState m) where + coarbitrary NoPrompt = variant @Int 1 + coarbitrary (WaitingPrompt txt _) = variant @Int 2 . coarbitrary txt + +instance Function (GamePromptState m) where + function = functionMap onlyNoPrompt (const NoPrompt) + where + onlyNoPrompt NoPrompt = () + onlyNoPrompt (WaitingPrompt _ _) = + error "Can't handle prompts in Function!" + +-------------------------------------------------------------------------------- + +newtype AppT m a + = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a } + deriving ( Functor + , Applicative + , Monad + , MonadState GameState + , MonadReader GameEnv + , MonadIO + ) + via (ReaderT GameEnv (StateT GameState m)) + deriving ( MonadTrans + , MFunctor + ) + via (ReaderT GameEnv `ComposeT` StateT GameState) + +type AppM = AppT (EventM ResourceName) + +-------------------------------------------------------------------------------- + +class Draw a where + drawWithNeighbors :: Neighbors (VectorBag SomeEntity) -> a -> Widget n + drawWithNeighbors = const draw + + draw :: a -> Widget n + draw = drawWithNeighbors $ pure mempty + + -- | higher priority gets drawn on top + drawPriority :: a -> Word + drawPriority = const minBound + +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 + +instance KnownSymbol char => Draw (DrawCharacter char a) where + draw _ = str $ symbolVal @char Proxy + +data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + +class KnownColor (color :: Color) where + colorVal :: forall proxy. proxy color -> Vty.Color + +instance KnownColor 'Black where colorVal _ = Vty.black +instance KnownColor 'Red where colorVal _ = Vty.red +instance KnownColor 'Green where colorVal _ = Vty.green +instance KnownColor 'Yellow where colorVal _ = Vty.yellow +instance KnownColor 'Blue where colorVal _ = Vty.blue +instance KnownColor 'Magenta where colorVal _ = Vty.magenta +instance KnownColor 'Cyan where colorVal _ = Vty.cyan +instance KnownColor 'White where colorVal _ = Vty.white + +class KnownMaybeColor (maybeColor :: Maybe Color) where + maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color + +instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing +instance KnownColor color => KnownMaybeColor ('Just color) where + maybeColorVal _ = Just $ colorVal @color Proxy + +newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where + DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a + +instance + ( KnownMaybeColor fg + , KnownMaybeColor bg + , KnownSymbol char + ) + => Draw (DrawStyledCharacter fg bg char a) where + draw _ = raw $ Vty.string attr $ symbolVal @char Proxy + where attr = Vty.Attr + { Vty.attrStyle = Vty.Default + , Vty.attrForeColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @fg Proxy + , Vty.attrBackColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @bg Proxy + , Vty.attrURL = Vty.Default + } + +instance Draw EntityChar where + draw EntityChar{..} = raw $ Vty.string _style [_char] + +-------------------------------------------------------------------------------- + +newtype DrawNothing (a :: Type) = DrawNothing a + +instance Draw (DrawNothing a) where + draw = const emptyWidget + drawPriority = const 0 + +newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a + +instance + forall rawField a raw. + ( HasField rawField a a raw raw + , HasChar raw EntityChar + ) => Draw (DrawRawChar rawField a) where + draw (DrawRawChar e) = draw $ e ^. field @rawField . char + +newtype DrawRawCharPriority + (rawField :: Symbol) + (priority :: Nat) + (a :: Type) + = DrawRawCharPriority a + +instance + forall rawField priority a raw. + ( HasField rawField a a raw raw + , KnownNat priority + , HasChar raw EntityChar + ) => Draw (DrawRawCharPriority rawField priority a) where + draw (DrawRawCharPriority e) = draw $ e ^. field @rawField . char + drawPriority = const . fromIntegral $ natVal @priority Proxy + + +-------------------------------------------------------------------------------- + +class Brain a where + step :: Ticks -> Positioned a -> AppM (Positioned a) + -- | Does this entity ever move on its own? + entityCanMove :: a -> Bool + entityCanMove = const False + +newtype Brainless a = Brainless a + +instance Brain (Brainless a) where + step = const pure + +-- | Workaround for the inability to use DerivingVia on Brain due to the lack of +-- higher-order roles (specifically AppT not having its last type argument have +-- role representational bc of StateT) +brainVia + :: forall brain entity. (Coercible entity brain, Brain brain) + => (entity -> brain) -- ^ constructor, ignored + -> (Ticks -> Positioned entity -> AppM (Positioned entity)) +brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain) + +-------------------------------------------------------------------------------- + +class ( Show a, Eq a, Ord a, NFData a + , ToJSON a, FromJSON a + , Draw a, Brain a + ) => Entity a where + entityAttributes :: a -> EntityAttributes + entityAttributes = const defaultEntityAttributes + description :: a -> Text + entityChar :: a -> EntityChar + entityCollision :: a -> Maybe Collision + entityCollision = const $ Just Stop + +data SomeEntity where + SomeEntity :: forall a. (Entity a, Typeable a) => a -> SomeEntity + +instance Show SomeEntity where + show (SomeEntity e) = "SomeEntity (" <> show e <> ")" + +instance Eq SomeEntity where + (SomeEntity (a :: ea)) == (SomeEntity (b :: eb)) = case eqT @ea @eb of + Just Refl -> a == b + _ -> False + +instance Ord SomeEntity where + compare (SomeEntity (a :: ea)) (SomeEntity (b :: eb)) = case eqT @ea @eb of + Just Refl -> compare a b + _ -> compare (typeRep $ Proxy @ea) (typeRep $ Proxy @eb) + + +instance NFData SomeEntity where + rnf (SomeEntity ent) = ent `deepseq` () + +instance ToJSON SomeEntity where + toJSON (SomeEntity ent) = entityToJSON ent + where + entityToJSON :: forall entity. (Entity entity, Typeable entity) + => entity -> JSON.Value + entityToJSON entity = JSON.object + [ "type" JSON..= tshow (typeRep @_ @entity Proxy) + , "data" JSON..= toJSON entity + ] + +instance Draw SomeEntity where + drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent + drawPriority (SomeEntity ent) = drawPriority ent + +instance Brain SomeEntity where + step ticks (Positioned p (SomeEntity ent)) = + fmap SomeEntity <$> step ticks (Positioned p ent) + entityCanMove (SomeEntity ent) = entityCanMove ent + +downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a +downcastEntity (SomeEntity e) = cast e + +entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool +entityIs = isJust . downcastEntity @a + +_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a +_SomeEntity = prism' SomeEntity downcastEntity + +-- | Get the name of the type of 'SomeEntity' as a string +entityTypeName :: SomeEntity -> Text +entityTypeName (SomeEntity e) = pack . tyConName . typeRepTyCon $ typeOf e + +newtype DeriveEntity + (blocksVision :: Bool) + (description :: Symbol) + (entityChar :: Symbol) + (entity :: Type) + = DeriveEntity entity + deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw) + +instance Brain entity => Brain (DeriveEntity b d c entity) where + step = brainVia $ \(DeriveEntity e) -> e + +instance + ( KnownBool blocksVision + , KnownSymbol description + , KnownSymbol entityChar + , Show entity, Eq entity, Ord entity, NFData entity + , ToJSON entity, FromJSON entity + , Draw entity, Brain entity + ) + => Entity (DeriveEntity blocksVision description entityChar entity) where + entityAttributes _ = defaultEntityAttributes + & blocksVision .~ boolVal @blocksVision + description _ = pack . symbolVal $ Proxy @description + entityChar _ = fromString . symbolVal $ Proxy @entityChar + +-------------------------------------------------------------------------------- + +data GameLevel = GameLevel + { _levelEntities :: !(EntityMap SomeEntity) + , _upStaircasePosition :: !Position + , _levelRevealedPositions :: !(Set Position) + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (ToJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + GameLevel + +-------------------------------------------------------------------------------- + +data Autocommand + = AutoMove Direction + | AutoRest + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Autocommand +{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} + +data AutocommandState + = NoAutocommand + | ActiveAutocommand Autocommand (Async ()) + deriving stock (Eq, Ord, Generic) + deriving anyclass (Hashable) + +instance Show AutocommandState where + show NoAutocommand = "NoAutocommand" + show (ActiveAutocommand ac _) = + "(ActiveAutocommand " <> show ac <> " <Async>)" + +instance ToJSON AutocommandState where + toJSON = const Null + +instance FromJSON AutocommandState where + parseJSON Null = pure NoAutocommand + parseJSON _ = fail "Invalid AutocommandState; expected null" + +instance NFData AutocommandState where + rnf NoAutocommand = () + rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` () + +instance CoArbitrary AutocommandState where + coarbitrary NoAutocommand = variant @Int 1 + coarbitrary (ActiveAutocommand ac t) + = variant @Int 2 + . coarbitrary ac + . coarbitrary (hash t) + +instance Function AutocommandState where + function = functionMap onlyNoAC (const NoAutocommand) + where + onlyNoAC NoAutocommand = () + onlyNoAC _ = error "Can't handle autocommands in Function" + +-------------------------------------------------------------------------------- + + +data DebugState = DebugState + { _allRevealed :: !Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + DebugState +{-# ANN DebugState ("HLint: ignore Use newtype instead of data" :: String) #-} + +instance Arbitrary DebugState where + arbitrary = genericArbitrary + +data GameState = GameState + { _levels :: !(Levels GameLevel) + , _characterEntityID :: !EntityID + , _messageHistory :: !MessageHistory + , _randomGen :: !StdGen + + -- | The active panel displayed in the UI, if any + , _activePanel :: !(Maybe Panel) + + , _promptState :: !(GamePromptState AppM) + , _debugState :: !DebugState + , _autocommand :: !AutocommandState + + -- | The path to the savefile that was loaded for this game, if any + , _savefile :: !(Maybe FilePath) + + , _memo :: MemoState + } + deriving stock (Show, Generic) + deriving anyclass (NFData) + deriving (ToJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + GameState + +makeLenses ''GameLevel +makeLenses ''GameState + +entities :: Lens' GameState (EntityMap SomeEntity) +entities = levels . current . levelEntities + +revealedPositions :: Lens' GameState (Set Position) +revealedPositions = levels . current . levelRevealedPositions + +instance Eq GameState where + (==) = (==) `on` \gs -> + ( gs ^. entities + , gs ^. revealedPositions + , gs ^. characterEntityID + , gs ^. messageHistory + , gs ^. activePanel + , gs ^. debugState + ) + +-------------------------------------------------------------------------------- + +runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState) +runAppT appt env initialState + = flip runStateT initialState + . flip runReaderT env + . unAppT + $ appt + +instance (Monad m) => MonadRandom (AppT m) where + getRandomR rng = randomGen %%= randomR rng + getRandom = randomGen %%= random + getRandomRs rng = uses randomGen $ randomRs rng + getRandoms = uses randomGen randoms + +instance MonadTransControl AppT where + type StT AppT a = (a, GameState) + liftWith f + = AppT + . ReaderT $ \e + -> StateT $ \s + -> (,s) <$> f (\action -> runAppT action e s) + restoreT = AppT . ReaderT . const . StateT . const + +-------------------------------------------------------------------------------- + +makeLenses ''DebugState +makePrisms ''AutocommandState diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level.hs new file mode 100644 index 0000000000..fc57402e7d --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level + ( generate + , Generator(..) + , SGenerator(..) + , GeneratorInput(..) + , generateFromInput + , parseGeneratorInput + , showCells + , Level(..) + , levelWalls + , levelItems + , levelCreatures + , levelDoors + , levelCharacterPosition + , levelTutorialMessage + , levelExtra + , generateLevel + , levelToEntityMap + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Data.Array.Unboxed +import qualified Options.Applicative as Opt +import Control.Monad.Random +-------------------------------------------------------------------------------- +import qualified Xanthous.Generators.Level.CaveAutomata as CaveAutomata +import qualified Xanthous.Generators.Level.Dungeon as Dungeon +import Xanthous.Generators.Level.Util +import Xanthous.Generators.Level.LevelContents +import Xanthous.Generators.Level.Village as Village +import Xanthous.Data (Dimensions, Position'(Position), Position) +import Xanthous.Data.EntityMap (EntityMap, _EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Environment +import Xanthous.Entities.Item (Item) +import Xanthous.Entities.Creature (Creature) +import Xanthous.Game.State (SomeEntity(..)) +import Linear.V2 +-------------------------------------------------------------------------------- + +data Generator + = CaveAutomata + | Dungeon + deriving stock (Show, Eq) + +data SGenerator (gen :: Generator) where + SCaveAutomata :: SGenerator 'CaveAutomata + SDungeon :: SGenerator 'Dungeon + +type family Params (gen :: Generator) :: Type where + Params 'CaveAutomata = CaveAutomata.Params + Params 'Dungeon = Dungeon.Params + +generate + :: RandomGen g + => SGenerator gen + -> Params gen + -> Dimensions + -> g + -> Cells +generate SCaveAutomata = CaveAutomata.generate +generate SDungeon = Dungeon.generate + +data GeneratorInput where + GeneratorInput :: forall gen. SGenerator gen -> Params gen -> GeneratorInput + +generateFromInput :: RandomGen g => GeneratorInput -> Dimensions -> g -> Cells +generateFromInput (GeneratorInput sg ps) = generate sg ps + +parseGeneratorInput :: Opt.Parser GeneratorInput +parseGeneratorInput = Opt.subparser + $ generatorCommand SCaveAutomata + "cave" + "Cellular-automata based cave generator" + CaveAutomata.parseParams + <> generatorCommand SDungeon + "dungeon" + "Classic dungeon map generator" + Dungeon.parseParams + where + generatorCommand sgen name desc parseParams = + Opt.command name + (Opt.info + (GeneratorInput sgen <$> parseParams) + (Opt.progDesc desc) + ) + + +showCells :: Cells -> Text +showCells arr = + let (V2 minX minY, V2 maxX maxY) = bounds arr + showCellVal True = "x" + showCellVal False = " " + showCell = showCellVal . (arr !) + row r = foldMap (showCell . (`V2` r)) [minX..maxX] + rows = row <$> [minY..maxY] + in intercalate "\n" rows + +cellsToWalls :: Cells -> EntityMap Wall +cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells + where + maybeInsertWall em (pos@(V2 x y), True) + | not (surroundedOnAllSides pos) = + let x' = fromIntegral x + y' = fromIntegral y + in EntityMap.insertAt (Position x' y') Wall em + maybeInsertWall em _ = em + surroundedOnAllSides pos = numAliveNeighbors cells pos == 8 + +-------------------------------------------------------------------------------- + +data Level = Level + { _levelWalls :: !(EntityMap Wall) + , _levelDoors :: !(EntityMap Door) + , _levelItems :: !(EntityMap Item) + , _levelCreatures :: !(EntityMap Creature) + , _levelTutorialMessage :: !(EntityMap GroundMessage) + , _levelStaircases :: !(EntityMap Staircase) + , _levelExtra :: !(EntityMap SomeEntity) -- ^ TODO this is a bit of a hack... + , _levelCharacterPosition :: !Position + } + deriving stock (Generic) + deriving anyclass (NFData) +makeLenses ''Level + +generateLevel + :: MonadRandom m + => SGenerator gen + -> Params gen + -> Dimensions + -> Word -- ^ Level number, starting at 0 + -> m Level +generateLevel gen ps dims num = do + rand <- mkStdGen <$> getRandom + let cells = generate gen ps dims rand + _levelWalls = cellsToWalls cells + village <- generateVillage cells gen + let _levelExtra = village + _levelItems <- randomItems cells + _levelCreatures <- randomCreatures num cells + _levelDoors <- randomDoors cells + _levelCharacterPosition <- chooseCharacterPosition cells + let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)] + downStaircase <- placeDownStaircase cells + let _levelStaircases = upStaircase <> downStaircase + _levelTutorialMessage <- + if num == 0 + then tutorialMessage cells _levelCharacterPosition + else pure mempty + pure Level {..} + +levelToEntityMap :: Level -> EntityMap SomeEntity +levelToEntityMap level + = (SomeEntity <$> level ^. levelWalls) + <> (SomeEntity <$> level ^. levelDoors) + <> (SomeEntity <$> level ^. levelItems) + <> (SomeEntity <$> level ^. levelCreatures) + <> (SomeEntity <$> level ^. levelTutorialMessage) + <> (SomeEntity <$> level ^. levelStaircases) + <> (level ^. levelExtra) + +generateVillage + :: MonadRandom m + => Cells -- ^ Wall positions + -> SGenerator gen + -> m (EntityMap SomeEntity) +generateVillage wallPositions SCaveAutomata = Village.fromCave wallPositions +generateVillage _ _ = pure mempty diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs new file mode 100644 index 0000000000..03d534ca39 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.CaveAutomata + ( Params(..) + , defaultParams + , parseParams + , generate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Control.Monad.Random (RandomGen, runRandT) +import Data.Array.ST +import Data.Array.Unboxed +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- +import Xanthous.Util (between) +import Xanthous.Util.Optparse +import Xanthous.Data (Dimensions, width, height) +import Xanthous.Generators.Level.Util +import Linear.V2 +-------------------------------------------------------------------------------- + +data Params = Params + { _aliveStartChance :: Double + , _birthLimit :: Word + , _deathLimit :: Word + , _steps :: Word + } + deriving stock (Show, Eq, Generic) +makeLenses ''Params + +defaultParams :: Params +defaultParams = Params + { _aliveStartChance = 0.6 + , _birthLimit = 3 + , _deathLimit = 4 + , _steps = 4 + } + +parseParams :: Opt.Parser Params +parseParams = Params + <$> Opt.option parseChance + ( Opt.long "alive-start-chance" + <> Opt.value (defaultParams ^. aliveStartChance) + <> Opt.showDefault + <> Opt.help ( "Chance for each cell to start alive at the beginning of " + <> "the cellular automata" + ) + <> Opt.metavar "CHANCE" + ) + <*> Opt.option parseNeighbors + ( Opt.long "birth-limit" + <> Opt.value (defaultParams ^. birthLimit) + <> Opt.showDefault + <> Opt.help "Minimum neighbor count required for birth of a cell" + <> Opt.metavar "NEIGHBORS" + ) + <*> Opt.option parseNeighbors + ( Opt.long "death-limit" + <> Opt.value (defaultParams ^. deathLimit) + <> Opt.showDefault + <> Opt.help "Maximum neighbor count required for death of a cell" + <> Opt.metavar "NEIGHBORS" + ) + <*> Opt.option Opt.auto + ( Opt.long "steps" + <> Opt.value (defaultParams ^. steps) + <> Opt.showDefault + <> Opt.help "Number of generations to run the automata for" + <> Opt.metavar "STEPS" + ) + <**> Opt.helper + where + parseChance = readWithGuard + (between 0 1) + $ \res -> "Chance must be in the range [0,1], got: " <> show res + + parseNeighbors = readWithGuard + (between 0 8) + $ \res -> "Neighbors must be in the range [0,8], got: " <> show res + +generate :: RandomGen g => Params -> Dimensions -> g -> Cells +generate params dims gen + = runSTUArray + $ fmap fst + $ flip runRandT gen + $ generate' params dims + +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) +generate' params dims = do + cells <- randInitialize dims $ params ^. aliveStartChance + let steps' = params ^. steps + when (steps' > 0) + $ for_ [0 .. pred steps'] . const $ stepAutomata cells dims params + -- Remove all but the largest contiguous region of unfilled space + (_: smallerRegions) <- lift $ regions @UArray . amap not <$> freeze cells + lift $ fillAllM (fold smallerRegions) cells + lift $ fillOuterEdgesM cells + pure cells + +stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () +stepAutomata cells dims params = do + origCells <- lift $ cloneMArray @_ @(STUArray s) cells + for_ (range (0, V2 (dims ^. width) (dims ^. height))) $ \pos -> do + neighs <- lift $ numAliveNeighborsM origCells pos + origValue <- lift $ readArray origCells pos + lift . writeArray cells pos + $ if origValue + then neighs >= params ^. deathLimit + else neighs > params ^. birthLimit diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs new file mode 100644 index 0000000000..0be7c0435c --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Dungeon.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.Dungeon + ( Params(..) + , defaultParams + , parseParams + , generate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding ((:>)) +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.ST +import Data.Array.IArray (amap) +import Data.Stream.Infinite (Stream(..)) +import qualified Data.Stream.Infinite as Stream +import qualified Data.Graph.Inductive.Graph as Graph +import Data.Graph.Inductive.PatriciaTree +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Linear.V2 +import Linear.Metric +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- +import Xanthous.Random +import Xanthous.Data hiding (x, y, _x, _y, edges, distance) +import Xanthous.Generators.Level.Util +import Xanthous.Util.Graphics (delaunay, straightLine) +import Xanthous.Util.Graph (mstSubGraph) +-------------------------------------------------------------------------------- + +data Params = Params + { _numRoomsRange :: (Word, Word) + , _roomDimensionRange :: (Word, Word) + , _connectednessRatioRange :: (Double, Double) + } + deriving stock (Show, Eq, Ord, Generic) +makeLenses ''Params + +defaultParams :: Params +defaultParams = Params + { _numRoomsRange = (6, 8) + , _roomDimensionRange = (3, 12) + , _connectednessRatioRange = (0.1, 0.15) + } + +parseParams :: Opt.Parser Params +parseParams = Params + <$> parseRange + "num-rooms" + "number of rooms to generate in the dungeon" + "ROOMS" + (defaultParams ^. numRoomsRange) + <*> parseRange + "room-size" + "size in tiles of one of the sides of a room" + "TILES" + (defaultParams ^. roomDimensionRange) + <*> parseRange + "connectedness-ratio" + ( "ratio of edges from the delaunay triangulation to re-add to the " + <> "minimum-spanning-tree") + "RATIO" + (defaultParams ^. connectednessRatioRange) + <**> Opt.helper + where + parseRange name desc metavar (defMin, defMax) = + (,) + <$> Opt.option Opt.auto + ( Opt.long ("min-" <> name) + <> Opt.value defMin + <> Opt.showDefault + <> Opt.help ("Minimum " <> desc) + <> Opt.metavar metavar + ) + <*> Opt.option Opt.auto + ( Opt.long ("max-" <> name) + <> Opt.value defMax + <> Opt.showDefault + <> Opt.help ("Maximum " <> desc) + <> Opt.metavar metavar + ) + +generate :: RandomGen g => Params -> Dimensions -> g -> Cells +generate params dims gen + = amap not + $ runSTUArray + $ fmap fst + $ flip runRandT gen + $ generate' params dims + +-------------------------------------------------------------------------------- + +generate' :: RandomGen g => Params -> Dimensions -> CellM g s (MCells s) +generate' params dims = do + cells <- initializeEmpty dims + rooms <- genRooms params dims + for_ rooms $ fillRoom cells + + let fullRoomGraph = delaunayRoomGraph rooms + mst = mstSubGraph fullRoomGraph + mstEdges = Graph.edges mst + nonMSTEdges = filter (\(n₁, n₂, _) -> (n₁, n₂) `notElem` mstEdges) + $ Graph.labEdges fullRoomGraph + + reintroEdgeCount <- floor . (* fromIntegral (length nonMSTEdges)) + <$> getRandomR (params ^. connectednessRatioRange) + let reintroEdges = take reintroEdgeCount nonMSTEdges + corridorGraph = Graph.insEdges reintroEdges mst + + corridors <- traverse + ( uncurry corridorBetween + . over both (fromJust . Graph.lab corridorGraph) + ) $ Graph.edges corridorGraph + + for_ (join corridors) $ \pt -> lift $ writeArray cells pt True + + pure cells + +type Room = Box Word + +genRooms :: MonadRandom m => Params -> Dimensions -> m [Room] +genRooms params dims = do + numRooms <- fromIntegral <$> getRandomR (params ^. numRoomsRange) + subRand . fmap (Stream.take numRooms . removeIntersecting []) . infinitely $ do + roomWidth <- getRandomR $ params ^. roomDimensionRange + roomHeight <- getRandomR $ params ^. roomDimensionRange + xPos <- getRandomR (0, dims ^. width - roomWidth) + yPos <- getRandomR (0, dims ^. height - roomHeight) + pure Box + { _topLeftCorner = V2 xPos yPos + , _dimensions = V2 roomWidth roomHeight + } + where + removeIntersecting seen (room :> rooms) + | any (boxIntersects room) seen + = removeIntersecting seen rooms + | otherwise + = room :> removeIntersecting (room : seen) rooms + streamRepeat x = x :> streamRepeat x + infinitely = sequence . streamRepeat + +delaunayRoomGraph :: [Room] -> Gr Room Double +delaunayRoomGraph rooms = + Graph.insEdges edges . Graph.insNodes nodes $ Graph.empty + where + edges = map (\((n₁, room₁), (n₂, room₂)) -> (n₁, n₂, roomDist room₁ room₂)) + . over (mapped . both) snd + . delaunay @Double + . NE.fromList + . map (\p@(_, room) -> (boxCenter $ fromIntegral <$> room, p)) + $ nodes + nodes = zip [0..] rooms + roomDist = distance `on` (boxCenter . fmap fromIntegral) + +fillRoom :: MCells s -> Room -> CellM g s () +fillRoom cells room = + let V2 posx posy = room ^. topLeftCorner + V2 dimx dimy = room ^. dimensions + in for_ [posx .. posx + dimx] $ \x -> + for_ [posy .. posy + dimy] $ \y -> + lift $ writeArray cells (V2 x y) True + +corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word] +corridorBetween originRoom destinationRoom + = straightLine <$> origin <*> destination + where + origin = choose . NE.fromList =<< originEdge + destination = choose . NE.fromList =<< destinationEdge + originEdge = pickEdge originRoom originCorner + destinationEdge = pickEdge destinationRoom destinationCorner + pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner + originCorner = + case ( compare (originRoom ^. topLeftCorner . _x) + (destinationRoom ^. topLeftCorner . _x) + , compare (originRoom ^. topLeftCorner . _y) + (destinationRoom ^. topLeftCorner . _y) + ) of + (LT, LT) -> BottomRight + (LT, GT) -> TopRight + (GT, LT) -> BottomLeft + (GT, GT) -> TopLeft + + (EQ, LT) -> BottomLeft + (EQ, GT) -> TopRight + (GT, EQ) -> TopLeft + (LT, EQ) -> BottomRight + (EQ, EQ) -> TopLeft -- should never happen + + destinationCorner = opposite originCorner diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs new file mode 100644 index 0000000000..4f8a2f42ee --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/LevelContents.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE RecordWildCards #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.LevelContents + ( chooseCharacterPosition + , randomItems + , randomCreatures + , randomDoors + , placeDownStaircase + , tutorialMessage + , entityFromRaw + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (any, toList) +-------------------------------------------------------------------------------- +import Control.Monad.Random +import Data.Array.IArray (amap, bounds, rangeSize, (!)) +import qualified Data.Array.IArray as Arr +import Data.Foldable (any, toList) +import Linear.V2 +-------------------------------------------------------------------------------- +import Xanthous.Generators.Level.Util +import Xanthous.Random hiding (chance) +import qualified Xanthous.Random as Random +import Xanthous.Data + ( positionFromV2, Position, _Position + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) +import Xanthous.Data.EntityMap (EntityMap, _EntityMap) +import Xanthous.Entities.Raws (rawsWithType, RawType, raw) +import qualified Xanthous.Entities.Item as Item +import Xanthous.Entities.Item (Item) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Creature (Creature) +import Xanthous.Entities.Environment + (GroundMessage(..), Door(..), unlockedDoor, Staircase(..)) +import Xanthous.Messages (message_) +import Xanthous.Util.Graphics (circle) +import Xanthous.Entities.RawTypes +import Xanthous.Entities.Creature.Hippocampus (initialHippocampus) +import Xanthous.Entities.Common (inRightHand, asWieldedItem, wielded) +import Xanthous.Game.State (SomeEntity(SomeEntity)) +-------------------------------------------------------------------------------- + +chooseCharacterPosition :: MonadRandom m => Cells -> m Position +chooseCharacterPosition = randomPosition + +randomItems :: MonadRandom m => Cells -> m (EntityMap Item) +randomItems = randomEntities (fmap Identity . Item.newWithType) (0.0004, 0.001) + +placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase) +placeDownStaircase cells = do + pos <- randomPosition cells + pure $ _EntityMap # [(pos, DownStaircase)] + +randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) +randomDoors cells = do + doorRatio <- getRandomR subsetRange + let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) + doorPositions = + removeAdjacent . fmap positionFromV2 . take numDoors $ candidateCells + doors = zip doorPositions $ repeat unlockedDoor + pure $ _EntityMap # doors + where + removeAdjacent = + foldr (\pos acc -> + if pos `elem` (acc >>= toList . neighborPositions) + then acc + else pos : acc + ) [] + candidateCells = filter doorable $ Arr.indices cells + subsetRange = (0.8 :: Double, 1.0) + doorable pos = + not (fromMaybe True $ cells ^? ix pos) + && any (teeish . fmap (fromMaybe True)) + (rotations $ arrayNeighbors cells pos) + -- only generate doors at the *ends* of hallways, eg (where O is walkable, + -- X is a wall, and D is a door): + -- + -- O O O + -- X D X + -- O + teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) = + and [tl, t, tr, b] && (and . fmap not) [l, r] + +randomCreatures + :: MonadRandom m + => Word -- ^ Level number, starting at 0 + -> Cells + -> m (EntityMap Creature) +randomCreatures levelNumber + = randomEntities maybeNewCreature (0.0007, 0.002) + where + maybeNewCreature cType + | maybe True (canGenerate levelNumber) $ cType ^. generateParams + = Just <$> newCreatureWithType cType + | otherwise + = pure Nothing + +newCreatureWithType :: MonadRandom m => CreatureType -> m Creature +newCreatureWithType _creatureType = do + let _hitpoints = _creatureType ^. maxHitpoints + _hippocampus = initialHippocampus + + equipped <- fmap join + . traverse genEquipped + $ _creatureType + ^.. generateParams . _Just . equippedItem . _Just + let _inventory = maybe id (\ei -> wielded .~ inRightHand ei) (headMay equipped) mempty + pure Creature.Creature {..} + where + genEquipped cei = do + doGen <- Random.chance $ cei ^. chance + let entName = cei ^. entityName + itemType = + fromMaybe (error $ "raw \"" <> unpack entName <> "\" not of type Item") + . preview _Item + . fromMaybe (error $ "Could not find raw: " <> unpack entName) + $ raw entName + item <- Item.newWithType itemType + if doGen + then pure [fromMaybe (error $ "raw \"" <> unpack entName <> "\" not wieldable") + $ preview asWieldedItem item] + else pure [] + + +tutorialMessage :: MonadRandom m + => Cells + -> Position -- ^ CharacterPosition + -> m (EntityMap GroundMessage) +tutorialMessage cells characterPosition = do + let distance = 2 + pos <- fmap (fromMaybe (error "No valid positions for tutorial message?")) + . choose . ChooseElement + $ accessiblePositionsWithin distance cells characterPosition + msg <- message_ ["tutorial", "message1"] + pure $ _EntityMap # [(pos, GroundMessage msg)] + where + accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] + accessiblePositionsWithin dist valid pos = + review _Position + <$> filter + (\pt -> not $ valid ! (fromIntegral <$> pt)) + (circle (pos ^. _Position) dist) + +randomEntities + :: forall entity raw m t. (MonadRandom m, RawType raw, Functor t, Foldable t) + => (raw -> m (t entity)) + -> (Float, Float) + -> Cells + -> m (EntityMap entity) +randomEntities newWithType sizeRange cells = + case fromNullable $ rawsWithType @raw of + Nothing -> pure mempty + Just raws -> do + let len = rangeSize $ bounds cells + (numEntities :: Int) <- + floor . (* fromIntegral len) <$> getRandomR sizeRange + entities <- for [0..numEntities] $ const $ do + pos <- randomPosition cells + r <- choose raws + entities <- newWithType r + pure $ (pos, ) <$> entities + pure $ _EntityMap # (entities >>= toList) + +randomPosition :: MonadRandom m => Cells -> m Position +randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates + +-- cellCandidates :: Cells -> Cells +cellCandidates :: Cells -> Set (V2 Word) +cellCandidates + -- find the largest contiguous region of cells in the cave. + = maximumBy (compare `on` length) + . fromMaybe (error "No regions generated! this should never happen.") + . fromNullable + . regions + -- cells ends up with true = wall, we want true = can put an item here + . amap not + +entityFromRaw :: MonadRandom m => EntityRaw -> m SomeEntity +entityFromRaw (Creature ct) = SomeEntity <$> newCreatureWithType ct +entityFromRaw (Item it) = SomeEntity <$> Item.newWithType it diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs new file mode 100644 index 0000000000..0008eb965c --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Util.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.Util + ( MCells + , Cells + , CellM + , randInitialize + , initializeEmpty + , numAliveNeighborsM + , numAliveNeighbors + , fillOuterEdgesM + , cloneMArray + , floodFill + , regions + , fillAll + , fillAllM + , fromPoints + , fromPointsM + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Foldable, toList, for_) +-------------------------------------------------------------------------------- +import Data.Array.ST +import Data.Array.Unboxed +import Control.Monad.ST +import Control.Monad.Random +import Data.Monoid +import Data.Foldable (Foldable, toList, for_) +import qualified Data.Set as Set +import Data.Semigroup.Foldable +import Linear.V2 +-------------------------------------------------------------------------------- +import Xanthous.Util (foldlMapM', maximum1, minimum1) +import Xanthous.Data (Dimensions, width, height) +-------------------------------------------------------------------------------- + +type MCells s = STUArray s (V2 Word) Bool +type Cells = UArray (V2 Word) Bool +type CellM g s a = RandT g (ST s) a + +randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) +randInitialize dims aliveChance = do + res <- initializeEmpty dims + for_ [0..dims ^. width] $ \i -> + for_ [0..dims ^. height] $ \j -> do + val <- (>= aliveChance) <$> getRandomR (0, 1) + lift $ writeArray res (V2 i j) val + pure res + +initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) +initializeEmpty dims = + lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False + +-- | Returns the number of neighbors of the given point in the given array that +-- are True. +-- +-- Behavior if point is out-of-bounds for the array is undefined, but will not +-- error +numAliveNeighborsM + :: forall a i m + . (MArray a Bool m, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i + -> m Word +numAliveNeighborsM cells pt@(V2 x y) = do + cellBounds <- getBounds cells + getSum <$> foldlMapM' + (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) + neighborPositions + + where + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool + boundedGet bnds _ + | not (inRange bnds pt) + = pure True + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) + | (x <= minX && i < 0) + || (y <= minY && j < 0) + || (x >= maxX && i > 0) + || (y >= maxY && j > 0) + = pure True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in readArray cells $ V2 nx ny + +-- | Returns the number of neighbors of the given point in the given array that +-- are True. +-- +-- Behavior if point is out-of-bounds for the array is undefined, but will not +-- error +numAliveNeighbors + :: forall a i + . (IArray a Bool, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i + -> Word +numAliveNeighbors cells pt@(V2 x y) = + let cellBounds = bounds cells + in getSum $ foldMap + (Sum . fromIntegral . fromEnum . boundedGet cellBounds) + neighborPositions + + where + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool + boundedGet bnds _ + | not (inRange bnds pt) + = True + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) + | (x <= minX && i < 0) + || (y <= minY && j < 0) + || (x >= maxX && i > 0) + || (y >= maxY && j > 0) + = True + | otherwise = + let nx = fromIntegral $ fromIntegral x + i + ny = fromIntegral $ fromIntegral y + j + in cells ! V2 nx ny + +neighborPositions :: [(Int, Int)] +neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] + +fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m () +fillOuterEdgesM arr = do + (V2 minX minY, V2 maxX maxY) <- getBounds arr + for_ (range (minX, maxX)) $ \x -> do + writeArray arr (V2 x minY) True + writeArray arr (V2 x maxY) True + for_ (range (minY, maxY)) $ \y -> do + writeArray arr (V2 minX y) True + writeArray arr (V2 maxX y) True + +cloneMArray + :: forall a a' i e m. + ( Ix i + , MArray a e m + , MArray a' e m + , IArray UArray e + ) + => a i e + -> m (a' i e) +cloneMArray = thaw @_ @UArray <=< freeze + +-------------------------------------------------------------------------------- + +-- | Flood fill a cell array starting at a point, returning a list of all the +-- (true) cell locations reachable from that point +floodFill :: forall a i. + ( IArray a Bool + , Ix i + , Enum i + , Bounded i + , Eq i + ) + => a (V2 i) Bool -- ^ array + -> (V2 i) -- ^ position + -> Set (V2 i) +floodFill = go mempty + where + go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i) + go res arr@(bounds -> arrBounds) idx@(V2 x y) + | not (inRange arrBounds idx) = res + | not (arr ! idx) = res + | otherwise = + let neighbors + = filter (inRange arrBounds) + . filter (/= idx) + . filter (`notMember` res) + $ V2 + <$> [(if x == minBound then x else pred x) + .. + (if x == maxBound then x else succ x)] + <*> [(if y == minBound then y else pred y) + .. + (if y == maxBound then y else succ y)] + in foldl' (\r idx' -> + if arr ! idx' + then r <> (let r' = r & contains idx' .~ True + in r' `seq` go r' arr idx') + else r) + (res & contains idx .~ True) neighbors +{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-} + +-- | Gives a list of all the disconnected regions in a cell array, represented +-- each as lists of points +regions :: forall a i. + ( IArray a Bool + , Ix i + , Enum i + , Bounded i + , Eq i + ) + => a (V2 i) Bool + -> [Set (V2 i)] +regions arr + | Just firstPoint <- findFirstPoint arr = + let region = floodFill arr firstPoint + arr' = fillAll region arr + in region : regions arr' + | otherwise = [] + where + findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i) + findFirstPoint = fmap fst . headMay . filter snd . assocs +{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-} + +fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool +fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes + +fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m () +fillAllM ixes a = for_ ixes $ \i -> writeArray a i False + +fromPoints + :: forall a f i. + ( IArray a Bool + , Ix i + , Functor f + , Foldable1 f + ) + => f (i, i) + -> a (i, i) Bool +fromPoints points = + let pts = Set.fromList $ toList points + dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points) + , (maximum1 $ fst <$> points, maximum1 $ snd <$> points) + ) + in array dims $ range dims <&> \i -> (i, i `member` pts) + +fromPointsM + :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f) + => NonNull f + -> m (a i Bool) +fromPointsM points = do + arr <- newArray (minimum points, maximum points) False + fillAllM (otoList points) arr + pure arr diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs b/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs new file mode 100644 index 0000000000..ab7de95e68 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Level/Village.hs @@ -0,0 +1,126 @@ +-------------------------------------------------------------------------------- +module Xanthous.Generators.Level.Village + ( fromCave + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (any, failing, toList) +-------------------------------------------------------------------------------- +import Control.Monad.Random (MonadRandom) +import Control.Monad.State (execStateT, MonadState, modify) +import Control.Monad.Trans.Maybe +import Control.Parallel.Strategies +import Data.Array.IArray +import Data.Foldable (any, toList) +-------------------------------------------------------------------------------- +import Xanthous.Data +import Xanthous.Data.EntityMap (EntityMap) +import qualified Xanthous.Data.EntityMap as EntityMap +import Xanthous.Entities.Environment +import Xanthous.Generators.Level.Util +import Xanthous.Game.State (SomeEntity(..)) +import Xanthous.Random +-------------------------------------------------------------------------------- + +fromCave :: MonadRandom m + => Cells -- ^ The positions of all the walls + -> m (EntityMap SomeEntity) +fromCave wallPositions = execStateT (fromCave' wallPositions) mempty + +fromCave' :: forall m. (MonadRandom m, MonadState (EntityMap SomeEntity) m) + => Cells + -> m () +fromCave' wallPositions = failing (pure ()) $ do + Just villageRegion <- + choose + . (`using` parTraversable rdeepseq) + . weightedBy (\reg -> let circSize = length $ circumference reg + in if circSize == 50 + then (1.0 :: Double) + else 1.0 / (fromIntegral . abs $ circSize - 50)) + $ regions closedHallways + + let circ = setFromList . circumference $ villageRegion + + centerPoints <- chooseSubset (0.1 :: Double) $ toList circ + + roomTiles <- foldM + (flip $ const $ stepOut circ) + (map pure centerPoints) + [0 :: Int ..2] + + let roomWalls = circumference . setFromList @(Set _) <$> roomTiles + allWalls = join roomWalls + + doorPositions <- fmap join . for roomWalls $ \room -> + let candidates = filter (`notMember` circ) room + in fmap toList . choose $ ChooseElement candidates + + let entryways = + filter (\pt -> + let ncs = neighborCells pt + in any ((&&) <$> (not . (wallPositions !)) + <*> (`notMember` villageRegion)) ncs + && any ((&&) <$> (`member` villageRegion) + <*> (`notElem` allWalls)) ncs) + $ toList villageRegion + + Just entryway <- choose $ ChooseElement entryways + + for_ (filter ((&&) <$> (`notElem` doorPositions) <*> (/= entryway)) allWalls) + $ insertEntity Wall + for_ (filter (/= entryway) doorPositions) $ insertEntity unlockedDoor + insertEntity unlockedDoor entryway + + + where + insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e + ptToPos pt = _Position # (fromIntegral <$> pt) + + stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]] + stepOut circ rooms = for rooms $ \room -> + let nextLevels = hashNub $ toList . neighborCells =<< room + in pure + . (<> room) + $ filter ((&&) <$> (`notMember` circ) <*> (`notElem` join rooms)) + nextLevels + + circumference pts = + filter (any (`notMember` pts) . neighborCells) $ toList pts + closedHallways = closeHallways livePositions + livePositions = amap not wallPositions + +-------------------------------------------------------------------------------- + +closeHallways :: Cells -> Cells +closeHallways livePositions = + livePositions // mapMaybe closeHallway (assocs livePositions) + where + closeHallway (_, False) = Nothing + closeHallway (pos, _) + | isHallway pos = Just (pos, False) + | otherwise = Nothing + isHallway pos = any ((&&) <$> not . view left <*> not . view right) + . rotations + . fmap (fromMaybe False) + $ arrayNeighbors livePositions pos + +failing :: Monad m => m a -> MaybeT m a -> m a +failing result = (maybe result pure =<<) . runMaybeT + +{- + +import Xanthous.Generators.Village +import Xanthous.Generators +import Xanthous.Data +import System.Random +import qualified Data.Text +import qualified Xanthous.Generators.CaveAutomata as CA +let gi = GeneratorInput SCaveAutomata CA.defaultParams +wallPositions <- generateFromInput gi (Dimensions 80 50) <$> getStdGen +putStrLn . Data.Text.unpack $ showCells wallPositions + +import Data.Array.IArray +let closedHallways = closeHallways . amap not $ wallPositions +putStrLn . Data.Text.unpack . showCells $ amap not closedHallways + +-} diff --git a/users/aspen/xanthous/src/Xanthous/Generators/Speech.hs b/users/aspen/xanthous/src/Xanthous/Generators/Speech.hs new file mode 100644 index 0000000000..8abc00b6a2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Generators/Speech.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedLists #-} +-------------------------------------------------------------------------------- +module Xanthous.Generators.Speech + ( -- * Language definition + Language(..) + -- ** Lenses + , phonotactics + , syllablesPerWord + + -- ** Phonotactics + , Phonotactics(..) + -- *** Lenses + , onsets + , nuclei + , codas + , numOnsets + , numNuclei + , numCodas + + -- * Language generation + , syllable + , word + + -- * Languages + , english + , gormlak + + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (replicateM) +import Data.Interval (Interval, (<=..<=)) +import qualified Data.Interval as Interval +import Control.Monad.Random.Class (MonadRandom) +import Xanthous.Random (chooseRange, choose, ChooseElement (..), Weighted (Weighted)) +import Control.Monad (replicateM) +import Test.QuickCheck (Arbitrary, CoArbitrary, Function) +import Test.QuickCheck.Instances.Text () +import Data.List.NonEmpty (NonEmpty) +-------------------------------------------------------------------------------- + +newtype Phoneme = Phoneme Text + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving newtype (IsString, Semigroup, Monoid, Arbitrary) + +-- | The phonotactics of a language +-- +-- The phonotactics of a language represent the restriction on the phonemes in +-- the syllables of a language. +-- +-- Syllables in a language consist of an onset, a nucleus, and a coda (the +-- nucleus and the coda together representing the "rhyme" of the syllable). +data Phonotactics = Phonotactics + { _onsets :: [Phoneme] -- ^ The permissible onsets, or consonant clusters + -- at the beginning of a syllable + , _nuclei :: [Phoneme] -- ^ The permissible nuclei, or vowel clusters in + -- the middle of a syllable + , _codas :: [Phoneme] -- ^ The permissible codas, or consonant clusters at + -- the end of a syllable + , _numOnsets :: Interval Word -- ^ The range of number of allowable onsets + , _numNuclei :: Interval Word -- ^ The range of number of allowable nuclei + , _numCodas :: Interval Word -- ^ The range of number of allowable codas + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) +makeLenses ''Phonotactics + +-- | Randomly generate a syllable with the given 'Phonotactics' +syllable :: MonadRandom m => Phonotactics -> m Text +syllable phonotactics = do + let genPart num choices = do + n <- fromIntegral . fromMaybe 0 <$> chooseRange (phonotactics ^. num) + fmap (fromMaybe mempty . mconcat) + . replicateM n + . choose . ChooseElement + $ phonotactics ^. choices + + (Phoneme onset) <- genPart numOnsets onsets + (Phoneme nucleus) <- genPart numNuclei nuclei + (Phoneme coda) <- genPart numCodas codas + + pure $ onset <> nucleus <> coda + +-- | A definition for a language +-- +-- Currently this provides enough information to generate multi-syllabic words, +-- but in the future will likely also include grammar-related things. +data Language = Language + { _phonotactics :: Phonotactics + , _syllablesPerWord :: Weighted Int NonEmpty Int + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) +makeLenses ''Language + +word :: MonadRandom m => Language -> m Text +word lang = do + numSyllables <- choose $ lang ^. syllablesPerWord + mconcat <$> replicateM numSyllables (syllable $ lang ^. phonotactics) + +-------------------------------------------------------------------------------- + +-- <https://en.wikipedia.org/wiki/English_phonology#Phonotactics> +englishPhonotactics :: Phonotactics +englishPhonotactics = Phonotactics + { _onsets = [ "pl" , "bl" , "kl" , "gl" , "pr" , "br" , "tr" , "dr" , "kr" + , "gr" , "tw" , "dw" , "gw" , "kw" , "pw" + + , "fl" , "sl" , {- "thl", -} "shl" {- , "vl" -} + , "p", "b", "t", "d", "k", "ɡ", "m", "n", "f", "v", "th", "s" + , "z", "h", "l", "w" + + , "sp", "st", "sk" + + , "sm", "sn" + + , "sf", "sth" + + , "spl", "skl", "spr", "str", "skr", "skw", "sm", "sp", "st", "sk" + ] + , _nuclei = [ "a", "e", "i", "o", "u", "ur", "ar", "or", "ear", "are", "ure" + , "oa", "ee", "oo", "ei", "ie", "oi", "ou" + ] + , _codas = [ "m", "n", "ng", "p", "t", "tsh", "k", "f", "sh", "s", "th", "x" + , "v", "z", "zh", "l", "r", "w" + + , "lk", "lb", "lt", "ld", "ltsh", "ldsh", "lk" + , "rp", "rb", "rt", "rd", "rtsh", "rdsh", "rk", "rɡ" + , "lf", "lv", "lth", "ls", "lz", "lsh", "lth" + , "rf", "rv", "rth", "rs", "rz", "rth" + , "lm", "ln" + , "rm", "rn", "rl" + , "mp", "nt", "nd", "nth", "nsh", "nk" + , "mf", "ms", "mth", "nf", "nth", "ns", "nz", "nth" + , "ft", "sp", "st", "sk" + , "fth" + , "pt", "kt" + , "pth", "ps", "th", "ts", "dth", "dz", "ks" + , "lpt", "lps", "lfth", "lts", "lst", "lkt", "lks" + , "rmth", "rpt", "rps", "rts", "rst", "rkt" + , "mpt", "mps", "ndth", "nkt", "nks", "nkth" + , "ksth", "kst" + ] + , _numOnsets = 0 <=..<= 1 + , _numNuclei = Interval.singleton 1 + , _numCodas = 0 <=..<= 1 + } + +english :: Language +english = Language + { _phonotactics = englishPhonotactics + , _syllablesPerWord = Weighted [(20, 1), + (7, 2), + (2, 3), + (1, 4)] + } + +gormlakPhonotactics :: Phonotactics +gormlakPhonotactics = Phonotactics + { _onsets = [ "h", "l", "g", "b", "m", "n", "ng" + , "gl", "bl", "fl" + ] + , _numOnsets = Interval.singleton 1 + , _nuclei = [ "a", "o", "aa", "u" ] + , _numNuclei = Interval.singleton 1 + , _codas = [ "r", "l", "g", "m", "n" + , "rl", "gl", "ml", "rm" + , "n", "k" + ] + , _numCodas = Interval.singleton 1 + } + +gormlak :: Language +gormlak = Language + { _phonotactics = gormlakPhonotactics + , _syllablesPerWord = Weighted [ (5, 2) + , (5, 1) + , (1, 3) + ] + } diff --git a/users/aspen/xanthous/src/Xanthous/Messages.hs b/users/aspen/xanthous/src/Xanthous/Messages.hs new file mode 100644 index 0000000000..c273d65082 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Messages.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TemplateHaskell #-} +-------------------------------------------------------------------------------- +module Xanthous.Messages + ( Message(..) + , resolve + , MessageMap(..) + , lookupMessage + + -- * Game messages + , messages + , render + , render_ + , lookup + , message + , message_ + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (lookup) +-------------------------------------------------------------------------------- +import Control.Monad.Random.Class (MonadRandom) +import Data.Aeson (FromJSON, ToJSON, toJSON, object) +import qualified Data.Aeson as JSON +import Data.Aeson.Generic.DerivingVia +import Data.FileEmbed +import Data.List.NonEmpty +import Test.QuickCheck hiding (choose) +import Test.QuickCheck.Instances.UnorderedContainers () +import Text.Mustache +import qualified Data.Yaml as Yaml +-------------------------------------------------------------------------------- +import Xanthous.Random +import Xanthous.Orphans () +-------------------------------------------------------------------------------- + +data Message = Single Template | Choice (NonEmpty Template) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData) + deriving (ToJSON, FromJSON) + via WithOptions '[ SumEnc UntaggedVal ] + Message + +instance Arbitrary Message where + arbitrary = + frequency [ (10, Single <$> arbitrary) + , (1, Choice <$> arbitrary) + ] + shrink = genericShrink + +resolve :: MonadRandom m => Message -> m Template +resolve (Single t) = pure t +resolve (Choice ts) = choose ts + +data MessageMap = Direct Message | Nested (HashMap Text MessageMap) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData) + deriving (ToJSON, FromJSON) + via WithOptions '[ SumEnc UntaggedVal ] + MessageMap + +instance Arbitrary MessageMap where + arbitrary = frequency [ (10, Direct <$> arbitrary) + , (1, Nested <$> arbitrary) + ] + +lookupMessage :: [Text] -> MessageMap -> Maybe Message +lookupMessage [] (Direct msg) = Just msg +lookupMessage (k:ks) (Nested m) = lookupMessage ks =<< m ^. at k +lookupMessage _ _ = Nothing + +type instance Index MessageMap = [Text] +type instance IxValue MessageMap = Message +instance Ixed MessageMap where + ix [] f (Direct msg) = Direct <$> f msg + ix (k:ks) f (Nested m) = case m ^. at k of + Just m' -> ix ks f m' <&> \m'' -> + Nested $ m & at k ?~ m'' + Nothing -> pure $ Nested m + ix _ _ m = pure m + +-------------------------------------------------------------------------------- + +rawMessages :: ByteString +rawMessages = $(embedFile "src/Xanthous/messages.yaml") + +messages :: MessageMap +messages + = either (error . Yaml.prettyPrintParseException) id + $ Yaml.decodeEither' rawMessages + +render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text +render msg params = do + tpl <- resolve msg + pure . toStrict . renderMustache tpl $ toJSON params + +-- | Render a message with an empty set of params +render_ :: (MonadRandom m) => Message -> m Text +render_ msg = render msg $ object [] + +lookup :: [Text] -> Message +lookup path = fromMaybe notFound $ messages ^? ix path + where notFound + = Single + $ compileMustacheText "template" "Message not found" + ^?! _Right + +message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text +message path params = maybe notFound (`render` params) $ messages ^? ix path + where + notFound = pure "Message not found" + +message_ :: (MonadRandom m) => [Text] -> m Text +message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path + where + notFound = pure "Message not found" diff --git a/users/aspen/xanthous/src/Xanthous/Messages/Template.hs b/users/aspen/xanthous/src/Xanthous/Messages/Template.hs new file mode 100644 index 0000000000..5176880355 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Messages/Template.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +module Xanthous.Messages.Template + ( -- * Template AST + Template(..) + , Substitution(..) + , Filter(..) + + -- ** Template AST transformations + , reduceTemplate + + -- * Template parser + , template + , runParser + , errorBundlePretty + + -- * Template pretty-printer + , ppTemplate + + -- * Rendering templates + , TemplateVar(..) + , nested + , TemplateVars(..) + , vars + , RenderError + , render + ) +where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding + (many, concat, try, elements, some, parts) +-------------------------------------------------------------------------------- +import Test.QuickCheck hiding (label) +import Test.QuickCheck.Instances.Text () +import Test.QuickCheck.Instances.Semigroup () +import Test.QuickCheck.Checkers (EqProp) +import Control.Monad.Combinators.NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Data +import Text.Megaparsec hiding (sepBy1, some) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L +import Data.Function (fix) +-------------------------------------------------------------------------------- +import Xanthous.Util (EqEqProp(..)) +-------------------------------------------------------------------------------- + +genIdentifier :: Gen Text +genIdentifier = pack <$> listOf1 (elements identifierChars) + +identifierChars :: String +identifierChars = ['a'..'z'] <> ['A'..'Z'] <> ['-', '_'] + +newtype Filter = FilterName Text + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (NFData) + deriving (IsString) via Text + +instance Arbitrary Filter where + arbitrary = FilterName <$> genIdentifier + shrink (FilterName fn) = fmap FilterName . filter (not . null) $ shrink fn + +data Substitution + = SubstPath (NonEmpty Text) + | SubstFilter Substitution Filter + deriving stock (Show, Eq, Ord, Generic, Data) + deriving anyclass (NFData) + +instance Arbitrary Substitution where + arbitrary = sized . fix $ \gen n -> + let leaves = + [ SubstPath <$> ((:|) <$> genIdentifier <*> listOf genIdentifier)] + subtree = gen $ n `div` 2 + in if n == 0 + then oneof leaves + else oneof $ leaves <> [ SubstFilter <$> subtree <*> arbitrary ] + shrink (SubstPath pth) = + fmap SubstPath + . filter (not . any ((||) <$> null <*> any (`notElem` identifierChars))) + $ shrink pth + shrink (SubstFilter s f) + = shrink s + <> (uncurry SubstFilter <$> shrink (s, f)) + +data Template + = Literal Text + | Subst Substitution + | Concat Template Template + deriving stock (Show, Generic, Data) + deriving anyclass (NFData) + deriving EqProp via EqEqProp Template + +instance Plated Template where + plate _ tpl@(Literal _) = pure tpl + plate _ tpl@(Subst _) = pure tpl + plate f (Concat tpl₁ tpl₂) = Concat <$> f tpl₁ <*> f tpl₂ + +reduceTemplate :: Template -> Template +reduceTemplate = transform $ \case + (Concat (Literal t₁) (Literal t₂)) -> Literal (t₁ <> t₂) + (Concat (Literal "") t) -> t + (Concat t (Literal "")) -> t + (Concat t₁ (Concat t₂ t₃)) -> Concat (Concat t₁ t₂) t₃ + (Concat (Concat t₁ (Literal t₂)) (Literal t₃)) -> (Concat t₁ (Literal $ t₂ <> t₃)) + t -> t + +instance Eq Template where + tpl₁ == tpl₂ = case (reduceTemplate tpl₁, reduceTemplate tpl₂) of + (Literal t₁, Literal t₂) -> t₁ == t₂ + (Subst s₁, Subst s₂) -> s₁ == s₂ + (Concat ta₁ ta₂, Concat tb₁ tb₂) -> ta₁ == tb₁ && ta₂ == tb₂ + _ -> False + +instance Arbitrary Template where + arbitrary = sized . fix $ \gen n -> + let leaves = [ Literal . pack . filter (`notElem` ['\\', '{']) <$> arbitrary + , Subst <$> arbitrary + ] + subtree = gen $ n `div` 2 + genConcat = Concat <$> subtree <*> subtree + in if n == 0 + then oneof leaves + else oneof $ genConcat : leaves + shrink (Literal t) = Literal <$> shrink t + shrink (Subst s) = Subst <$> shrink s + shrink (Concat t₁ t₂) + = shrink t₁ + <> shrink t₂ + <> (Concat <$> shrink t₁ <*> shrink t₂) + +instance Semigroup Template where + (<>) = Concat + +instance Monoid Template where + mempty = Literal "" + +-------------------------------------------------------------------------------- + +type Parser = Parsec Void Text + +sc :: Parser () +sc = L.space space1 empty empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +identifier :: Parser Text +identifier = lexeme . label "identifier" $ do + firstChar <- letterChar <|> oneOf ['-', '_'] + restChars <- many $ alphaNumChar <|> oneOf ['-', '_'] + pure $ firstChar <| pack restChars + +filterName :: Parser Filter +filterName = FilterName <$> identifier + +substitutionPath :: Parser Substitution +substitutionPath = SubstPath <$> sepBy1 identifier (char '.') + +substitutionFilter :: Parser Substitution +substitutionFilter = do + path <- substitutionPath + fs <- some $ symbol "|" *> filterName + pure $ foldl' SubstFilter path fs + -- pure $ SubstFilter path f + +substitutionContents :: Parser Substitution +substitutionContents + = try substitutionFilter + <|> substitutionPath + +substitution :: Parser Substitution +substitution = between (string "{{") (string "}}") substitutionContents + +literal :: Parser Template +literal = Literal <$> + ( (string "\\{" $> "{") + <|> takeWhile1P Nothing (`notElem` ['\\', '{']) + ) + +subst :: Parser Template +subst = Subst <$> substitution + +template' :: Parser Template +template' = do + parts <- many $ literal <|> subst + pure $ foldr Concat (Literal "") parts + + +template :: Parser Template +template = reduceTemplate <$> template' <* eof + +-------------------------------------------------------------------------------- + +ppSubstitution :: Substitution -> Text +ppSubstitution (SubstPath substParts) = intercalate "." substParts +ppSubstitution (SubstFilter s (FilterName f)) = ppSubstitution s <> " | " <> f + +ppTemplate :: Template -> Text +ppTemplate (Literal txt) = txt +ppTemplate (Subst s) = "{{" <> ppSubstitution s <> "}}" +ppTemplate (Concat tpl₁ tpl₂) = ppTemplate tpl₁ <> ppTemplate tpl₂ + +-------------------------------------------------------------------------------- + +data TemplateVar + = Val Text + | Nested (Map Text TemplateVar) + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +nested :: [(Text, TemplateVar)] -> TemplateVar +nested = Nested . mapFromList + +instance Arbitrary TemplateVar where + arbitrary = sized . fix $ \gen n -> + let nst = fmap mapFromList . listOf $ (,) <$> arbitrary <*> gen (n `div` 2) + in if n == 0 + then Val <$> arbitrary + else oneof [ Val <$> arbitrary + , Nested <$> nst] + +newtype TemplateVars = Vars { getTemplateVars :: Map Text TemplateVar } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (Arbitrary) via (Map Text TemplateVar) + +type instance Index TemplateVars = Text +type instance IxValue TemplateVars = TemplateVar +instance Ixed TemplateVars where + ix k f (Vars vs) = Vars <$> ix k f vs +instance At TemplateVars where + at k f (Vars vs) = Vars <$> at k f vs + +vars :: [(Text, TemplateVar)] -> TemplateVars +vars = Vars . mapFromList + +lookupVar :: TemplateVars -> NonEmpty Text -> Maybe TemplateVar +lookupVar vs (p :| []) = vs ^. at p +lookupVar vs (p :| (p₁ : ps)) = vs ^. at p >>= \case + (Val _) -> Nothing + (Nested vs') -> lookupVar (Vars vs') $ p₁ :| ps + +data RenderError + = NoSuchVariable (NonEmpty Text) + | NestedFurther (NonEmpty Text) + | NoSuchFilter Filter + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +renderSubst + :: Map Filter (Text -> Text) -- ^ Filters + -> TemplateVars + -> Substitution + -> Either RenderError Text +renderSubst _ vs (SubstPath pth) = + case lookupVar vs pth of + Just (Val v) -> Right v + Just (Nested _) -> Left $ NestedFurther pth + Nothing -> Left $ NoSuchVariable pth +renderSubst fs vs (SubstFilter s fn) = + case fs ^. at fn of + Just filterFn -> filterFn <$> renderSubst fs vs s + Nothing -> Left $ NoSuchFilter fn + +render + :: Map Filter (Text -> Text) -- ^ Filters + -> TemplateVars -- ^ Template variables + -> Template -- ^ Template + -> Either RenderError Text +render _ _ (Literal s) = pure s +render fs vs (Concat t₁ t₂) = (<>) <$> render fs vs t₁ <*> render fs vs t₂ +render fs vs (Subst s) = renderSubst fs vs s diff --git a/users/aspen/xanthous/src/Xanthous/Monad.hs b/users/aspen/xanthous/src/Xanthous/Monad.hs new file mode 100644 index 0000000000..db602de56f --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Monad.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------------------- +module Xanthous.Monad + ( AppT(..) + , AppM + , runAppT + , continue + , halt + + -- * Messages + , say + , say_ + , message + , message_ + , writeMessage + + -- * Autocommands + , cancelAutocommand + + -- * Events + , sendEvent + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Control.Monad.Random +import Control.Monad.State +import qualified Brick +import Brick (EventM, Next) +import Brick.BChan (writeBChan) +import Data.Aeson (ToJSON, object) +-------------------------------------------------------------------------------- +import Xanthous.Data.App (AppEvent) +import Xanthous.Game.State +import Xanthous.Game.Env +import Xanthous.Messages (Message) +import qualified Xanthous.Messages as Messages +-------------------------------------------------------------------------------- + +halt :: AppT (EventM n) (Next GameState) +halt = lift . Brick.halt =<< get + +continue :: AppT (EventM n) (Next GameState) +continue = lift . Brick.continue =<< get + +-------------------------------------------------------------------------------- + +say :: (MonadRandom m, ToJSON params, MonadState GameState m) + => [Text] -> params -> m () +say msgPath = writeMessage <=< Messages.message msgPath + +say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m () +say_ msgPath = say msgPath $ object [] + +message :: (MonadRandom m, ToJSON params, MonadState GameState m) + => Message -> params -> m () +message msg = writeMessage <=< Messages.render msg + +message_ :: (MonadRandom m, MonadState GameState m) + => Message -> m () +message_ msg = message msg $ object [] + +writeMessage :: MonadState GameState m => Text -> m () +writeMessage m = messageHistory %= pushMessage m + +-- | Cancel the currently active autocommand, if any +cancelAutocommand :: (MonadState GameState m, MonadIO m) => m () +cancelAutocommand = do + traverse_ (liftIO . cancel . snd) =<< preuse (autocommand . _ActiveAutocommand) + autocommand .= NoAutocommand + +-------------------------------------------------------------------------------- + +-- | Send an event to the app in an environment where the game env is available +sendEvent :: (MonadReader GameEnv m, MonadIO m) => AppEvent -> m () +sendEvent evt = do + ec <- view eventChan + liftIO $ writeBChan ec evt diff --git a/users/aspen/xanthous/src/Xanthous/Orphans.hs b/users/aspen/xanthous/src/Xanthous/Orphans.hs new file mode 100644 index 0000000000..66004163f6 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Orphans.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} +-------------------------------------------------------------------------------- +module Xanthous.Orphans + ( ppTemplate + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (elements, (.=)) +-------------------------------------------------------------------------------- +import Data.Aeson hiding (Key) +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (typeMismatch) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Graphics.Vty.Input +import Graphics.Vty.Attributes +import Brick.Widgets.Edit +import Data.Text.Zipper.Generic (GenericTextZipper) +import Brick.Widgets.Core (getName) +import System.Random.Internal (StdGen (..)) +import System.Random.SplitMix (SMGen ()) +import Test.QuickCheck +-- import Test.QuickCheck.Arbitrary.Generic (Arg ()) +import "quickcheck-instances" Test.QuickCheck.Instances () +import Text.Megaparsec (errorBundlePretty) +import Text.Megaparsec.Pos +import Text.Mustache +import Text.Mustache.Type ( showKey ) +import Control.Monad.State +import Linear +import qualified Data.Interval as Interval +import Data.Interval ( Interval, Extended (..), Boundary (..) + , lowerBound', upperBound', (<=..<), (<=..<=) + , interval) +import Test.QuickCheck.Checkers (EqProp ((=-=))) +-------------------------------------------------------------------------------- +import Xanthous.Util.JSON +import Xanthous.Util.QuickCheck +import Xanthous.Util (EqEqProp(EqEqProp)) +import qualified Graphics.Vty.Input.Events +-------------------------------------------------------------------------------- + +instance forall s a. + ( Cons s s a a + , IsSequence s + , Element s ~ a + ) => Cons (NonNull s) (NonNull s) a a where + _Cons = prism hither yon + where + hither :: (a, NonNull s) -> NonNull s + hither (a, ns) = + let s = toNullable ns + in impureNonNull $ a <| s + + yon :: NonNull s -> Either (NonNull s) (a, NonNull s) + yon ns = case nuncons ns of + (_, Nothing) -> Left ns + (x, Just xs) -> Right (x, xs) + +instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where + _Cons = prism hither yon + where + hither :: (a, NonEmpty a) -> NonEmpty a + hither (a, x :| xs) = a :| (x : xs) + + yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a) + yon ns@(x :| xs) = case xs of + (y : ys) -> Right (x, y :| ys) + [] -> Left ns + + +instance Arbitrary PName where + arbitrary = PName . pack <$> listOf1 (elements ['a'..'z']) + +instance Arbitrary Key where + arbitrary = Key <$> listOf1 arbSafeText + where arbSafeText = pack <$> listOf1 (elements ['a'..'z']) + shrink (Key []) = error "unreachable" + shrink k@(Key [_]) = pure k + shrink (Key (p:ps)) = Key . (p :) <$> shrink ps + +instance Arbitrary Pos where + arbitrary = mkPos . succ . abs <$> arbitrary + shrink (unPos -> 1) = [] + shrink (unPos -> x) = mkPos <$> [x..1] + +instance Arbitrary Node where + arbitrary = scale (`div` 10) $ sized node + where + node n | n > 0 = oneof $ leaves ++ branches (n `div` 4) + node _ = oneof leaves + branches n = + [ Section <$> arbitrary <*> subnodes n + , InvertedSection <$> arbitrary <*> subnodes n + ] + subnodes = fmap concatTextBlocks . listOf . node + leaves = + [ TextBlock . pack <$> listOf1 (elements ['a'..'z']) + , EscapedVar <$> arbitrary + , UnescapedVar <$> arbitrary + -- TODO fix pretty-printing of mustache partials + -- , Partial <$> arbitrary <*> arbitrary + ] + shrink = genericShrink + +concatTextBlocks :: [Node] -> [Node] +concatTextBlocks [] = [] +concatTextBlocks [x] = [x] +concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs) + = concatTextBlocks $ TextBlock (txt₁ <> txt₂) : concatTextBlocks xs +concatTextBlocks (x : xs) = x : concatTextBlocks xs + +instance Arbitrary Template where + arbitrary = scale (`div` 8) $ do + template <- concatTextBlocks <$> arbitrary + -- templateName <- arbitrary + -- rest <- arbitrary + let templateName = "template" + rest = mempty + pure $ Template + { templateActual = templateName + , templateCache = rest & at templateName ?~ template + } + shrink (Template actual cache) = + let Just tpl = cache ^. at actual + in do + cache' <- shrink cache + tpl' <- shrink tpl + actual' <- shrink actual + pure $ Template + { templateActual = actual' + , templateCache = cache' & at actual' ?~ tpl' + } + +instance CoArbitrary Template where + coarbitrary = coarbitrary . ppTemplate + +instance Function Template where + function = functionMap ppTemplate parseTemplatePartial + where + parseTemplatePartial txt + = compileMustacheText "template" txt ^?! _Right + +ppNode :: Map PName [Node] -> Node -> Text +ppNode _ (TextBlock txt) = txt +ppNode _ (EscapedVar k) = "{{" <> showKey k <> "}}" +ppNode ctx (Section k body) = + let sk = showKey k + in "{{#" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" +ppNode _ (UnescapedVar k) = "{{{" <> showKey k <> "}}}" +ppNode ctx (InvertedSection k body) = + let sk = showKey k + in "{{^" <> sk <> "}}" <> foldMap (ppNode ctx) body <> "{{/" <> sk <> "}}" +ppNode _ (Partial n _) = "{{> " <> unPName n <> "}}" + +ppTemplate :: Template -> Text +ppTemplate (Template actual cache) = + case cache ^. at actual of + Nothing -> error "Template not found?" + Just nodes -> foldMap (ppNode cache) nodes + +instance ToJSON Template where + toJSON = String . ppTemplate + +instance FromJSON Template where + parseJSON + = withText "Template" + $ either (fail . errorBundlePretty) pure + . compileMustacheText "template" + +deriving anyclass instance NFData Node +deriving anyclass instance NFData Template + +instance FromJSON Color where + parseJSON (String "black") = pure black + parseJSON (String "red") = pure red + parseJSON (String "green") = pure green + parseJSON (String "yellow") = pure yellow + parseJSON (String "blue") = pure blue + parseJSON (String "magenta") = pure magenta + parseJSON (String "cyan") = pure cyan + parseJSON (String "white") = pure white + parseJSON (String "brightBlack") = pure brightBlack + parseJSON (String "brightRed") = pure brightRed + parseJSON (String "brightGreen") = pure brightGreen + parseJSON (String "brightYellow") = pure brightYellow + parseJSON (String "brightBlue") = pure brightBlue + parseJSON (String "brightMagenta") = pure brightMagenta + parseJSON (String "brightCyan") = pure brightCyan + parseJSON (String "brightWhite") = pure brightWhite + parseJSON n@(Number _) = Color240 <$> parseJSON n + parseJSON x = typeMismatch "Color" x + +instance ToJSON Color where + toJSON color + | color == black = "black" + | color == red = "red" + | color == green = "green" + | color == yellow = "yellow" + | color == blue = "blue" + | color == magenta = "magenta" + | color == cyan = "cyan" + | color == white = "white" + | color == brightBlack = "brightBlack" + | color == brightRed = "brightRed" + | color == brightGreen = "brightGreen" + | color == brightYellow = "brightYellow" + | color == brightBlue = "brightBlue" + | color == brightMagenta = "brightMagenta" + | color == brightCyan = "brightCyan" + | color == brightWhite = "brightWhite" + | Color240 num <- color = toJSON num + | otherwise = error $ "unimplemented: " <> show color + +instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where + parseJSON Null = pure Default + parseJSON (String "keepCurrent") = pure KeepCurrent + parseJSON x = SetTo <$> parseJSON x + +instance ToJSON a => ToJSON (MaybeDefault a) where + toJSON Default = Null + toJSON KeepCurrent = String "keepCurrent" + toJSON (SetTo x) = toJSON x + +-------------------------------------------------------------------------------- + +instance Arbitrary Color where + arbitrary = oneof [ Color240 <$> choose (0, 239) + , ISOColor <$> choose (0, 15) + ] + +deriving anyclass instance CoArbitrary Color +deriving anyclass instance Function Color + +instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where + arbitrary = oneof [ pure Default + , pure KeepCurrent + , SetTo <$> arbitrary + ] + +instance CoArbitrary a => CoArbitrary (MaybeDefault a) where + coarbitrary Default = variant @Int 1 + coarbitrary KeepCurrent = variant @Int 2 + coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x + +instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where + function = functionShow + +deriving via (EqEqProp Attr) instance EqProp Attr + +instance Arbitrary Attr where + arbitrary = do + attrStyle <- arbitrary + attrForeColor <- arbitrary + attrBackColor <- arbitrary + attrURL <- arbitrary + pure Attr {..} + +deriving anyclass instance CoArbitrary Attr +deriving anyclass instance Function Attr + +instance ToJSON Attr where + toJSON Attr{..} = object + [ "style" .= maybeDefaultToJSONWith styleToJSON attrStyle + , "foreground" .= attrForeColor + , "background" .= attrBackColor + , "url" .= attrURL + ] + where + maybeDefaultToJSONWith _ Default = Null + maybeDefaultToJSONWith _ KeepCurrent = String "keepCurrent" + maybeDefaultToJSONWith tj (SetTo x) = tj x + styleToJSON style + | style == standout = "standout" + | style == underline = "underline" + | style == reverseVideo = "reverseVideo" + | style == blink = "blink" + | style == dim = "dim" + | style == bold = "bold" + | style == italic = "italic" + | otherwise = toJSON style + +instance FromJSON Attr where + parseJSON = withObject "Attr" $ \obj -> do + attrStyle <- parseStyle =<< obj .:? "style" .!= Default + attrForeColor <- obj .:? "foreground" .!= Default + attrBackColor <- obj .:? "background" .!= Default + attrURL <- obj .:? "url" .!= Default + pure Attr{..} + + where + parseStyle (SetTo (String "standout")) = pure (SetTo standout) + parseStyle (SetTo (String "underline")) = pure (SetTo underline) + parseStyle (SetTo (String "reverseVideo")) = pure (SetTo reverseVideo) + parseStyle (SetTo (String "blink")) = pure (SetTo blink) + parseStyle (SetTo (String "dim")) = pure (SetTo dim) + parseStyle (SetTo (String "bold")) = pure (SetTo bold) + parseStyle (SetTo (String "italic")) = pure (SetTo italic) + parseStyle (SetTo n@(Number _)) = SetTo <$> parseJSON n + parseStyle (SetTo v) = typeMismatch "Style" v + parseStyle Default = pure Default + parseStyle KeepCurrent = pure KeepCurrent + +deriving stock instance Ord Color +deriving stock instance Ord a => Ord (MaybeDefault a) +deriving stock instance Ord Attr + +deriving anyclass instance Hashable Graphics.Vty.Input.Events.Key +deriving anyclass instance Hashable Graphics.Vty.Input.Events.Modifier + +-------------------------------------------------------------------------------- + +instance (SemiSequence a, Arbitrary (Element a), Arbitrary a) + => Arbitrary (NonNull a) where + arbitrary = ncons <$> arbitrary <*> arbitrary + +instance ToJSON a => ToJSON (NonNull a) where + toJSON = toJSON . toNullable + +instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where + parseJSON = maybe (fail "Found empty list") pure . fromNullable <=< parseJSON + +instance NFData a => NFData (NonNull a) where + rnf xs = xs `seq` toNullable xs `deepseq` () + +-------------------------------------------------------------------------------- + +instance forall t name. (NFData t, Monoid t, NFData name) + => NFData (Editor t name) where + rnf ed = getName @_ @name ed `deepseq` getEditContents ed `deepseq` () + +deriving via (ReadShowJSON SMGen) instance ToJSON SMGen +deriving via (ReadShowJSON SMGen) instance FromJSON SMGen + +instance ToJSON StdGen where + toJSON = toJSON . unStdGen + toEncoding = toEncoding . unStdGen + +instance FromJSON StdGen where + parseJSON = fmap StdGen . parseJSON + +-------------------------------------------------------------------------------- + +instance CoArbitrary a => CoArbitrary (NonNull a) where + coarbitrary = coarbitrary . toNullable + +instance (MonoFoldable a, Function a) => Function (NonNull a) where + function = functionMap toNullable $ fromMaybe (error "null") . fromNullable + +instance (Arbitrary t, Arbitrary n, GenericTextZipper t) + => Arbitrary (Editor t n) where + arbitrary = editor <$> arbitrary <*> arbitrary <*> arbitrary + +instance forall t n. (CoArbitrary t, CoArbitrary n, Monoid t) + => CoArbitrary (Editor t n) where + coarbitrary ed = coarbitrary (getName @_ @n ed, getEditContents ed) + +instance CoArbitrary StdGen where + coarbitrary = coarbitrary . show + +instance Function StdGen where + function = functionMap unStdGen StdGen + +instance Function SMGen where + function = functionShow + +-------------------------------------------------------------------------------- + +deriving newtype instance (Arbitrary s, CoArbitrary (m (a, s))) + => CoArbitrary (StateT s m a) + +-------------------------------------------------------------------------------- + +deriving via (GenericArbitrary (V2 a)) instance (Arbitrary a) => Arbitrary (V2 a) +instance CoArbitrary a => CoArbitrary (V2 a) +instance Function a => Function (V2 a) + +-------------------------------------------------------------------------------- + +instance CoArbitrary Boundary +instance Function Boundary + +instance Arbitrary a => Arbitrary (Extended a) where + arbitrary = oneof [ pure NegInf + , pure PosInf + , Finite <$> arbitrary + ] + +instance CoArbitrary a => CoArbitrary (Extended a) where + coarbitrary NegInf = variant 1 + coarbitrary PosInf = variant 2 + coarbitrary (Finite x) = variant 3 . coarbitrary x + +instance (Function a) => Function (Extended a) where + function = functionMap g h + where + g NegInf = Left True + g (Finite a) = Right a + g PosInf = Left False + h (Left False) = PosInf + h (Left True) = NegInf + h (Right a) = Finite a + +instance ToJSON a => ToJSON (Extended a) where + toJSON NegInf = String "NegInf" + toJSON PosInf = String "PosInf" + toJSON (Finite x) = toJSON x + +instance FromJSON a => FromJSON (Extended a) where + parseJSON (String "NegInf") = pure NegInf + parseJSON (String "PosInf") = pure PosInf + parseJSON val = Finite <$> parseJSON val + +instance (EqProp a, Show a) => EqProp (Extended a) where + NegInf =-= NegInf = property True + PosInf =-= PosInf = property True + (Finite x) =-= (Finite y) = x =-= y + x =-= y = counterexample (show x <> " /= " <> show y) False + +instance Arbitrary Interval.Boundary where + arbitrary = elements [ Interval.Open , Interval.Closed ] + +instance (Ord r, Arbitrary r) => Arbitrary (Interval r) where + arbitrary = do + lower <- arbitrary + upper <- arbitrary + pure $ (if upper < lower then flip else id) + Interval.interval + lower + upper + +instance CoArbitrary a => CoArbitrary (Interval a) where + coarbitrary int = coarbitrary (lowerBound' int) . coarbitrary (upperBound' int) + +instance (Function a, Ord a) => Function (Interval a) where + function = functionMap g h + where + g = lowerBound' &&& upperBound' + h = uncurry interval + +deriving via (EqEqProp (Interval a)) instance Eq a => (EqProp (Interval a)) + +instance ToJSON a => ToJSON (Interval a) where + toJSON x = Array . fromList $ + [ object [ lowerKey .= lowerVal ] + , object [ upperKey .= upperVal ] + ] + where + (lowerVal, lowerBoundary) = lowerBound' x + (upperVal, upperBoundary) = upperBound' x + upperKey = boundaryToKey upperBoundary + lowerKey = boundaryToKey lowerBoundary + boundaryToKey Open = "Excluded" + boundaryToKey Closed = "Included" + +instance forall a. (FromJSON a, Ord a) => FromJSON (Interval a) where + parseJSON x = + boundPairWithBoundary x + <|> boundPairWithoutBoundary x + <|> singleVal x + where + boundPairWithBoundary = withArray "Bound pair" $ \arr -> do + checkLength arr + lower <- parseBound $ arr ^?! ix 0 + upper <- parseBound $ arr ^?! ix 1 + pure $ interval lower upper + parseBound = withObject "Bound" $ \obj -> do + when (KM.size obj /= 1) $ fail "Expected an object with a single key" + let [(k, v)] = obj ^@.. ifolded + boundary <- case k of + "Excluded" -> pure Open + "Open" -> pure Open + "Included" -> pure Closed + "Closed" -> pure Closed + _ -> fail "Invalid boundary specification" + val <- parseJSON v + pure (val, boundary) + boundPairWithoutBoundary = withArray "Bound pair" $ \arr -> do + checkLength arr + lower <- parseJSON $ arr ^?! ix 0 + upper <- parseJSON $ arr ^?! ix 1 + pure $ lower <=..< upper + singleVal v = do + val <- parseJSON v + pure $ val <=..<= val + checkLength arr = + when (length arr /= 2) $ fail "Expected array of length 2" + +-------------------------------------------------------------------------------- + +deriving anyclass instance NFData Graphics.Vty.Input.Key +deriving anyclass instance NFData Graphics.Vty.Input.Modifier diff --git a/users/aspen/xanthous/src/Xanthous/Physics.hs b/users/aspen/xanthous/src/Xanthous/Physics.hs new file mode 100644 index 0000000000..37530cbbc2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Physics.hs @@ -0,0 +1,71 @@ +-------------------------------------------------------------------------------- +module Xanthous.Physics + ( throwDistance + , bluntThrowDamage + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Xanthous.Data + ( Meters + , (:**:)(..) + , Square + , Grams + , (|*|) + , (|/|) + , Hitpoints + , Per (..) + , squared + , Uno(..), (|+|) + ) +-------------------------------------------------------------------------------- + +-- university shotputter can put a 16 lb shot about 14 meters +-- ≈ 7.25 kg 14 meters +-- 14m = x / (7.25kg × y + z)² +-- 14m = x / (7250g × y + z)² +-- +-- we don't want to scale down too much: +-- +-- 10 kg 10 meters +-- = 10000 g 10 meters +-- +-- 15 kg w meters +-- = 15000 g w meters +-- +-- 14m = x / (7250g × y + z)² +-- 10m = x / (10000g × y + z)² +-- wm = x / (15000g × y + z)² +-- +-- w≈0.527301 ∧ y≈0.000212178 sqrt(x) ∧ z≈1.80555 sqrt(x) ∧ 22824.1 sqrt(x)!=0 +-- +-- x = 101500 +-- y = 0.0675979 +-- z = 575.231 +-- + +-- TODO make this dynamic +strength :: Meters :**: Square Grams +strength = Times 10150000 + +yCoeff :: Uno Double +yCoeff = Uno 0.0675979 + +zCoeff :: Uno Double +zCoeff = Uno 575.231 + +-- | Calculate the maximum distance an object with the given weight can be +-- thrown +throwDistance + :: Grams -- ^ Weight of the object + -> Meters -- ^ Max distance thrown +throwDistance weight = strength |/| squared (weight |*| yCoeff |+| zCoeff) + +-- | Returns the damage dealt by a blunt object with the given weight when +-- thrown +bluntThrowDamage + :: Grams + -> Hitpoints +bluntThrowDamage weight = throwDamageRatio |*| weight + where + throwDamageRatio :: Hitpoints `Per` Grams + throwDamageRatio = Rate $ 1 / 5000 diff --git a/users/aspen/xanthous/src/Xanthous/Prelude.hs b/users/aspen/xanthous/src/Xanthous/Prelude.hs new file mode 100644 index 0000000000..2cb4299303 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Prelude.hs @@ -0,0 +1,48 @@ +-------------------------------------------------------------------------------- +module Xanthous.Prelude + ( module ClassyPrelude + , Type + , Constraint + , module GHC.TypeLits + , module Control.Lens + , module Data.Void + , module Control.Comonad + , module Witherable + , fail + + , (&!) + + -- * Classy-Prelude addons + , ninsertSet + , ndeleteSet + , toVector + ) where +-------------------------------------------------------------------------------- +import ClassyPrelude hiding + ( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say + , catMaybes, filter, mapMaybe, hashNub, ordNub + , Memoized, runMemoized + ) +import Data.Kind +import GHC.TypeLits hiding (Text) +import Control.Lens hiding (levels, Level) +import Data.Void +import Control.Comonad +import Witherable +import Control.Monad.Fail (fail) +-------------------------------------------------------------------------------- + +ninsertSet + :: (IsSet set, MonoPointed set) + => Element set -> NonNull set -> NonNull set +ninsertSet x xs = impureNonNull $ opoint x `union` toNullable xs + +ndeleteSet :: IsSet b => Element b -> NonNull b -> b +ndeleteSet x = deleteSet x . toNullable + +toVector :: (MonoFoldable (f a), Element (f a) ~ a) => f a -> Vector a +toVector = fromList . toList + +infixl 1 &! +(&!) :: a -> (a -> b) -> b +(&!) = flip ($!) diff --git a/users/aspen/xanthous/src/Xanthous/Random.hs b/users/aspen/xanthous/src/Xanthous/Random.hs new file mode 100644 index 0000000000..329b321b8b --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Random.hs @@ -0,0 +1,186 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-------------------------------------------------------------------------------- +module Xanthous.Random + ( Choose(..) + , ChooseElement(..) + , Weighted(..) + , evenlyWeighted + , weightedBy + , subRand + , chance + , chooseSubset + , chooseRange + , FiniteInterval(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.List.NonEmpty (NonEmpty(..)) +import Control.Monad.Random.Class (MonadRandom(getRandomR, getRandom)) +import Control.Monad.Random (Rand, evalRand, mkStdGen, StdGen) +import Data.Functor.Compose +import Data.Random.Shuffle.Weighted +import Data.Random.Distribution +import Data.Random.Distribution.Uniform +import Data.Random.Distribution.Uniform.Exclusive +import Data.Random.Sample +import qualified Data.Random.Source as DRS +import Data.Interval ( Interval, lowerBound', Extended (Finite) + , upperBound', Boundary (Closed), lowerBound, upperBound + ) +-------------------------------------------------------------------------------- + +instance {-# INCOHERENT #-} (Monad m, MonadRandom m) => DRS.MonadRandom m where + getRandomWord8 = getRandom + getRandomWord16 = getRandom + getRandomWord32 = getRandom + getRandomWord64 = getRandom + getRandomDouble = getRandom + getRandomNByteInteger n = getRandomR (0, 256 ^ n) + +class Choose a where + type RandomResult a + choose :: MonadRandom m => a -> m (RandomResult a) + +newtype ChooseElement a = ChooseElement a + +instance MonoFoldable a => Choose (ChooseElement a) where + type RandomResult (ChooseElement a) = Maybe (Element a) + choose (ChooseElement xs) = do + chosenIdx <- getRandomR (0, olength xs - 1) + let pick _ (Just x) = Just x + pick (x, i) Nothing + | i == chosenIdx = Just x + | otherwise = Nothing + pure $ ofoldr pick Nothing $ zip (toList xs) [0..] + +instance MonoFoldable a => Choose (NonNull a) where + type RandomResult (NonNull a) = Element a + choose + = fmap (fromMaybe (error "unreachable")) -- why not lol + . choose + . ChooseElement + . toNullable + +instance Choose (NonEmpty a) where + type RandomResult (NonEmpty a) = a + choose = choose . fromNonEmpty @[_] + +instance Choose (a, a) where + type RandomResult (a, a) = a + choose (x, y) = choose (x :| [y]) + +newtype Weighted w t a = Weighted (t (w, a)) + deriving (Functor, Foldable) via (t `Compose` (,) w) + +deriving newtype instance Eq (t (w, a)) => Eq (Weighted w t a) +deriving newtype instance Show (t (w, a)) => Show (Weighted w t a) +deriving newtype instance NFData (t (w, a)) => NFData (Weighted w t a) + +instance Traversable t => Traversable (Weighted w t) where + traverse f (Weighted twa) = Weighted <$> (traverse . traverse) f twa + +evenlyWeighted :: [a] -> Weighted Int [] a +evenlyWeighted = Weighted . itoList + +-- | Weight the elements of some functor by a function. Larger values of 'w' per +-- its 'Ord' instance will be more likely to be generated +weightedBy :: Functor t => (a -> w) -> t a -> Weighted w t a +weightedBy weighting xs = Weighted $ (weighting &&& id) <$> xs + +instance (Num w, Ord w, Distribution Uniform w, Excludable w) + => Choose (Weighted w [] a) where + type RandomResult (Weighted w [] a) = Maybe a + choose (Weighted ws) = sample $ headMay <$> weightedSample 1 ws + +instance (Num w, Ord w, Distribution Uniform w, Excludable w) + => Choose (Weighted w NonEmpty a) where + type RandomResult (Weighted w NonEmpty a) = a + choose (Weighted ws) = + sample + $ fromMaybe (error "unreachable") . headMay + <$> weightedSample 1 (toList ws) + +subRand :: MonadRandom m => Rand StdGen a -> m a +subRand sub = evalRand sub . mkStdGen <$> getRandom + +-- | Has a @n@ chance of returning 'True' +-- +-- eg, chance 0.5 will return 'True' half the time +chance + :: (Num w, Ord w, Distribution Uniform w, Excludable w, MonadRandom m) + => w + -> m Bool +chance n = choose $ weightedBy (bool 1 (n * 2)) bools + +-- | Choose a random subset of *about* @w@ of the elements of the given +-- 'Witherable' structure +chooseSubset :: ( Num w, Ord w, Distribution Uniform w, Excludable w + , Witherable t + , MonadRandom m + ) => w -> t a -> m (t a) +chooseSubset = filterA . const . chance + +-- | Choose a random @n@ in the given interval +chooseRange + :: ( MonadRandom m + , Distribution Uniform n + , Enum n + , Bounded n + , Ord n + ) + => Interval n + -> m (Maybe n) +chooseRange int = traverse sample distribution + where + (lower, lowerBoundary) = lowerBound' int + lowerR = case lower of + Finite x -> if lowerBoundary == Closed + then x + else succ x + _ -> minBound + (upper, upperBoundary) = upperBound' int + upperR = case upper of + Finite x -> if upperBoundary == Closed + then x + else pred x + _ -> maxBound + distribution + | lowerR <= upperR = Just $ Uniform lowerR upperR + | otherwise = Nothing + +instance ( Distribution Uniform n + , Enum n + , Bounded n + , Ord n + ) + => Choose (Interval n) where + type RandomResult (Interval n) = n + choose = fmap (fromMaybe $ error "Invalid interval") . chooseRange + +newtype FiniteInterval a + = FiniteInterval { unwrapFiniteInterval :: (Interval a) } + +instance ( Distribution Uniform n + , Ord n + ) + => Choose (FiniteInterval n) where + type RandomResult (FiniteInterval n) = n + -- TODO broken with open/closed right now + choose + = sample + . uncurry Uniform + . over both getFinite + . (lowerBound &&& upperBound) + . unwrapFiniteInterval + where + getFinite (Finite x) = x + getFinite _ = error "Infinite value" + +-------------------------------------------------------------------------------- + +bools :: NonEmpty Bool +bools = True :| [False] diff --git a/users/aspen/xanthous/src/Xanthous/Util.hs b/users/aspen/xanthous/src/Xanthous/Util.hs new file mode 100644 index 0000000000..f918340f05 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE QuantifiedConstraints #-} +-------------------------------------------------------------------------------- +module Xanthous.Util + ( EqEqProp(..) + , EqProp(..) + , 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 + , smallestNotIn + , removeVectorIndex + , removeFirst + , maximum1 + , minimum1 + + -- * Combinators + , times, times_, endoTimes + + -- * State utilities + , modifyK, modifyKL, useListOf + + -- * Type-level programming utils + , KnownBool(..) + + -- * + , AlphaChar(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (foldr) +-------------------------------------------------------------------------------- +import Test.QuickCheck.Checkers +import Data.Foldable (foldr) +import Data.Monoid +import Data.Proxy +import qualified Data.Vector as V +import Data.Semigroup (Max(..), Min(..)) +import Data.Semigroup.Foldable +import Control.Monad.State.Class +import Control.Monad.State (evalState) +-------------------------------------------------------------------------------- + +newtype EqEqProp a = EqEqProp a + deriving newtype Eq + +instance Eq a => EqProp (EqEqProp a) where + (=-=) = eq + +foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b +foldlMapM f = foldr f' (pure mempty) + where + f' :: a -> m b -> m b + f' x = liftA2 mappend (f x) + +-- Strict in the monoidal accumulator. For monads strict +-- in the left argument of bind, this will run in constant +-- space. +foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b +foldlMapM' f xs = foldr f' pure xs mempty + where + f' :: a -> (b -> m b) -> b -> m b + f' x k bl = do + br <- f x + let !b = mappend bl br + k b + +-- | Returns whether the third argument is in the range given by the first two +-- arguments, inclusive +-- +-- >>> between (0 :: Int) 2 2 +-- True +-- +-- >>> between (0 :: Int) 2 3 +-- False +between + :: Ord a + => a -- ^ lower bound + -> a -- ^ upper bound + -> 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 [] + +-- | Returns the smallest value not in a list +smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a +smallestNotIn xs = case uniq $ sort xs of + [] -> minBound + xs'@(x : _) + | x > minBound -> minBound + | otherwise + -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..] + +-- | Remove the element at the given index, if any, from the given vector +removeVectorIndex :: Int -> Vector a -> Vector a +removeVectorIndex idx vect = + let (before, after) = V.splitAt idx vect + in before <> fromMaybe Empty (tailMay after) + +-- | Remove the first element in a sequence that matches a given predicate +removeFirst :: IsSequence seq => (Element seq -> Bool) -> seq -> seq +removeFirst p + = flip evalState False + . filterM (\x -> do + found <- get + let matches = p x + when matches $ put True + pure $ found || not matches) + +maximum1 :: (Ord a, Foldable1 f) => f a -> a +maximum1 = getMax . foldMap1 Max + +minimum1 :: (Ord a, Foldable1 f) => f a -> a +minimum1 = getMin . foldMap1 Min + +times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b] +times n f = traverse f [1..n] + +times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a] +times_ n fa = times n (const fa) + +-- | Multiply an endomorphism by an integral +-- +-- >>> endoTimes (4 :: Int) succ (5 :: Int) +-- 9 +endoTimes :: Integral n => n -> (a -> a) -> a -> a +endoTimes n f = appEndo $ stimes n (Endo f) + +-------------------------------------------------------------------------------- + +-- | This class gives a boolean associated with a type-level bool, a'la +-- 'KnownSymbol', 'KnownNat' etc. +class KnownBool (bool :: Bool) where + boolVal' :: forall proxy. proxy bool -> Bool + boolVal' _ = boolVal @bool + + boolVal :: Bool + boolVal = boolVal' $ Proxy @bool + +instance KnownBool 'True where boolVal = True +instance KnownBool 'False where boolVal = False + +-------------------------------------------------------------------------------- + +-- | Modify some monadic state via the application of a kleisli endomorphism on +-- the state itself +-- +-- Note that any changes made to the state during execution of @k@ will be +-- overwritten +-- +-- @@ +-- modifyK pure === pure () +-- @@ +modifyK :: MonadState s m => (s -> m s) -> m () +modifyK k = get >>= k >>= put + +-- | Modify some monadic state via the application of a kleisli endomorphism on +-- the target of a lens +-- +-- Note that any changes made to the state during execution of @k@ will be +-- overwritten +-- +-- @@ +-- modifyKL id pure === pure () +-- @@ +modifyKL :: MonadState s m => LensLike m s s a b -> (a -> m b) -> m () +modifyKL l k = get >>= traverseOf l k >>= put + +-- | Use a list of all the targets of a 'Fold' in the current state +-- +-- @@ +-- evalState (useListOf folded) === toList +-- @@ +useListOf :: MonadState s m => Getting (Endo [a]) s a -> m [a] +useListOf = gets . toListOf + +-------------------------------------------------------------------------------- + +-- | A newtype wrapper around 'Char' whose 'Enum' and 'Bounded' instances only +-- include the characters @[a-zA-Z]@ +-- +-- >>> succ (AlphaChar 'z') +-- 'A' +newtype AlphaChar = AlphaChar { getAlphaChar :: Char } + deriving stock Show + deriving (Eq, Ord) via Char + +instance Enum AlphaChar where + toEnum n + | between 0 25 n + = AlphaChar . toEnum $ n + fromEnum 'a' + | between 26 51 n + = AlphaChar . toEnum $ n - 26 + fromEnum 'A' + | otherwise + = error $ "Tag " <> show n <> " out of range [0, 51] for enum AlphaChar" + fromEnum (AlphaChar chr) + | between 'a' 'z' chr + = fromEnum chr - fromEnum 'a' + | between 'A' 'Z' chr + = fromEnum chr - fromEnum 'A' + | otherwise + = error $ "Invalid value for alpha char: " <> show chr + +instance Bounded AlphaChar where + minBound = AlphaChar 'a' + maxBound = AlphaChar 'Z' diff --git a/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs b/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs new file mode 100644 index 0000000000..9e158cc8e2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs @@ -0,0 +1,24 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.Comonad + ( -- * Store comonad utils + replace + , current + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Control.Comonad.Store.Class +-------------------------------------------------------------------------------- + +-- | Replace the current position of a store comonad with a new value by +-- comparing positions +replace :: (Eq i, ComonadStore i w) => w a -> a -> w a +replace w x = w =>> \w' -> if pos w' == pos w then x else extract w' +{-# INLINE replace #-} + +-- | Lens into the current position of a store comonad. +-- +-- current = lens extract replace +current :: (Eq i, ComonadStore i w) => Lens' (w a) a +current = lens extract replace +{-# INLINE current #-} diff --git a/users/aspen/xanthous/src/Xanthous/Util/Graph.hs b/users/aspen/xanthous/src/Xanthous/Util/Graph.hs new file mode 100644 index 0000000000..8e5c04f4bf --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/Graph.hs @@ -0,0 +1,33 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.Graph where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Graph.Inductive.Query.MST (msTree) +import qualified Data.Graph.Inductive.Graph as Graph +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Basic (undir) +import Data.Set (isSubsetOf) +-------------------------------------------------------------------------------- + +mstSubGraph + :: forall gr node edge. (DynGraph gr, Real edge, Show edge) + => gr node edge -> gr node edge +mstSubGraph graph = insEdges mstEdges . insNodes (labNodes graph) $ Graph.empty + where + mstEdges = ordNub $ do + LP path <- msTree $ undir graph + case path of + [] -> [] + [_] -> [] + ((n₂, edgeWeight) : (n₁, _) : _) -> + pure (n₁, n₂, edgeWeight) + +isSubGraphOf + :: (Graph gr1, Graph gr2, Ord node, Ord edge) + => gr1 node edge + -> gr2 node edge + -> Bool +isSubGraphOf graph₁ graph₂ + = setFromList (labNodes graph₁) `isSubsetOf` setFromList (labNodes graph₂) + && setFromList (labEdges graph₁) `isSubsetOf` setFromList (labEdges graph₂) diff --git a/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs b/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs new file mode 100644 index 0000000000..0cb009f45a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Graphics algorithms and utils for rendering things in 2D space +-------------------------------------------------------------------------------- +module Xanthous.Util.Graphics + ( circle + , filledCircle + , line + , straightLine + , delaunay + + -- * Debugging and testing tools + , renderBooleanGraphics + , showBooleanGraphics + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +-- https://github.com/noinia/hgeometry/issues/28 +-- import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer +-- as Geometry +import qualified Algorithms.Geometry.DelaunayTriangulation.Naive + as Geometry +import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry +import Control.Monad.State (execState, State) +import qualified Data.Geometry.Point as Geometry +import Data.Ext ((:+)(..)) +import Data.List (unfoldr) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NE +import Data.Ix (Ix) +import Linear.V2 +-------------------------------------------------------------------------------- + + +-- | Generate a circle centered at the given point and with the given radius +-- using the <midpoint circle algorithm +-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>. +-- +-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell> +circle :: (Num i, Ord i) + => V2 i -- ^ center + -> i -- ^ radius + -> [V2 i] +circle (V2 x₀ y₀) radius + -- Four initial points, plus the generated points + = V2 x₀ (y₀ + radius) + : V2 x₀ (y₀ - radius) + : V2 (x₀ + radius) y₀ + : V2 (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 (V2 x y) + = [ V2 (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 (V2 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 + + +data FillState i + = FillState + { _inCircle :: Bool + , _result :: NonEmpty (V2 i) + } +makeLenses ''FillState + +runFillState :: NonEmpty (V2 i) -> State (FillState i) a -> [V2 i] +runFillState circumference s + = toList + . view result + . execState s + $ FillState False circumference + +-- | Generate a *filled* circle centered at the given point and with the given +-- radius by filling a circle generated with 'circle' +filledCircle :: (Num i, Integral i, Ix i) + => V2 i -- ^ center + -> i -- ^ radius + -> [V2 i] +filledCircle center radius = + case NE.nonEmpty (circle center radius) of + Nothing -> [] + Just circumference -> runFillState circumference $ + -- the first and last lines of all circles are solid, so the whole "in the + -- circle, out of the circle" thing doesn't work... but that's fine since + -- we don't need to fill them. So just skip them + for_ [succ minX..pred maxX] $ \x -> + for_ [minY..maxY] $ \y -> do + let pt = V2 x y + next = V2 x $ succ y + whenM (use inCircle) $ result %= NE.cons pt + + when (pt `elem` circumference && next `notElem` circumference) + $ inCircle %= not + + where + (V2 minX minY, V2 maxX maxY) = minmaxes circumference + +-- | Draw a line between two points using Bresenham's line drawing algorithm +-- +-- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm> +line :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i] +line pa@(V2 xa ya) pb@(V2 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 view _yx else id + [V2 x₁ y₁, V2 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 (V2 xTemp yTemp, (xTemp + 1, newY, newError)) + where + tempError = err + δy + (newY, newError) = if (2 * tempError) >= δx + then (yTemp + ystep, tempError - δx) + else (yTemp, tempError) +{-# SPECIALIZE line :: V2 Int -> V2 Int -> [V2 Int] #-} +{-# SPECIALIZE line :: V2 Word -> V2 Word -> [V2 Word] #-} + +straightLine :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i] +straightLine pa@(V2 xa _) pb@(V2 _ yb) = line pa midpoint ++ line midpoint pb + where midpoint = V2 xa yb + +delaunay + :: (Ord n, Fractional n) + => NonEmpty (V2 n, p) + -> [((V2 n, p), (V2 n, p))] +delaunay + = map (over both fromPoint) + . Geometry.edgesAsPoints + . Geometry.delaunayTriangulation + . map toPoint + where + toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid + fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid) + +-------------------------------------------------------------------------------- + +renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> String +renderBooleanGraphics [] = "" +renderBooleanGraphics (pt : pts') = intercalate "\n" rows + where + rows = row <$> [minX..maxX] + row x = [minY..maxY] <&> \y -> if V2 x y `member` ptSet then 'X' else ' ' + (V2 minX minY, V2 maxX maxY) = minmaxes pts + pts = pt :| pts' + ptSet :: Set (V2 i) + ptSet = setFromList $ toList pts + +showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> IO () +showBooleanGraphics = putStrLn . pack . renderBooleanGraphics + +minmaxes :: forall i. (Ord i) => NonEmpty (V2 i) -> (V2 i, V2 i) +minmaxes xs = + ( V2 (minimum1Of (traverse1 . _x) xs) + (minimum1Of (traverse1 . _y) xs) + , V2 (maximum1Of (traverse1 . _x) xs) + (maximum1Of (traverse1 . _y) xs) + ) diff --git a/users/aspen/xanthous/src/Xanthous/Util/Inflection.hs b/users/aspen/xanthous/src/Xanthous/Util/Inflection.hs new file mode 100644 index 0000000000..724f2339dd --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/Inflection.hs @@ -0,0 +1,14 @@ + +module Xanthous.Util.Inflection + ( toSentence + ) where + +import Xanthous.Prelude + +toSentence :: (MonoFoldable mono, Element mono ~ Text) => mono -> Text +toSentence xs = case reverse . toList $ xs of + [] -> "" + [x] -> x + [b, a] -> a <> " and " <> b + (final : butlast) -> + intercalate ", " (reverse butlast) <> ", and " <> final diff --git a/users/aspen/xanthous/src/Xanthous/Util/JSON.hs b/users/aspen/xanthous/src/Xanthous/Util/JSON.hs new file mode 100644 index 0000000000..91d1328e4a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/JSON.hs @@ -0,0 +1,19 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.JSON + ( ReadShowJSON(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Data.Aeson +-------------------------------------------------------------------------------- + +newtype ReadShowJSON a = ReadShowJSON a + deriving newtype (Read, Show) + +instance Show a => ToJSON (ReadShowJSON a) where + toJSON = toJSON . show + +instance Read a => FromJSON (ReadShowJSON a) where + parseJSON = withText "readable" + $ maybe (fail "Could not read") pure . readMay diff --git a/users/aspen/xanthous/src/Xanthous/Util/Optparse.hs b/users/aspen/xanthous/src/Xanthous/Util/Optparse.hs new file mode 100644 index 0000000000..dfa6537235 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/Optparse.hs @@ -0,0 +1,21 @@ +-------------------------------------------------------------------------------- +module Xanthous.Util.Optparse + ( readWithGuard + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import qualified Options.Applicative as Opt +-------------------------------------------------------------------------------- + +readWithGuard + :: Read b + => (b -> Bool) + -> (b -> String) + -> Opt.ReadM b +readWithGuard predicate errmsg = do + res <- Opt.auto + unless (predicate res) + $ Opt.readerError + $ errmsg res + pure res diff --git a/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs new file mode 100644 index 0000000000..aa881b3227 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE UndecidableInstances #-} +module Xanthous.Util.QuickCheck + ( functionShow + , FunctionShow(..) + , functionJSON + , FunctionJSON(..) + , genericArbitrary + , GenericArbitrary(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck.Arbitrary.Generic +import Data.Aeson +-------------------------------------------------------------------------------- + +newtype FunctionShow a = FunctionShow a + deriving newtype (Show, Read) + +instance (Show a, Read a) => Function (FunctionShow a) where + function = functionShow + +functionJSON :: (ToJSON a, FromJSON a) => (a -> c) -> a :-> c +functionJSON = functionMap encode (headEx . decode) + +newtype FunctionJSON a = FunctionJSON a + deriving newtype (ToJSON, FromJSON) + +instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where + function = functionJSON diff --git a/users/aspen/xanthous/src/Xanthous/keybindings.yaml b/users/aspen/xanthous/src/Xanthous/keybindings.yaml new file mode 100644 index 0000000000..cffb27cb03 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/keybindings.yaml @@ -0,0 +1,22 @@ +q: Quit +?: Help +.: Wait +C-p: PreviousMessage +',': PickUp +d: Drop +o: Open +c: Close +;: Look +e: Eat +S: Save +r: Read +i: ShowInventory +I: DescribeInventory +w: Wield +f: Fire +'<': GoUp +'>': GoDown +R: Rest + +# Debug commands +M-r: ToggleRevealAll diff --git a/users/aspen/xanthous/src/Xanthous/messages.yaml b/users/aspen/xanthous/src/Xanthous/messages.yaml new file mode 100644 index 0000000000..bc08ec1ad2 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/messages.yaml @@ -0,0 +1,161 @@ +welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Press ? for help. +dead: + - You have died... + - You die... + - You perish... + - You have perished... + +generic: + continue: Press enter to continue... + +save: + disabled: "Sorry, saving is currently disabled" + location: "Enter filename to save to: " + overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? " + +quit: + confirm: Really quit without saving? + +entities: + description: You see here {{entityDescriptions}} + say: + creature: + visible: The {{creature.creatureType.name}} {{creature.creatureType.sayVerb}} "{{message}}" + invisible: You hear something yell "{{message}}" in the distance + +pickUp: + menu: What would you like to pick up? + pickUp: You pick up the {{item.itemType.name}}. + nothingToPickUp: "There's nothing here to pick up" + +cant: + goUp: + - You can't go up here + - There's nothing here that would let you go up + goDown: + - You can't go down here + - There's nothing here that would let you go down + +open: + prompt: Direction to open (hjklybnu.)? + success: "You open the door." + locked: "That door is locked" + nothingToOpen: "There's nothing to open there." + alreadyOpen: "That door is already open." + +close: + prompt: Direction to close (hjklybnu.)? + success: + - You close the door. + - You shut the door. + nothingToClose: "There's nothing to close there." + alreadyClosed: "That door is already closed." + blocked: "The {{entityDescriptions}} {{blockOrBlocks}} the door!" + +look: + prompt: Select a position on the map to describe (use Enter to confirm) + nothing: There's nothing there + +character: + namePrompt: "What's your name? " + body: + knuckles: + calluses: + - You've started developing calluses on your knuckles from all the punching you've been doing. + - You've been fighting with your fists so much they're starting to develop calluses. + +combat: + nothingToAttack: There's nothing to attack there. + menu: Which creature would you like to attack? + fistSelfDamage: + - You hit so hard with your fists you hurt yourself! + - The punch leaves your knuckles bloody! + fistExtraSelfDamage: + - You hurt your already-bloody fists with the strike! + - Ouch! Your fists were already bleeding! + hit: + fists: + - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot. + - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles. + generic: + - You hit the {{creature.creatureType.name}}. + - You attack the {{creature.creatureType.name}}. + creatureAttack: + natural: The {{creature.creatureType.name}} {{attackDescription}}. + genericWeapon: The {{creature.creatureType.name}} attacks you with its {{item.itemType.name}}. + killed: + - You kill the {{creature.creatureType.name}}! + - You've killed the {{creature.creatureType.name}}! + +debug: + toggleRevealAll: revealAll now set to {{revealAll}} + +eat: + noFood: + - You have nothing edible. + - You don't have any food. + - You don't have anything to eat. + - You search your pockets for something edible, and come up short. + menuPrompt: What would you like to eat? + eat: You eat the {{item.itemType.name}}. + +read: + prompt: Direction to read (hjklybnu.)? + nothing: "There's nothing there to read" + result: "\"{{message}}\"" + +inventory: + describe: + select: Select an item in your inventory to describe + nothing: You aren't carrying anything + +wield: + nothing: + - You aren't carrying anything you can wield + - You can't wield anything in your backpack + - You can't wield anything currently in your backpack + menu: What would you like to wield? + hand: Wield in which hand? + wielded: You wield the {{item.wieldedItem.itemType.name}} in {{hand}} + +fire: + nothing: + - You don't currently have anything you can throw + - You don't have anything to throw + zeroRange: + - That item is too heavy to throw! + - That's too heavy to throw + - You're not strong enough to throw that any meaningful distance + menu: What would you like to throw? + target: Choose a target + atRange: + - It's too heavy for you to throw any further than this + fired: + noTarget: + - You throw the {{item.itemType.name}} at the ground + noDamage: + - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to care. + - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to do anything. + - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It doesn't seem to hurt it. + someDamage: + - You throw the {{item.itemType.name}} at the {{creature.creatureType.name}}. It hits it on the head!. + +drop: + nothing: You aren't carrying anything + menu: What would you like to drop? + # TODO: use actual hands + dropped: + - You drop the {{item.itemType.name}}. + - You drop the {{item.itemType.name}} on the ground. + - You put the {{item.itemType.name}} on the ground. + - You take the {{item.itemType.name}} out of your backpack and put it on the ground. + - You take the {{item.itemType.name}} out of your backpack and drop it on the ground. + +autocommands: + enemyInSight: There's a {{firstEntity.creatureType.name}} nearby! + resting: Resting... + doneResting: Done resting +### + +tutorial: + message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance! You can pick items up with ,. |