diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous')
68 files changed, 0 insertions, 9759 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs b/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs deleted file mode 100644 index 1f2b513ffe0e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/AI/Gormlak.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs deleted file mode 100644 index 426230cdc2fc..000000000000 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ /dev/null @@ -1,647 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/App/Autocommands.hs b/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs deleted file mode 100644 index 5d4db1a47465..000000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Autocommands.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/App/Common.hs b/users/grfn/xanthous/src/Xanthous/App/Common.hs deleted file mode 100644 index 69ba6f0e0596..000000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Common.hs +++ /dev/null @@ -1,67 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs deleted file mode 100644 index 799281a1c2fd..000000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/App/Time.hs b/users/grfn/xanthous/src/Xanthous/App/Time.hs deleted file mode 100644 index cca352858d9c..000000000000 --- a/users/grfn/xanthous/src/Xanthous/App/Time.hs +++ /dev/null @@ -1,42 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Command.hs b/users/grfn/xanthous/src/Xanthous/Command.hs deleted file mode 100644 index 6e6274a02c6f..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Command.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs deleted file mode 100644 index 703955206a7e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ /dev/null @@ -1,822 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Data/App.hs b/users/grfn/xanthous/src/Xanthous/Data/App.hs deleted file mode 100644 index 13c4b5d61068..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/App.hs +++ /dev/null @@ -1,47 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Data/Entities.hs b/users/grfn/xanthous/src/Xanthous/Data/Entities.hs deleted file mode 100644 index 39953410f2f3..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/Entities.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Data.Entities - ( -- * Collisions - Collision(..) - , _Stop - , _Combat - -- * Entity Attributes - , EntityAttributes(..) - , blocksVision - , blocksObject - , collision - , defaultEntityAttributes - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON(..), FromJSON(..), (.:?), (.!=), withObject) -import Data.Aeson.Generic.DerivingVia -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Test.QuickCheck --------------------------------------------------------------------------------- - -data Collision - = Stop -- ^ Can't move through this - | Combat -- ^ Moving into this equates to hitting it with a stick - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Collision - deriving (ToJSON, FromJSON) - via WithOptions '[ AllNullaryToStringTag 'True ] - Collision -makePrisms ''Collision - --- | Attributes of an entity -data EntityAttributes = EntityAttributes - { _blocksVision :: Bool - -- | Does this entity block a large object from being put in the same tile as - -- it - eg a a door being closed on it - , _blocksObject :: Bool - -- | What type of collision happens when moving into this entity? - , _collision :: Collision - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EntityAttributes - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - EntityAttributes -makeLenses ''EntityAttributes - -instance FromJSON EntityAttributes where - parseJSON = withObject "EntityAttributes" $ \o -> do - _blocksVision <- o .:? "blocksVision" - .!= _blocksVision defaultEntityAttributes - _blocksObject <- o .:? "blocksObject" - .!= _blocksObject defaultEntityAttributes - _collision <- o .:? "collision" - .!= _collision defaultEntityAttributes - pure EntityAttributes {..} - -defaultEntityAttributes :: EntityAttributes -defaultEntityAttributes = EntityAttributes - { _blocksVision = False - , _blocksObject = False - , _collision = Stop - } diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs deleted file mode 100644 index 855a3462daee..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityChar.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.EntityChar - ( EntityChar(..) - , HasChar(..) - , HasStyle(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((.=)) --------------------------------------------------------------------------------- -import qualified Graphics.Vty.Attributes as Vty -import Test.QuickCheck -import Data.Aeson --------------------------------------------------------------------------------- -import Xanthous.Orphans () -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) --------------------------------------------------------------------------------- - - -class HasChar s a | s -> a where - char :: Lens' s a - {-# MINIMAL char #-} - -data EntityChar = EntityChar - { _char :: Char - , _style :: Vty.Attr - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EntityChar -makeFieldsNoPrefix ''EntityChar - -instance FromJSON EntityChar where - parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr - parseJSON (Object o) = do - (EntityChar _char _) <- o .: "char" - _style <- o .:? "style" .!= Vty.defAttr - pure EntityChar {..} - parseJSON _ = fail "Invalid type, expected string or object" - -instance ToJSON EntityChar where - toJSON (EntityChar chr styl) - | styl == Vty.defAttr = String $ chr <| Empty - | otherwise = object - [ "char" .= chr - , "style" .= styl - ] - -instance IsString EntityChar where - fromString [ch] = EntityChar ch Vty.defAttr - fromString _ = error "Entity char must only be a single character" diff --git a/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs deleted file mode 100644 index 33a98f1ae5a9..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityMap.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap - ( EntityMap - , _EntityMap - , EntityID - , emptyEntityMap - , insertAt - , insertAtReturningID - , fromEIDsAndPositioned - , toEIDsAndPositioned - , atPosition - , atPositionWithIDs - , positions - , lookup - , lookupWithPosition - , 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/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs deleted file mode 100644 index 1398c611cf20..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ /dev/null @@ -1,72 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Data/Levels.hs b/users/grfn/xanthous/src/Xanthous/Data/Levels.hs deleted file mode 100644 index 13251d8afdf2..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/Levels.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Data/Memo.hs b/users/grfn/xanthous/src/Xanthous/Data/Memo.hs deleted file mode 100644 index 2b2ee0f96028..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/Memo.hs +++ /dev/null @@ -1,98 +0,0 @@ --------------------------------------------------------------------------------- --- | 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/grfn/xanthous/src/Xanthous/Data/NestedMap.hs b/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs deleted file mode 100644 index 1b875d448302..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/NestedMap.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PolyKinds #-} --------------------------------------------------------------------------------- -module Xanthous.Data.NestedMap - ( NestedMapVal(..) - , NestedMap(..) - , lookup - , lookupVal - , insert - - -- * - , (:->) - , BifunctorFunctor'(..) - , BifunctorMonad'(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup, foldMap) -import qualified Xanthous.Prelude as P --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson -import Data.Function (fix) -import Data.Foldable (Foldable(..)) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE --------------------------------------------------------------------------------- - --- | Natural transformations on bifunctors -type (:->) p q = forall a b. p a b -> q a b -infixr 0 :-> - -class (forall b. Bifunctor b => Bifunctor (t b)) => BifunctorFunctor' t where - bifmap' :: (Bifunctor p, Bifunctor q) => (p :-> q) -> t p :-> t q - -class BifunctorFunctor' t => BifunctorMonad' t where - bireturn' :: (Bifunctor p) => p :-> t p - - bibind' :: (Bifunctor p, Bifunctor q) => (p :-> t q) -> t p :-> t q - bibind' f = bijoin' . bifmap' f - - bijoin' :: (Bifunctor p) => t (t p) :-> t p - bijoin' = bibind' id - - {-# MINIMAL bireturn', (bibind' | bijoin') #-} - --------------------------------------------------------------------------------- - -data NestedMapVal m k v = Val v | Nested (NestedMap m k v) - -deriving stock instance - ( forall k' v'. (Show k', Show v') => Show (m k' v') - , Show k - , Show v - ) => Show (NestedMapVal m k v) - -deriving stock instance - ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') - , Eq k - , Eq v - ) => Eq (NestedMapVal m k v) - -instance - forall m k v. - ( Arbitrary (m k v) - , Arbitrary (m k (NestedMapVal m k v)) - , Arbitrary k - , Arbitrary v - , IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) => Arbitrary (NestedMapVal m k v) where - arbitrary = sized . fix $ \gen n -> - let nst = fmap (NestedMap . mapFromList) - . listOf - $ (,) <$> arbitrary @k <*> gen (n `div` 2) - in if n == 0 - then Val <$> arbitrary - else oneof [ Val <$> arbitrary - , Nested <$> nst] - shrink (Val v) = Val <$> shrink v - shrink (Nested mkv) = Nested <$> shrink mkv - -instance Functor (m k) => Functor (NestedMapVal m k) where - fmap f (Val v) = Val $ f v - fmap f (Nested m) = Nested $ fmap f m - -instance Bifunctor m => Bifunctor (NestedMapVal m) where - bimap _ g (Val v) = Val $ g v - bimap f g (Nested m) = Nested $ bimap f g m - -instance BifunctorFunctor' NestedMapVal where - bifmap' _ (Val v) = Val v - bifmap' f (Nested m) = Nested $ bifmap' f m - -instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) - => ToJSON (NestedMapVal m k v) where - toJSON (Val v) = toJSON v - toJSON (Nested m) = toJSON m - -instance Foldable (m k) => Foldable (NestedMapVal m k) where - foldMap f (Val v) = f v - foldMap f (Nested m) = foldMap f m - --- _NestedMapVal --- :: forall m k v m' k' v'. --- ( IsMap (m k v), IsMap (m' k' v') --- , IsMap (m [k] v), IsMap (m' [k'] v') --- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' --- , ContainerKey (m [k] v) ~ [k], ContainerKey (m' [k'] v') ~ [k'] --- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' --- , MapValue (m [k] v) ~ v, MapValue (m' [k'] v') ~ v' --- ) --- => Iso (NestedMapVal m k v) --- (NestedMapVal m' k' v') --- (m [k] v) --- (m' [k'] v') --- _NestedMapVal = iso hither yon --- where --- hither :: NestedMapVal m k v -> m [k] v --- hither (Val v) = singletonMap [] v --- hither (Nested m) = bimap _ _ $ m ^. _NestedMap --- yon = _ - --------------------------------------------------------------------------------- - -newtype NestedMap m k v = NestedMap (m k (NestedMapVal m k v)) - -deriving stock instance - ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') - , Eq k - , Eq v - ) => Eq (NestedMap m k v) - -deriving stock instance - ( forall k' v'. (Show k', Show v') => Show (m k' v') - , Show k - , Show v - ) => Show (NestedMap m k v) - -instance Arbitrary (m k (NestedMapVal m k v)) - => Arbitrary (NestedMap m k v) where - arbitrary = NestedMap <$> arbitrary - shrink (NestedMap m) = NestedMap <$> shrink m - -instance Functor (m k) => Functor (NestedMap m k) where - fmap f (NestedMap m) = NestedMap $ fmap (fmap f) m - -instance Bifunctor m => Bifunctor (NestedMap m) where - bimap f g (NestedMap m) = NestedMap $ bimap f (bimap f g) m - -instance BifunctorFunctor' NestedMap where - bifmap' f (NestedMap m) = NestedMap . f $ bimap id (bifmap' f) m - -instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) - => ToJSON (NestedMap m k v) where - toJSON (NestedMap m) = toJSON m - -instance Foldable (m k) => Foldable (NestedMap m k) where - foldMap f (NestedMap m) = foldMap (foldMap f) m - --------------------------------------------------------------------------------- - -lookup - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> NestedMap m k v - -> Maybe (NestedMapVal m k v) -lookup (p :| []) (NestedMap vs) = P.lookup p vs -lookup (p :| (p₁ : ps)) (NestedMap vs) = P.lookup p vs >>= \case - (Val _) -> Nothing - (Nested vs') -> lookup (p₁ :| ps) vs' - -lookupVal - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> NestedMap m k v - -> Maybe v -lookupVal ks m - | Just (Val v) <- lookup ks m = Just v - | otherwise = Nothing - -insert - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> v - -> NestedMap m k v - -> NestedMap m k v -insert (k :| []) v (NestedMap m) = NestedMap $ P.insertMap k (Val v) m -insert (k₁ :| (k₂ : ks)) v (NestedMap m) = NestedMap $ alterMap upd k₁ m - where - upd (Just (Nested nm)) = Just . Nested $ insert (k₂ :| ks) v nm - upd _ = Just $ - let (kΩ :| ks') = NE.reverse (k₂ :| ks) - in P.foldl' - (\m' k -> Nested . NestedMap . singletonMap k $ m') - (Nested . NestedMap . singletonMap kΩ $ Val v) - ks' - --- _NestedMap --- :: ( IsMap (m k v), IsMap (m' k' v') --- , IsMap (m (NonEmpty k) v), IsMap (m' (NonEmpty k') v') --- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' --- , ContainerKey (m (NonEmpty k) v) ~ (NonEmpty k) --- , ContainerKey (m' (NonEmpty k') v') ~ (NonEmpty k') --- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' --- , MapValue (m (NonEmpty k) v) ~ v, MapValue (m' (NonEmpty k') v') ~ v' --- ) --- => Iso (NestedMap m k v) --- (NestedMap m' k' v') --- (m (NonEmpty k) v) --- (m' (NonEmpty k') v') --- _NestedMap = iso undefined yon --- where --- hither (NestedMap m) = undefined . mapToList $ m --- yon mkv = undefined diff --git a/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs b/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs deleted file mode 100644 index 2e6d48062a45..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Data/VectorBag.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.VectorBag - (VectorBag(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Aeson -import qualified Data.Vector as V -import Test.QuickCheck -import Test.QuickCheck.Instances.Vector () --------------------------------------------------------------------------------- - --- | Acts exactly like a Vector, except ignores order when testing for equality -newtype VectorBag a = VectorBag (Vector a) - deriving stock - ( Traversable - , Generic - ) - deriving newtype - ( Show - , Read - , Foldable - , FromJSON - , FromJSON1 - , ToJSON - , Reversing - , Applicative - , Functor - , Monad - , Monoid - , Semigroup - , Arbitrary - , CoArbitrary - , Filterable - ) -makeWrapped ''VectorBag - -instance Function a => Function (VectorBag a) where - function = functionMap (\(VectorBag v) -> v) VectorBag - -type instance Element (VectorBag a) = a -deriving via (Vector a) instance MonoFoldable (VectorBag a) -deriving via (Vector a) instance GrowingAppend (VectorBag a) -deriving via (Vector a) instance SemiSequence (VectorBag a) -deriving via (Vector a) instance MonoPointed (VectorBag a) -deriving via (Vector a) instance MonoFunctor (VectorBag a) - -instance Cons (VectorBag a) (VectorBag b) a b where - _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) -> - if V.null v - then Left (VectorBag mempty) - else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v) - -instance AsEmpty (VectorBag a) where - _Empty = prism' (const $ VectorBag Empty) $ \case - (VectorBag Empty) -> Just () - _ -> Nothing - -instance Witherable VectorBag where - wither f (VectorBag v) = VectorBag <$> wither f v - witherM f (VectorBag v) = VectorBag <$> witherM f v - filterA p (VectorBag v) = VectorBag <$> filterA p v - -{- - TODO: - , Ixed - , FoldableWithIndex - , FunctorWithIndex - , TraversableWithIndex - , Snoc - , Each --} - -instance Ord a => Eq (VectorBag a) where - (==) = (==) `on` (view _Wrapped . sort) - -instance Ord a => Ord (VectorBag a) where - compare = compare `on` (view _Wrapped . sort) - -instance MonoTraversable (VectorBag a) where - otraverse f (VectorBag v) = VectorBag <$> otraverse f v - -instance IsSequence (VectorBag a) where - fromList = VectorBag . fromList - break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v - span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v - dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v - takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v - splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v - unsafeSplitAt idx (VectorBag v) = - bimap VectorBag VectorBag $ unsafeSplitAt idx v - take n (VectorBag v) = VectorBag $ take n v - unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v - drop n (VectorBag v) = VectorBag $ drop n v - unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v - partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs deleted file mode 100644 index c8153086f1ac..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs deleted file mode 100644 index 368b03f25bed..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Xanthous.Entities.Common --- Description : Common data type definitions and utilities for entities --- --------------------------------------------------------------------------------- -module Xanthous.Entities.Common - ( -- * Inventory - Inventory(..) - , HasInventory(..) - , backpack - , wielded - , items - , InventoryPosition(..) - , describeInventoryPosition - , inventoryPosition - , itemsWithPosition - , removeItemFromPosition - - -- ** Wielded items - , Wielded(..) - , nothingWielded - , hands - , leftHand - , rightHand - , inLeftHand - , inRightHand - , doubleHanded - , Hand(..) - , itemsInHand - , inHand - , wieldInHand - , describeHand - , wieldedItems - , WieldedItem(..) - , wieldedItem - , wieldableItem - , asWieldedItem - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia -import Test.QuickCheck -import Test.QuickCheck.Checkers (EqProp) --------------------------------------------------------------------------------- -import Xanthous.Data (Positioned(..), positioned) -import Xanthous.Util.QuickCheck -import Xanthous.Game.State -import Xanthous.Entities.Item -import Xanthous.Entities.RawTypes (WieldableItem, wieldable) -import Xanthous.Util (removeFirst, EqEqProp(..)) --------------------------------------------------------------------------------- - -data WieldedItem = WieldedItem - { _wieldedItem :: Item - , _wieldableItem :: WieldableItem - -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - WieldedItem -makeFieldsNoPrefix ''WieldedItem - -asWieldedItem :: Prism' Item WieldedItem -asWieldedItem = prism' hither yon - where - yon item = WieldedItem item <$> item ^. itemType . wieldable - hither (WieldedItem item _) = item - -instance Brain WieldedItem where - step ticks (Positioned p wi) = - over positioned (\i -> WieldedItem i $ wi ^. wieldableItem) - <$> step ticks (Positioned p $ wi ^. wieldedItem) - -instance Draw WieldedItem where - draw = draw . view wieldedItem - -instance Entity WieldedItem where - entityAttributes = entityAttributes . view wieldedItem - description = description . view wieldedItem - entityChar = entityChar . view wieldedItem - -instance Arbitrary WieldedItem where - arbitrary = genericArbitrary <&> \wi -> - wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem - -data Wielded - = DoubleHanded WieldedItem - | Hands { _leftHand :: !(Maybe WieldedItem) - , _rightHand :: !(Maybe WieldedItem) - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Wielded - deriving (ToJSON, FromJSON) - via WithOptions '[ 'SumEnc 'ObjWithSingleField ] - Wielded - - -nothingWielded :: Wielded -nothingWielded = Hands Nothing Nothing - -hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem) -hands = prism' (uncurry Hands) $ \case - Hands l r -> Just (l, r) - _ -> Nothing - -leftHand :: Traversal' Wielded (Maybe WieldedItem) -leftHand = hands . _1 - -inLeftHand :: WieldedItem -> Wielded -inLeftHand wi = Hands (Just wi) Nothing - -rightHand :: Traversal' Wielded (Maybe WieldedItem) -rightHand = hands . _2 - -inRightHand :: WieldedItem -> Wielded -inRightHand wi = Hands Nothing (Just wi) - -doubleHanded :: Prism' Wielded WieldedItem -doubleHanded = prism' DoubleHanded $ \case - DoubleHanded i -> Just i - _ -> Nothing - -wieldedItems :: Traversal' Wielded WieldedItem -wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded -wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r - - -data Hand - = LeftHand - | RightHand - | BothHands - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Hand - -itemsInHand :: Hand -> Wielded -> [WieldedItem] -itemsInHand LeftHand (DoubleHanded wi) = [wi] -itemsInHand LeftHand (Hands lh _) = toList lh -itemsInHand RightHand (DoubleHanded wi) = [wi] -itemsInHand RightHand (Hands _ rh) = toList rh -itemsInHand BothHands (DoubleHanded wi) = [wi] -itemsInHand BothHands (Hands lh rh) = toList lh <> toList rh - -inHand :: Hand -> WieldedItem -> Wielded -inHand LeftHand = inLeftHand -inHand RightHand = inRightHand -inHand BothHands = review doubleHanded - -wieldInHand :: Hand -> WieldedItem -> Wielded -> ([WieldedItem], Wielded) -wieldInHand hand item w = (itemsInHand hand w, doWield) - where - doWield = case (hand, w) of - (LeftHand, Hands _ r) -> Hands (Just item) r - (LeftHand, DoubleHanded _) -> inLeftHand item - (RightHand, Hands l _) -> Hands l (Just item) - (RightHand, DoubleHanded _) -> inRightHand item - (BothHands, _) -> DoubleHanded item - -describeHand :: Hand -> Text -describeHand LeftHand = "your left hand" -describeHand RightHand = "your right hand" -describeHand BothHands = "both hands" - -data Inventory = Inventory - { _backpack :: Vector Item - , _wielded :: Wielded - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Inventory - deriving EqProp via EqEqProp Inventory - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Inventory -makeFieldsNoPrefix ''Inventory - -items :: Traversal' Inventory Item -items k (Inventory bp w) = Inventory - <$> traversed k bp - <*> (wieldedItems . wieldedItem) k w - -type instance Element Inventory = Item - -instance MonoFunctor Inventory where - omap = over items - -instance MonoFoldable Inventory where - ofoldMap = foldMapOf items - ofoldr = foldrOf items - ofoldl' = foldlOf' items - otoList = toListOf items - oall = allOf items - oany = anyOf items - onull = nullOf items - ofoldr1Ex = foldr1Of items - ofoldl1Ex' = foldl1Of' items - headEx = headEx . toListOf items - lastEx = lastEx . toListOf items - -instance MonoTraversable Inventory where - otraverse = traverseOf items - -instance Semigroup Inventory where - inv₁ <> inv₂ = - let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack - (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of - (wielded₁, wielded₂@(DoubleHanded _)) -> - (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) - (wielded₁, wielded₂@(Hands (Just _) (Just _))) -> - (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem)) - (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack') - (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack') - (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) -> - (Hands (Just l₁) (Just r₂), backpack') - (wielded₁@(DoubleHanded _), wielded₂) -> - (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem)) - (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) -> - (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack') - (Hands Nothing r₁, Hands (Just l₂) Nothing) -> - (Hands (Just l₂) r₁, backpack') - (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) -> - (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack') - (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) -> - (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack') - (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) -> - (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack') - in Inventory backpack'' wielded' - -instance Monoid Inventory where - mempty = Inventory mempty $ Hands Nothing Nothing - -class HasInventory s a | s -> a where - inventory :: Lens' s a - {-# MINIMAL inventory #-} - --- | Representation for where in the inventory an item might be -data InventoryPosition - = Backpack - | InHand Hand - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary InventoryPosition - --- | Return a human-readable description of the given 'InventoryPosition' -describeInventoryPosition :: InventoryPosition -> Text -describeInventoryPosition Backpack = "In backpack" -describeInventoryPosition (InHand hand) = "Wielded, in " <> describeHand hand - --- | Given a position in the inventory, return a traversal on the inventory over --- all the items in that position -inventoryPosition :: InventoryPosition -> Traversal' Inventory Item -inventoryPosition Backpack = backpack . traversed -inventoryPosition (InHand LeftHand) = wielded . leftHand . _Just . wieldedItem -inventoryPosition (InHand RightHand) = wielded . leftHand . _Just . wieldedItem -inventoryPosition (InHand BothHands) = wielded . doubleHanded . wieldedItem - --- | A fold over all the items in the inventory accompanied by their position in --- the inventory --- --- Invariant: This will return items in the same order as 'items' -itemsWithPosition :: Fold Inventory (InventoryPosition, Item) -itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems - where - backpackItems = toListOf $ backpack . folded . to (Backpack ,) - handItems inv = case inv ^. wielded of - DoubleHanded i -> pure (InHand BothHands, i ^. wieldedItem) - Hands l r -> (l ^.. folded . wieldedItem . to (InHand LeftHand ,)) - <> (r ^.. folded . wieldedItem . to (InHand RightHand ,)) - --- | Remove the first item equal to 'Item' from the given position in the --- inventory -removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory -removeItemFromPosition Backpack item inv - = inv & backpack %~ removeFirst (== item) -removeItemFromPosition (InHand LeftHand) item inv - = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem) -removeItemFromPosition (InHand RightHand) item inv - = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem) -removeItemFromPosition (InHand BothHands) item inv - | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv - = inv & wielded .~ nothingWielded - | otherwise - = inv diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs deleted file mode 100644 index 3ea610795e98..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs deleted file mode 100644 index d13ea8055c2b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs deleted file mode 100644 index aa6c5fa4fc47..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Draw/Util.hs +++ /dev/null @@ -1,31 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Entities.hs b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs deleted file mode 100644 index a0c037a1b4ed..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot deleted file mode 100644 index 519a862c6a5a..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Entities.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Environment.hs b/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs deleted file mode 100644 index b45a91eabed2..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Environment.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Item.hs b/users/grfn/xanthous/src/Xanthous/Entities/Item.hs deleted file mode 100644 index eadd62569663..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Item.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Marker.hs b/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs deleted file mode 100644 index 14d02872ed4e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Marker.hs +++ /dev/null @@ -1,41 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs deleted file mode 100644 index a7021d76cf65..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/RawTypes.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Raws.hs b/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs deleted file mode 100644 index 10f0d831934e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml deleted file mode 100644 index 12c76fc14b2e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml +++ /dev/null @@ -1,24 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml deleted file mode 100644 index ad3d9cb147da..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml +++ /dev/null @@ -1,20 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml deleted file mode 100644 index cdfcde616d21..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/husk.yaml +++ /dev/null @@ -1,26 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml deleted file mode 100644 index c0501a18a8e0..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ /dev/null @@ -1,14 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml deleted file mode 100644 index fe427c94abf7..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/ooze.yaml +++ /dev/null @@ -1,15 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml deleted file mode 100644 index 3f4e133fe286..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/rock.yaml +++ /dev/null @@ -1,10 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml deleted file mode 100644 index 7f9e1faffedb..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ /dev/null @@ -1,22 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Game.hs b/users/grfn/xanthous/src/Xanthous/Game.hs deleted file mode 100644 index 89c23f0de850..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game.hs +++ /dev/null @@ -1,73 +0,0 @@ -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/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs deleted file mode 100644 index 679bfe54597f..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs deleted file mode 100644 index 291dfd8b5e46..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ /dev/null @@ -1,224 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Game/Env.hs b/users/grfn/xanthous/src/Xanthous/Game/Env.hs deleted file mode 100644 index 5d7b275c8a0b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Env.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs deleted file mode 100644 index c692a3b47944..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Game/Memo.hs b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs deleted file mode 100644 index 154063b5dde2..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 2d6c0a280f41..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs deleted file mode 100644 index 13b1ba158818..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Game/State.hs +++ /dev/null @@ -1,572 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Generators/Level.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level.hs deleted file mode 100644 index fc57402e7d8e..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs deleted file mode 100644 index 03d534ca39b3..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/CaveAutomata.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs deleted file mode 100644 index 0be7c0435c5a..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Dungeon.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs deleted file mode 100644 index 4f8a2f42ee16..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/LevelContents.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs deleted file mode 100644 index 0008eb965c42..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs deleted file mode 100644 index ab7de95e6806..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Village.hs +++ /dev/null @@ -1,126 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Generators/Speech.hs b/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs deleted file mode 100644 index 8abc00b6a2fc..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Generators/Speech.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Messages.hs b/users/grfn/xanthous/src/Xanthous/Messages.hs deleted file mode 100644 index c273d650821b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Messages.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Messages/Template.hs b/users/grfn/xanthous/src/Xanthous/Messages/Template.hs deleted file mode 100644 index 5176880355f4..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Messages/Template.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Monad.hs b/users/grfn/xanthous/src/Xanthous/Monad.hs deleted file mode 100644 index db602de56f3a..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Monad.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs deleted file mode 100644 index 66004163f6ea..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Orphans.hs +++ /dev/null @@ -1,495 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Physics.hs b/users/grfn/xanthous/src/Xanthous/Physics.hs deleted file mode 100644 index 37530cbbc21b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Physics.hs +++ /dev/null @@ -1,71 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Prelude.hs b/users/grfn/xanthous/src/Xanthous/Prelude.hs deleted file mode 100644 index 2cb4299303ba..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Prelude.hs +++ /dev/null @@ -1,48 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Random.hs b/users/grfn/xanthous/src/Xanthous/Random.hs deleted file mode 100644 index 329b321b8bda..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Random.hs +++ /dev/null @@ -1,186 +0,0 @@ --------------------------------------------------------------------------------- -{-# 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/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs deleted file mode 100644 index f918340f055b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Util/Comonad.hs b/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs deleted file mode 100644 index 9e158cc8e2d4..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs +++ /dev/null @@ -1,24 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Util/Graph.hs b/users/grfn/xanthous/src/Xanthous/Util/Graph.hs deleted file mode 100644 index 8e5c04f4bfa9..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/Graph.hs +++ /dev/null @@ -1,33 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Util/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs deleted file mode 100644 index 0cb009f45ad0..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/Util/Inflection.hs b/users/grfn/xanthous/src/Xanthous/Util/Inflection.hs deleted file mode 100644 index 724f2339dd21..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/Inflection.hs +++ /dev/null @@ -1,14 +0,0 @@ - -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/grfn/xanthous/src/Xanthous/Util/JSON.hs b/users/grfn/xanthous/src/Xanthous/Util/JSON.hs deleted file mode 100644 index 91d1328e4a10..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/JSON.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Util/Optparse.hs b/users/grfn/xanthous/src/Xanthous/Util/Optparse.hs deleted file mode 100644 index dfa65372351d..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/Optparse.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- -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/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs deleted file mode 100644 index aa881b322779..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# 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/grfn/xanthous/src/Xanthous/keybindings.yaml b/users/grfn/xanthous/src/Xanthous/keybindings.yaml deleted file mode 100644 index cffb27cb03f6..000000000000 --- a/users/grfn/xanthous/src/Xanthous/keybindings.yaml +++ /dev/null @@ -1,22 +0,0 @@ -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/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml deleted file mode 100644 index bc08ec1ad24d..000000000000 --- a/users/grfn/xanthous/src/Xanthous/messages.yaml +++ /dev/null @@ -1,161 +0,0 @@ -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 ,. |