diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous')
58 files changed, 0 insertions, 7514 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs b/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs deleted file mode 100644 index a6cc789d6894..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/AI/Gormlak.hs +++ /dev/null @@ -1,124 +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 - , 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) -import Xanthous.Game.State -import Xanthous.Game.Lenses - ( entitiesCollision, collisionAt - , character, characterPosition - ) -import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) -import Xanthous.Random -import Xanthous.Monad (say) --------------------------------------------------------------------------------- - --- 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 - , 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 - dest <- maybe (selectDestination pos creature) pure - $ creature ^. field @"_hippocampus" . destination - let progress' = - dest ^. destinationProgress - + creature ^. field @"_creatureType" . Raw.speed . invertedRate |*| ticks - if progress' < 1 - then pure - $ pe - & positioned . field @"_hippocampus" . destination - ?~ (dest & destinationProgress .~ progress') - else do - let newPos = dest ^. destinationPosition - remainingSpeed = progress' - 1 - newDest <- selectDestination newPos creature - <&> destinationProgress +~ remainingSpeed - let pe' = pe & positioned . field @"_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 - selectDestination pos' creature' = destinationFromPos <$> do - canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision - 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 - - vision = visionRadius creature - attackCharacter = do - say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] - character %= Character.damage 1 - -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 - --------------------------------------------------------------------------------- - --- 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/glittershark/xanthous/src/Xanthous/App.hs b/users/glittershark/xanthous/src/Xanthous/App.hs deleted file mode 100644 index 9091961b725c..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/App.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -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 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 - , (|*|) - ) -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 -import qualified Xanthous.Messages as Messages -import Xanthous.Random -import Xanthous.Util (removeVectorIndex) -import Xanthous.Util.Inflection (toSentence) --------------------------------------------------------------------------------- -import qualified Xanthous.Entities.Character as Character -import Xanthous.Entities.Character hiding (pickUpItem) -import Xanthous.Entities.Item (Item) -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 -import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Dungeon as Dungeon --------------------------------------------------------------------------------- - -type App = Brick.App GameState AppEvent ResourceName - -data RunType = NewGame | LoadGame - 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 -> pure - , 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 (Move dir) = do - newPos <- uses characterPosition $ move dir - collisionAt newPos >>= \case - Nothing -> do - characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| 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 - selectItemFromInventory_ ["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) -> - gets (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 Wield = do - selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem - (say_ ["wield", "nothing"]) - $ \(MenuResult item) -> do - prevItems <- character . inventory . wielded <<.= inRightHand item - character . inventory . backpack - <>= fromList (prevItems ^.. wieldedItems . wieldedItem) - say ["wield", "wielded"] item - continue - -handleCommand Save = do - -- TODO default save locations / config file? - prompt_ @'StringPrompt ["save", "location"] Cancellable - $ \(StringResult filename) -> do - exists <- liftIO . doesFileExist $ unpack filename - if exists - then confirm ["save", "overwrite"] (object ["filename" A..= filename]) - $ doSave filename - else doSave filename - continue - where - 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' -> levels .= levs' - 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 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 (creatureID, creature) = do - charDamage <- uses character characterDamage - let creature' = Creature.damage charDamage creature - msgParams = object ["creature" A..= creature'] - if Creature.isDead creature' - then do - say ["combat", "killed"] msgParams - entities . at creatureID .= Nothing - else do - msg <- uses character getAttackMessage - message msg msgParams - entities . ix creatureID . positioned .= SomeEntity creature' - - whenM (uses character $ isNothing . weapon) - $ whenM (chance (0.08 :: Float)) $ do - say_ ["combat", "fistSelfDamage"] - character %= Character.damage 1 - - stepGame -- TODO - weapon chr = chr ^? inventory . wielded . wieldedItems . wieldableItem - getAttackMessage chr = - case weapon chr of - Just wi -> - fromMaybe (Messages.lookup ["combat", "hit", "generic"]) - $ wi ^. attackMessage - Nothing -> - Messages.lookup ["combat", "hit", "fists"] - -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, remove it from 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 item) -> AppM ()) - -> AppM () -selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = - uses (character . inventory . backpack) - (V.mapMaybe $ preview extraInfo) - >>= \case - Empty -> onEmpty - items' -> - menu msgPath msgParams cancellable (itemMenu items') - $ \(MenuResult (idx, item)) -> do - character . inventory . backpack %= removeVectorIndex idx - cb $ MenuResult item - where - itemMenu = mkMenuItems . imap itemMenuItem - itemMenuItem idx extraInfoItem = - let item = extraInfo # extraInfoItem - in ( entityMenuChar item - , MenuOption (description item) (idx, extraInfoItem)) - -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 item) -> AppM ()) - -> AppM () -selectItemFromInventory_ msgPath = selectItemFromInventory 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 - :: Int -- ^ level number - -> AppM Level -genLevel _num = do - let dims = Dimensions 80 80 - generator <- choose $ CaveAutomata :| [Dungeon] - level <- case generator of - CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims - Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims - pure $!! level - -levelToGameLevel :: Level -> GameLevel -levelToGameLevel level = - let _levelEntities = levelToEntityMap level - _upStaircasePosition = level ^. levelCharacterPosition - _levelRevealedPositions = mempty - in GameLevel {..} diff --git a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs b/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs deleted file mode 100644 index f393a0e2ea9a..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Autocommands.hs +++ /dev/null @@ -1,64 +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) -import Xanthous.Entities.Creature (Creature, creatureType) -import Xanthous.Entities.RawTypes (hostile) -import Xanthous.Game.State --------------------------------------------------------------------------------- - -autoStep :: Autocommand -> AppM () -autoStep (AutoMove dir) = do - newPos <- uses characterPosition $ move dir - collisionAt newPos >>= \case - Nothing -> do - characterPosition .= newPos - stepGameBy =<< uses (character . speed) (|*| 1) - describeEntitiesAt newPos - maybeVisibleEnemies <- nonEmpty <$> enemiesInSight - for_ maybeVisibleEnemies $ \visibleEnemies -> do - say ["autoMove", "enemyInSight"] - $ object [ "firstEntity" A..= NE.head visibleEnemies ] - cancelAutocommand - Just _ -> 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/glittershark/xanthous/src/Xanthous/App/Common.hs b/users/glittershark/xanthous/src/Xanthous/App/Common.hs deleted file mode 100644 index 69ba6f0e0596..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/App/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs deleted file mode 100644 index 9b5a3bf24fa7..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Prompt.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------------------- -module Xanthous.App.Prompt - ( handlePromptEvent - , clearPrompt - , prompt - , prompt_ - , confirm_ - , confirm - , menu - , menu_ - ) 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 GHC.TypeLits (ErrorMessage(..)) --------------------------------------------------------------------------------- -import Xanthous.App.Common -import Xanthous.Data (move) -import Xanthous.Command (directionFromChar) -import Xanthous.Data.App (ResourceName, AppEvent) -import Xanthous.Game.Prompt -import Xanthous.Game.State -import qualified Xanthous.Messages as Messages --------------------------------------------------------------------------------- - -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 - _ - (Prompt Cancellable _ _ _ _) - (VtyEvent (EvKey (KChar 'q') [])) - = clearPrompt >> continue -handlePromptEvent _ _ _ = continue - -clearPrompt :: AppM () -clearPrompt = promptState .= NoPrompt - -class NotMenu (pt :: PromptType) -instance NotMenu 'StringPrompt -instance NotMenu 'Confirm -instance NotMenu 'DirectionPrompt -instance NotMenu 'PointOnMap -instance NotMenu 'Continue -instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts" - ':$$: 'Text "Use `menu` or `menu_` instead") - => NotMenu ('Menu a) - -prompt - :: forall (pt :: PromptType) (params :: Type). - (ToJSON params, SingPromptType pt, NotMenu 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 - p <- case pt of - SPointOnMap -> do - charPos <- use characterPosition - pure $ mkPointOnMapPrompt cancellable charPos cb - SStringPrompt -> pure $ mkPrompt cancellable pt cb - SConfirm -> pure $ mkPrompt cancellable pt cb - SDirectionPrompt -> pure $ mkPrompt cancellable pt cb - SContinue -> pure $ mkPrompt cancellable pt cb - SMenu -> error "unreachable" - promptState .= WaitingPrompt msg p - -prompt_ - :: forall (pt :: PromptType). - (SingPromptType pt, NotMenu pt) - => [Text] -- ^ Message key - -> PromptCancellable - -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler - -> AppM () -prompt_ msg = prompt 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 [] diff --git a/users/glittershark/xanthous/src/Xanthous/App/Time.hs b/users/glittershark/xanthous/src/Xanthous/App/Time.hs deleted file mode 100644 index b17348f3853e..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/App/Time.hs +++ /dev/null @@ -1,40 +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) --------------------------------------------------------------------------------- - - -stepGameBy :: Ticks -> AppM () -stepGameBy ticks = do - ents <- uses entities EntityMap.toEIDsAndPositioned - for_ ents $ \(eid, pEntity) -> do - pEntity' <- step ticks pEntity - entities . ix eid .= pEntity' - - 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/glittershark/xanthous/src/Xanthous/Command.hs b/users/glittershark/xanthous/src/Xanthous/Command.hs deleted file mode 100644 index 37025dd37ad2..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Command.hs +++ /dev/null @@ -1,73 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Command where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Left, Right, Down) --------------------------------------------------------------------------------- -import Graphics.Vty.Input (Key(..), Modifier(..)) -import qualified Data.Char as Char --------------------------------------------------------------------------------- -import Xanthous.Data (Direction(..)) --------------------------------------------------------------------------------- - -data Command - = Quit - | Move Direction - | StartAutoMove Direction - | PreviousMessage - | PickUp - | Drop - | Open - | Close - | Wait - | Eat - | Look - | Save - | Read - | ShowInventory - | Wield - | GoUp - | GoDown - - -- | TODO replace with `:` commands - | ToggleRevealAll - -commandFromKey :: Key -> [Modifier] -> Maybe Command -commandFromKey (KChar 'q') [] = Just Quit -commandFromKey (KChar '.') [] = Just Wait -commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir -commandFromKey (KChar c) [] - | Char.isUpper c - , Just dir <- directionFromChar $ Char.toLower c - = Just $ StartAutoMove dir -commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage -commandFromKey (KChar ',') [] = Just PickUp -commandFromKey (KChar 'd') [] = Just Drop -commandFromKey (KChar 'o') [] = Just Open -commandFromKey (KChar 'c') [] = Just Close -commandFromKey (KChar ';') [] = Just Look -commandFromKey (KChar 'e') [] = Just Eat -commandFromKey (KChar 'S') [] = Just Save -commandFromKey (KChar 'r') [] = Just Read -commandFromKey (KChar 'i') [] = Just ShowInventory -commandFromKey (KChar 'w') [] = Just Wield -commandFromKey (KChar '<') [] = Just GoUp -commandFromKey (KChar '>') [] = Just GoDown - --- DEBUG COMMANDS -- -commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll - -commandFromKey _ _ = Nothing - --------------------------------------------------------------------------------- - -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/glittershark/xanthous/src/Xanthous/Data.hs b/users/glittershark/xanthous/src/Xanthous/Data.hs deleted file mode 100644 index c9c11b553b67..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data.hs +++ /dev/null @@ -1,590 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE NoTypeSynonymInstances #-} -{-# LANGUAGE DuplicateRecordFields #-} --------------------------------------------------------------------------------- --- | 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 - - -- * Boxes - , Box(..) - , topLeftCorner - , bottomRightCorner - , setBottomRightCorner - , dimensions - , inBox - , boxIntersects - , boxCenter - , boxEdge - , module Linear.V2 - - -- * - , Per(..) - , invertRate - , invertedRate - , (|*|) - , Ticks(..) - , Tiles(..) - , TicksPerTile - , TilesPerTick - , timesTiles - - -- * - , 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 Xanthous.Util (EqEqProp(..), EqProp, between) -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Xanthous.Orphans () -import Xanthous.Util.Graphics --------------------------------------------------------------------------------- - --- | 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 - --------------------------------------------------------------------------------- - -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 Arbitrary via GenericArbitrary 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 Arbitrary via GenericArbitrary (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 (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) via Double - deriving (Semigroup, Monoid) via Product Double -instance Arbitrary (Per a b) where arbitrary = genericArbitrary - -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 - -infixl 7 |*| -(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a -(|*|) (Rate rate) b = fromScalar $ rate * scalar b - -newtype Ticks = Ticks Word - deriving stock (Show, 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 -instance Arbitrary Ticks where arbitrary = genericArbitrary - -newtype Tiles = Tiles Double - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double - deriving (Semigroup, Monoid) via (Sum Double) -instance Arbitrary Tiles where arbitrary = genericArbitrary - -type TicksPerTile = Ticks `Per` Tiles -type TilesPerTick = Tiles `Per` Ticks - -timesTiles :: TicksPerTile -> Tiles -> Ticks -timesTiles = (|*|) - --------------------------------------------------------------------------------- - -newtype Hitpoints = Hitpoints Word - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) - via Word - deriving (Semigroup, Monoid) via Sum Word - --------------------------------------------------------------------------------- - -data Box a = Box - { _topLeftCorner :: V2 a - , _dimensions :: V2 a - } - deriving stock (Show, Eq, Ord, Functor, Generic) - deriving Arbitrary via GenericArbitrary (Box a) -makeFieldsNoPrefix ''Box - -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/glittershark/xanthous/src/Xanthous/Data/App.hs b/users/glittershark/xanthous/src/Xanthous/Data/App.hs deleted file mode 100644 index 0361d2a59ed5..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/App.hs +++ /dev/null @@ -1,39 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.App - ( Panel(..) - , ResourceName(..) - , AppEvent(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - --- | Enum for "panels" displayed in the game's UI. -data Panel - = InventoryPanel -- ^ A panel displaying the character's inventory - deriving stock (Show, Eq, Ord, Generic, Enum, Bounded) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary Panel - - -data ResourceName - = MapViewport -- ^ The main viewport where we display the game content - | Character -- ^ The character - | MessageBox -- ^ The box where we display messages to the user - | Prompt -- ^ The game's prompt - | Panel Panel -- ^ A panel in the game - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary ResourceName - -data AppEvent - = AutoContinue -- ^ Continue whatever autocommand has been requested by the - -- user - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) - deriving Arbitrary via GenericArbitrary AppEvent diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs deleted file mode 100644 index 39953410f2f3..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/Entities.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RecordWildCards #-} --------------------------------------------------------------------------------- -module Xanthous.Data.Entities - ( -- * Collisions - Collision(..) - , _Stop - , _Combat - -- * Entity Attributes - , EntityAttributes(..) - , blocksVision - , blocksObject - , collision - , defaultEntityAttributes - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Data.Aeson (ToJSON(..), FromJSON(..), (.:?), (.!=), withObject) -import Data.Aeson.Generic.DerivingVia -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) -import Test.QuickCheck --------------------------------------------------------------------------------- - -data Collision - = Stop -- ^ Can't move through this - | Combat -- ^ Moving into this equates to hitting it with a stick - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary Collision - deriving (ToJSON, FromJSON) - via WithOptions '[ AllNullaryToStringTag 'True ] - Collision -makePrisms ''Collision - --- | Attributes of an entity -data EntityAttributes = EntityAttributes - { _blocksVision :: Bool - -- | Does this entity block a large object from being put in the same tile as - -- it - eg a a door being closed on it - , _blocksObject :: Bool - -- | What type of collision happens when moving into this entity? - , _collision :: Collision - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EntityAttributes - deriving (ToJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - EntityAttributes -makeLenses ''EntityAttributes - -instance FromJSON EntityAttributes where - parseJSON = withObject "EntityAttributes" $ \o -> do - _blocksVision <- o .:? "blocksVision" - .!= _blocksVision defaultEntityAttributes - _blocksObject <- o .:? "blocksObject" - .!= _blocksObject defaultEntityAttributes - _collision <- o .:? "collision" - .!= _collision defaultEntityAttributes - pure EntityAttributes {..} - -defaultEntityAttributes :: EntityAttributes -defaultEntityAttributes = EntityAttributes - { _blocksVision = False - , _blocksObject = False - , _collision = Stop - } diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs deleted file mode 100644 index 855a3462daee..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityChar.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.EntityChar - ( EntityChar(..) - , HasChar(..) - , HasStyle(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((.=)) --------------------------------------------------------------------------------- -import qualified Graphics.Vty.Attributes as Vty -import Test.QuickCheck -import Data.Aeson --------------------------------------------------------------------------------- -import Xanthous.Orphans () -import Xanthous.Util.QuickCheck (GenericArbitrary(..)) --------------------------------------------------------------------------------- - - -class HasChar s a | s -> a where - char :: Lens' s a - {-# MINIMAL char #-} - -data EntityChar = EntityChar - { _char :: Char - , _style :: Vty.Attr - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary EntityChar -makeFieldsNoPrefix ''EntityChar - -instance FromJSON EntityChar where - parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr - parseJSON (Object o) = do - (EntityChar _char _) <- o .: "char" - _style <- o .:? "style" .!= Vty.defAttr - pure EntityChar {..} - parseJSON _ = fail "Invalid type, expected string or object" - -instance ToJSON EntityChar where - toJSON (EntityChar chr styl) - | styl == Vty.defAttr = String $ chr <| Empty - | otherwise = object - [ "char" .= chr - , "style" .= styl - ] - -instance IsString EntityChar where - fromString [ch] = EntityChar ch Vty.defAttr - fromString _ = error "Entity char must only be a single character" diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs deleted file mode 100644 index d24defa841ab..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveFunctor #-} --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap - ( EntityMap - , _EntityMap - , EntityID - , emptyEntityMap - , insertAt - , insertAtReturningID - , fromEIDsAndPositioned - , toEIDsAndPositioned - , atPosition - , atPositionWithIDs - , positions - , lookup - , lookupWithPosition - -- , positionedEntities - , neighbors - , Deduplicate(..) - - -- * debug - , byID - , byPosition - , lastID - - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup) -import Xanthous.Data - ( Position - , Positioned(..) - , positioned - , Neighbors(..) - , neighborPositions - ) -import Xanthous.Data.VectorBag -import Xanthous.Orphans () -import Xanthous.Util (EqEqProp(..)) --------------------------------------------------------------------------------- -import Data.Monoid (Endo(..)) -import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function) -import Test.QuickCheck.Checkers (EqProp) -import Test.QuickCheck.Instances.UnorderedContainers () -import Test.QuickCheck.Instances.Vector () -import Text.Show (showString, showParen) -import Data.Aeson --------------------------------------------------------------------------------- - -type EntityID = Word32 -type NonNullSet a = NonNull (Set a) - -data EntityMap a where - EntityMap :: - { _byPosition :: Map Position (NonNullSet EntityID) - , _byID :: HashMap EntityID (Positioned a) - , _lastID :: EntityID - } -> EntityMap a - deriving stock (Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData, CoArbitrary, Function) -deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a) -makeLenses ''EntityMap - -instance ToJSON a => ToJSON (EntityMap a) where - toJSON = toJSON . toEIDsAndPositioned - - -instance FromJSON a => FromJSON (EntityMap a) where - parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON - -byIDInvariantError :: forall a. a -byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition " - <> "must point to entityIDs in byID" - -instance (Ord a, Eq a) => Eq (EntityMap a) where - -- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap - (==) = (==) `on` view (_EntityMap . to sort) - -deriving stock instance (Ord a) => Ord (EntityMap a) - -instance Show a => Show (EntityMap a) where - showsPrec pr em - = showParen (pr > 10) - $ showString - . ("fromEIDsAndPositioned " <>) - . show - . toEIDsAndPositioned - $ em - -instance Arbitrary a => Arbitrary (EntityMap a) where - arbitrary = review _EntityMap <$> arbitrary - shrink em = review _EntityMap <$> shrink (em ^. _EntityMap) - -type instance Index (EntityMap a) = EntityID -type instance IxValue (EntityMap a) = (Positioned a) -instance Ixed (EntityMap a) where ix eid = at eid . traverse - -instance At (EntityMap a) where - at eid = lens (view $ byID . at eid) setter - where - setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a - setter m Nothing = fromMaybe m $ do - Positioned pos _ <- m ^. byID . at eid - pure $ m - & removeEIDAtPos pos - & byID . at eid .~ Nothing - setter m (Just pe@(Positioned pos _)) = m - & (case lookupWithPosition eid m of - Nothing -> id - Just (Positioned origPos _) -> removeEIDAtPos origPos - ) - & byID . at eid ?~ pe - & byPosition . at pos %~ \case - Nothing -> Just $ opoint eid - Just es -> Just $ ninsertSet eid es - removeEIDAtPos pos = - byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid) - -instance Semigroup (EntityMap a) where - em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁ - -instance Monoid (EntityMap a) where - mempty = emptyEntityMap - -instance FunctorWithIndex EntityID EntityMap - -instance FoldableWithIndex EntityID EntityMap - -instance TraversableWithIndex EntityID EntityMap where - itraversed = byID . itraversed . rmap sequenceA . distrib - itraverse = itraverseOf itraversed - -type instance Element (EntityMap a) = a -instance MonoFoldable (EntityMap a) - -emptyEntityMap :: EntityMap a -emptyEntityMap = EntityMap mempty mempty 0 - -newtype Deduplicate a = Deduplicate (EntityMap a) - deriving stock (Show, Traversable, Generic) - deriving newtype (Eq, Functor, Foldable, EqProp, Arbitrary) - -instance Semigroup (Deduplicate a) where - (Deduplicate em₁) <> (Deduplicate em₂) = - let _byID = em₁ ^. byID <> em₂ ^. byID - _byPosition = mempty &~ do - ifor_ _byID $ \eid (Positioned pos _) -> - at pos %= \case - Just eids -> Just $ ninsertSet eid eids - Nothing -> Just $ opoint eid - _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID - in Deduplicate EntityMap{..} - - --------------------------------------------------------------------------------- - -_EntityMap :: Iso' (EntityMap a) [(Position, a)] -_EntityMap = iso hither yon - where - hither :: EntityMap a -> [(Position, a)] - hither em = do - (pos, eids) <- em ^. byPosition . _Wrapped - eid <- toList eids - ent <- em ^.. byID . at eid . folded . positioned - pure (pos, ent) - yon :: [(Position, a)] -> EntityMap a - yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap - - -insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a) -insertAtReturningID pos e em = - let (eid, em') = em & lastID <+~ 1 - in em' - & byID . at eid ?~ Positioned pos e - & byPosition . at pos %~ \case - Nothing -> Just $ opoint eid - Just es -> Just $ ninsertSet eid es - & (eid, ) - -insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a -insertAt pos e = snd . insertAtReturningID pos e - -atPosition :: forall a. (Ord a, Show a) => Position -> Lens' (EntityMap a) (VectorBag a) -atPosition pos = lens getter setter - where - getter em = - let eids :: VectorBag EntityID - eids = maybe mempty (VectorBag . toVector . toNullable) - $ em ^. byPosition . at pos - in getEIDAssume em <$> eids - setter em Empty = em & byPosition . at pos .~ Nothing - setter em (sort -> entities) = - let origEIDs = maybe Empty toNullable $ em ^. byPosition . at pos - origEntitiesWithIDs = - sortOn snd $ toList origEIDs <&> \eid -> (eid, getEIDAssume em eid) - go alles₁@((eid, e₁) :< es₁) -- orig - (e₂ :< es₂) -- new - | e₁ == e₂ - -- same, do nothing - = let (eids, lastEID, byID') = go es₁ es₂ - in (insertSet eid eids, lastEID, byID') - | otherwise - -- e₂ is new, generate a new ID for it - = let (eids, lastEID, byID') = go alles₁ es₂ - eid' = succ lastEID - in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos e₂) - go Empty Empty = (mempty, em ^. lastID, em ^. byID) - go orig Empty = - let byID' = foldr deleteMap (em ^. byID) $ map fst orig - in (mempty, em ^. lastID, byID') - go Empty (new :< news) = - let (eids, lastEID, byID') = go Empty news - eid' = succ lastEID - in (insertSet eid' eids, eid', byID' & at eid' ?~ Positioned pos new) - go _ _ = error "unreachable" - (eidsAtPosition, newLastID, newByID) = go origEntitiesWithIDs entities - in em & byPosition . at pos .~ fromNullable eidsAtPosition - & byID .~ newByID - & lastID .~ newLastID - -getEIDAssume :: EntityMap a -> EntityID -> a -getEIDAssume em eid = fromMaybe byIDInvariantError - $ em ^? byID . ix eid . positioned - -atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a) -atPositionWithIDs pos em = - let eids = maybe mempty (toVector . toNullable) - $ em ^. byPosition . at pos - in (id &&& Positioned pos . getEIDAssume em) <$> eids - -fromEIDsAndPositioned - :: forall mono a. (MonoFoldable mono, Element mono ~ (EntityID, Positioned a)) - => mono - -> EntityMap a -fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty - where - insert' (eid, pe@(Positioned pos _)) - = (byID . at eid ?~ pe) - . (byPosition . at pos %~ \case - Just eids -> Just $ ninsertSet eid eids - Nothing -> Just $ opoint eid - ) - newLastID em = em & lastID - .~ fromMaybe 1 - (maximumOf (ifolded . asIndex) (em ^. byID)) - -toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)] -toEIDsAndPositioned = itoListOf $ byID . ifolded - -positions :: EntityMap a -> [Position] -positions = toListOf $ byPosition . to keys . folded - -lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a) -lookupWithPosition eid = view $ byID . at eid - -lookup :: EntityID -> EntityMap a -> Maybe a -lookup eid = fmap (view positioned) . lookupWithPosition eid - --- unlawful :( --- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b) --- positionedEntities = byID . itraversed - -neighbors :: (Ord a, Show a) => Position -> EntityMap a -> Neighbors (VectorBag a) -neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos - --------------------------------------------------------------------------------- -makeWrapped ''Deduplicate diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs deleted file mode 100644 index 19e7b0cdf086..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ /dev/null @@ -1,64 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Data.EntityMap.Graphics - ( visiblePositions - , visibleEntities - , linesOfSight - , canSee - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lines) --------------------------------------------------------------------------------- -import Xanthous.Util (takeWhileInclusive) -import Xanthous.Data -import Xanthous.Data.Entities -import Xanthous.Data.EntityMap -import Xanthous.Game.State -import Xanthous.Util.Graphics (circle, line) --------------------------------------------------------------------------------- - --- | Returns a set of positions that are visible, when taking into account --- 'blocksVision', from the given position, within the given radius. -visiblePositions - :: Entity e - => Position - -> Word -- ^ Vision radius - -> EntityMap e - -> Set Position -visiblePositions pos radius - = setFromList . positions . visibleEntities pos radius - --- | Returns a list of individual lines of sight, each of which is a list of --- entities at positions on that line of sight -linesOfSight - :: forall e. Entity e - => Position - -> Word - -> EntityMap e - -> [[(Position, Vector (EntityID, e))]] -linesOfSight (view _Position -> pos) visionRadius em - = entitiesOnLines - <&> takeWhileInclusive - (none (view blocksVision . entityAttributes . snd) . snd) - where - radius = circle pos $ fromIntegral visionRadius - lines = line pos <$> radius - entitiesOnLines :: [[(Position, Vector (EntityID, e))]] - entitiesOnLines = lines <&> map getPositionedAt - getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e)) - getPositionedAt p = - let ppos = _Position # p - in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em) - --- | Given a point and a radius of vision, returns a list of all entities that --- are *visible* (eg, not blocked by an entity that obscures vision) from that --- point -visibleEntities :: Entity e => Position -> Word -> EntityMap e -> EntityMap e -visibleEntities pos visionRadius - = fromEIDsAndPositioned - . foldMap (\(p, es) -> over _2 (Positioned p) <$> es) - . fold - . linesOfSight pos visionRadius - -canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool -canSee match pos radius = any match . visibleEntities pos radius --- ^ this might be optimizable diff --git a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs b/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs deleted file mode 100644 index efc0f53acecf..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/Levels.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.Levels - ( Levels - , allLevels - , nextLevel - , prevLevel - , mkLevels1 - , mkLevels - , oneLevel - , current - , ComonadStore(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding ((<.>), Empty, foldMap) -import Xanthous.Util (between, EqProp, EqEqProp(..)) -import Xanthous.Util.Comonad (current) -import Xanthous.Orphans () --------------------------------------------------------------------------------- -import Control.Comonad.Store -import Control.Comonad.Store.Zipper -import Data.Aeson (ToJSON(..), FromJSON(..)) -import Data.Aeson.Generic.DerivingVia -import Data.Functor.Apply -import Data.Foldable (foldMap) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromJust) -import Data.Sequence (Seq((:<|), Empty)) -import Data.Semigroup.Foldable.Class -import Data.Text (replace) -import Test.QuickCheck --------------------------------------------------------------------------------- - --- | Collection of levels plus a pointer to the current level --- --- Navigation is via the 'Comonad' instance. We can get the current level with --- 'extract': --- --- extract @Levels :: Levels level -> level --- --- For access to and modification of the level, use --- 'Xanthous.Util.Comonad.current' -newtype Levels a = Levels { levelZipper :: Zipper Seq a } - deriving stock (Generic) - deriving (Functor, Comonad, Foldable) via (Zipper Seq) - deriving (ComonadStore Int) via (Zipper Seq) - -type instance Element (Levels a) = a -instance MonoFoldable (Levels a) -instance MonoFunctor (Levels a) -instance MonoTraversable (Levels a) - -instance Traversable Levels where - traverse f (Levels z) = Levels <$> traverse f z - -instance Foldable1 Levels - -instance Traversable1 Levels where - traverse1 f (Levels z) = seek (pos z) . partialMkLevels <$> go (unzipper z) - where - go Empty = error "empty seq, unreachable" - go (x :<| xs) = (<|) <$> f x <.> go xs - --- | Always takes the position of the latter element -instance Semigroup (Levels a) where - levs₁ <> levs₂ - = seek (pos levs₂) - . partialMkLevels - $ allLevels levs₁ <> allLevels levs₂ - --- | Make Levels from a Seq. Throws an error if the seq is not empty -partialMkLevels :: Seq a -> Levels a -partialMkLevels = Levels . fromJust . zipper - --- | Make Levels from a possibly-empty structure -mkLevels :: Foldable1 f => f level -> Maybe (Levels level) -mkLevels = fmap Levels . zipper . foldMap pure - --- | Make Levels from a non-empty structure -mkLevels1 :: Foldable1 f => f level -> Levels level -mkLevels1 = fromJust . mkLevels - -oneLevel :: a -> Levels a -oneLevel = mkLevels1 . Identity - --- | Get a sequence of all the levels -allLevels :: Levels a -> Seq a -allLevels = unzipper . levelZipper - --- | Step to the next level, generating a new level if necessary using the given --- applicative action -nextLevel - :: Applicative m - => m level -- ^ Generate a new level, if necessary - -> Levels level - -> m (Levels level) -nextLevel genLevel levs - | pos levs + 1 < size (levelZipper levs) - = pure $ seeks succ levs - | otherwise - = genLevel <&> \level -> - seek (pos levs + 1) . partialMkLevels $ allLevels levs |> level - --- | Go to the previous level. Returns Nothing if 'pos' is 0 -prevLevel :: Levels level -> Maybe (Levels level) -prevLevel levs | pos levs == 0 = Nothing - | otherwise = Just $ seeks pred levs - --------------------------------------------------------------------------------- - --- | alternate, slower representation of Levels we can Iso into to perform --- various operations -data AltLevels a = AltLevels - { _levels :: NonEmpty a - , _currentLevel :: Int -- ^ invariant: is within the bounds of _levels - } - deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - (AltLevels a) -makeLenses ''AltLevels - -alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b) -alt = iso hither yon - where - hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs) - yon (AltLevels levs curr) = seek curr $ mkLevels1 levs - -instance Eq a => Eq (Levels a) where - (==) = (==) `on` view alt - -deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a) - -instance Show a => Show (Levels a) where - show = unpack . replace "AltLevels" "Levels" . pack . show . view alt - -instance NFData a => NFData (Levels a) where - rnf = rnf . view alt - -instance ToJSON a => ToJSON (Levels a) where - toJSON = toJSON . view alt - -instance FromJSON a => FromJSON (Levels a) where - parseJSON = fmap (review alt) . parseJSON - -instance Arbitrary a => Arbitrary (AltLevels a) where - arbitrary = do - _levels <- arbitrary - _currentLevel <- choose (0, length _levels - 1) - pure AltLevels {..} - shrink als = do - _levels <- shrink $ als ^. levels - _currentLevel <- filter (between 0 $ length _levels - 1) - $ shrink $ als ^. currentLevel - pure AltLevels {..} - - -instance Arbitrary a => Arbitrary (Levels a) where - arbitrary = review alt <$> arbitrary - shrink = fmap (review alt) . shrink . view alt - -instance CoArbitrary a => CoArbitrary (Levels a) where - coarbitrary = coarbitrary . view alt - -instance Function a => Function (Levels a) where - function = functionMap (view alt) (review alt) diff --git a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs b/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs deleted file mode 100644 index 1b875d448302..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/NestedMap.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PolyKinds #-} --------------------------------------------------------------------------------- -module Xanthous.Data.NestedMap - ( NestedMapVal(..) - , NestedMap(..) - , lookup - , lookupVal - , insert - - -- * - , (:->) - , BifunctorFunctor'(..) - , BifunctorMonad'(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup, foldMap) -import qualified Xanthous.Prelude as P --------------------------------------------------------------------------------- -import Test.QuickCheck -import Data.Aeson -import Data.Function (fix) -import Data.Foldable (Foldable(..)) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE --------------------------------------------------------------------------------- - --- | Natural transformations on bifunctors -type (:->) p q = forall a b. p a b -> q a b -infixr 0 :-> - -class (forall b. Bifunctor b => Bifunctor (t b)) => BifunctorFunctor' t where - bifmap' :: (Bifunctor p, Bifunctor q) => (p :-> q) -> t p :-> t q - -class BifunctorFunctor' t => BifunctorMonad' t where - bireturn' :: (Bifunctor p) => p :-> t p - - bibind' :: (Bifunctor p, Bifunctor q) => (p :-> t q) -> t p :-> t q - bibind' f = bijoin' . bifmap' f - - bijoin' :: (Bifunctor p) => t (t p) :-> t p - bijoin' = bibind' id - - {-# MINIMAL bireturn', (bibind' | bijoin') #-} - --------------------------------------------------------------------------------- - -data NestedMapVal m k v = Val v | Nested (NestedMap m k v) - -deriving stock instance - ( forall k' v'. (Show k', Show v') => Show (m k' v') - , Show k - , Show v - ) => Show (NestedMapVal m k v) - -deriving stock instance - ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') - , Eq k - , Eq v - ) => Eq (NestedMapVal m k v) - -instance - forall m k v. - ( Arbitrary (m k v) - , Arbitrary (m k (NestedMapVal m k v)) - , Arbitrary k - , Arbitrary v - , IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) => Arbitrary (NestedMapVal m k v) where - arbitrary = sized . fix $ \gen n -> - let nst = fmap (NestedMap . mapFromList) - . listOf - $ (,) <$> arbitrary @k <*> gen (n `div` 2) - in if n == 0 - then Val <$> arbitrary - else oneof [ Val <$> arbitrary - , Nested <$> nst] - shrink (Val v) = Val <$> shrink v - shrink (Nested mkv) = Nested <$> shrink mkv - -instance Functor (m k) => Functor (NestedMapVal m k) where - fmap f (Val v) = Val $ f v - fmap f (Nested m) = Nested $ fmap f m - -instance Bifunctor m => Bifunctor (NestedMapVal m) where - bimap _ g (Val v) = Val $ g v - bimap f g (Nested m) = Nested $ bimap f g m - -instance BifunctorFunctor' NestedMapVal where - bifmap' _ (Val v) = Val v - bifmap' f (Nested m) = Nested $ bifmap' f m - -instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) - => ToJSON (NestedMapVal m k v) where - toJSON (Val v) = toJSON v - toJSON (Nested m) = toJSON m - -instance Foldable (m k) => Foldable (NestedMapVal m k) where - foldMap f (Val v) = f v - foldMap f (Nested m) = foldMap f m - --- _NestedMapVal --- :: forall m k v m' k' v'. --- ( IsMap (m k v), IsMap (m' k' v') --- , IsMap (m [k] v), IsMap (m' [k'] v') --- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' --- , ContainerKey (m [k] v) ~ [k], ContainerKey (m' [k'] v') ~ [k'] --- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' --- , MapValue (m [k] v) ~ v, MapValue (m' [k'] v') ~ v' --- ) --- => Iso (NestedMapVal m k v) --- (NestedMapVal m' k' v') --- (m [k] v) --- (m' [k'] v') --- _NestedMapVal = iso hither yon --- where --- hither :: NestedMapVal m k v -> m [k] v --- hither (Val v) = singletonMap [] v --- hither (Nested m) = bimap _ _ $ m ^. _NestedMap --- yon = _ - --------------------------------------------------------------------------------- - -newtype NestedMap m k v = NestedMap (m k (NestedMapVal m k v)) - -deriving stock instance - ( forall k' v'. (Eq k', Eq v') => Eq (m k' v') - , Eq k - , Eq v - ) => Eq (NestedMap m k v) - -deriving stock instance - ( forall k' v'. (Show k', Show v') => Show (m k' v') - , Show k - , Show v - ) => Show (NestedMap m k v) - -instance Arbitrary (m k (NestedMapVal m k v)) - => Arbitrary (NestedMap m k v) where - arbitrary = NestedMap <$> arbitrary - shrink (NestedMap m) = NestedMap <$> shrink m - -instance Functor (m k) => Functor (NestedMap m k) where - fmap f (NestedMap m) = NestedMap $ fmap (fmap f) m - -instance Bifunctor m => Bifunctor (NestedMap m) where - bimap f g (NestedMap m) = NestedMap $ bimap f (bimap f g) m - -instance BifunctorFunctor' NestedMap where - bifmap' f (NestedMap m) = NestedMap . f $ bimap id (bifmap' f) m - -instance (ToJSONKey k, ToJSON v, ToJSON (m k (NestedMapVal m k v))) - => ToJSON (NestedMap m k v) where - toJSON (NestedMap m) = toJSON m - -instance Foldable (m k) => Foldable (NestedMap m k) where - foldMap f (NestedMap m) = foldMap (foldMap f) m - --------------------------------------------------------------------------------- - -lookup - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> NestedMap m k v - -> Maybe (NestedMapVal m k v) -lookup (p :| []) (NestedMap vs) = P.lookup p vs -lookup (p :| (p₁ : ps)) (NestedMap vs) = P.lookup p vs >>= \case - (Val _) -> Nothing - (Nested vs') -> lookup (p₁ :| ps) vs' - -lookupVal - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> NestedMap m k v - -> Maybe v -lookupVal ks m - | Just (Val v) <- lookup ks m = Just v - | otherwise = Nothing - -insert - :: ( IsMap (m k (NestedMapVal m k v)) - , MapValue (m k (NestedMapVal m k v)) ~ (NestedMapVal m k v) - , ContainerKey (m k (NestedMapVal m k v)) ~ k - ) - => NonEmpty k - -> v - -> NestedMap m k v - -> NestedMap m k v -insert (k :| []) v (NestedMap m) = NestedMap $ P.insertMap k (Val v) m -insert (k₁ :| (k₂ : ks)) v (NestedMap m) = NestedMap $ alterMap upd k₁ m - where - upd (Just (Nested nm)) = Just . Nested $ insert (k₂ :| ks) v nm - upd _ = Just $ - let (kΩ :| ks') = NE.reverse (k₂ :| ks) - in P.foldl' - (\m' k -> Nested . NestedMap . singletonMap k $ m') - (Nested . NestedMap . singletonMap kΩ $ Val v) - ks' - --- _NestedMap --- :: ( IsMap (m k v), IsMap (m' k' v') --- , IsMap (m (NonEmpty k) v), IsMap (m' (NonEmpty k') v') --- , ContainerKey (m k v) ~ k, ContainerKey (m' k' v') ~ k' --- , ContainerKey (m (NonEmpty k) v) ~ (NonEmpty k) --- , ContainerKey (m' (NonEmpty k') v') ~ (NonEmpty k') --- , MapValue (m k v) ~ v, MapValue (m' k' v') ~ v' --- , MapValue (m (NonEmpty k) v) ~ v, MapValue (m' (NonEmpty k') v') ~ v' --- ) --- => Iso (NestedMap m k v) --- (NestedMap m' k' v') --- (m (NonEmpty k) v) --- (m' (NonEmpty k') v') --- _NestedMap = iso undefined yon --- where --- hither (NestedMap m) = undefined . mapToList $ m --- yon mkv = undefined diff --git a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs b/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs deleted file mode 100644 index 2e6d48062a45..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Data/VectorBag.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Data.VectorBag - (VectorBag(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Data.Aeson -import qualified Data.Vector as V -import Test.QuickCheck -import Test.QuickCheck.Instances.Vector () --------------------------------------------------------------------------------- - --- | Acts exactly like a Vector, except ignores order when testing for equality -newtype VectorBag a = VectorBag (Vector a) - deriving stock - ( Traversable - , Generic - ) - deriving newtype - ( Show - , Read - , Foldable - , FromJSON - , FromJSON1 - , ToJSON - , Reversing - , Applicative - , Functor - , Monad - , Monoid - , Semigroup - , Arbitrary - , CoArbitrary - , Filterable - ) -makeWrapped ''VectorBag - -instance Function a => Function (VectorBag a) where - function = functionMap (\(VectorBag v) -> v) VectorBag - -type instance Element (VectorBag a) = a -deriving via (Vector a) instance MonoFoldable (VectorBag a) -deriving via (Vector a) instance GrowingAppend (VectorBag a) -deriving via (Vector a) instance SemiSequence (VectorBag a) -deriving via (Vector a) instance MonoPointed (VectorBag a) -deriving via (Vector a) instance MonoFunctor (VectorBag a) - -instance Cons (VectorBag a) (VectorBag b) a b where - _Cons = prism (\(x, VectorBag xs) -> VectorBag $ x <| xs) $ \(VectorBag v) -> - if V.null v - then Left (VectorBag mempty) - else Right (V.unsafeHead v, VectorBag $ V.unsafeTail v) - -instance AsEmpty (VectorBag a) where - _Empty = prism' (const $ VectorBag Empty) $ \case - (VectorBag Empty) -> Just () - _ -> Nothing - -instance Witherable VectorBag where - wither f (VectorBag v) = VectorBag <$> wither f v - witherM f (VectorBag v) = VectorBag <$> witherM f v - filterA p (VectorBag v) = VectorBag <$> filterA p v - -{- - TODO: - , Ixed - , FoldableWithIndex - , FunctorWithIndex - , TraversableWithIndex - , Snoc - , Each --} - -instance Ord a => Eq (VectorBag a) where - (==) = (==) `on` (view _Wrapped . sort) - -instance Ord a => Ord (VectorBag a) where - compare = compare `on` (view _Wrapped . sort) - -instance MonoTraversable (VectorBag a) where - otraverse f (VectorBag v) = VectorBag <$> otraverse f v - -instance IsSequence (VectorBag a) where - fromList = VectorBag . fromList - break prd (VectorBag v) = bimap VectorBag VectorBag $ break prd v - span prd (VectorBag v) = bimap VectorBag VectorBag $ span prd v - dropWhile prd (VectorBag v) = VectorBag $ dropWhile prd v - takeWhile prd (VectorBag v) = VectorBag $ takeWhile prd v - splitAt idx (VectorBag v) = bimap VectorBag VectorBag $ splitAt idx v - unsafeSplitAt idx (VectorBag v) = - bimap VectorBag VectorBag $ unsafeSplitAt idx v - take n (VectorBag v) = VectorBag $ take n v - unsafeTake n (VectorBag v) = VectorBag $ unsafeTake n v - drop n (VectorBag v) = VectorBag $ drop n v - unsafeDrop n (VectorBag v) = VectorBag $ unsafeDrop n v - partition p (VectorBag v) = bimap VectorBag VectorBag $ partition p v diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs deleted file mode 100644 index c18d726a4bfd..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Character.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Xanthous.Entities.Character - ( Character(..) - , characterName - , inventory - , characterDamage - , characterHitpoints' - , characterHitpoints - , hitpointRecoveryRate - , speed - - -- * Inventory - , Inventory(..) - , backpack - , wielded - , items - -- ** Wielded items - , Wielded(..) - , hands - , leftHand - , rightHand - , inLeftHand - , inRightHand - , doubleHanded - , wieldedItems - , WieldedItem(..) - , wieldedItem - , wieldableItem - , asWieldedItem - - -- * - , mkCharacter - , pickUpItem - , isDead - , 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 Xanthous.Util.QuickCheck -import Xanthous.Game.State -import Xanthous.Entities.Item -import Xanthous.Data - ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned - , Positioned(..) - ) -import Xanthous.Entities.RawTypes (WieldableItem, wieldable) -import qualified Xanthous.Entities.RawTypes as Raw --------------------------------------------------------------------------------- - -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 - -hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem) -hands = prism' (uncurry Hands) $ \case - Hands l r -> Just (l, r) - _ -> Nothing - -leftHand :: Traversal' Wielded WieldedItem -leftHand = hands . _1 . _Just - -inLeftHand :: WieldedItem -> Wielded -inLeftHand wi = Hands (Just wi) Nothing - -rightHand :: Traversal' Wielded WieldedItem -rightHand = hands . _2 . _Just - -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 Inventory = Inventory - { _backpack :: Vector Item - , _wielded :: Wielded - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary 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 - --------------------------------------------------------------------------------- - -data Character = Character - { _inventory :: !Inventory - , _characterName :: !(Maybe Text) - , _characterHitpoints' :: !Double - , _speed :: TicksPerTile - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Character -makeLenses ''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 = (pure .) $ positioned . characterHitpoints' %~ \hp -> - if hp > fromIntegral initialHitpoints - then hp - else hp + hitpointRecoveryRate |*| 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 - } - -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 - . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage) - -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 diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs deleted file mode 100644 index e95e9f0b985b..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Creature.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Creature - ( -- * Creature - Creature(..) - -- ** Lenses - , creatureType - , hitpoints - , hippocampus - - -- ** Creature functions - , newWithType - , damage - , isDead - , visionRadius - - -- * Hippocampus - , Hippocampus(..) - -- ** Lenses - , destination - -- ** Destination - , Destination(..) - , destinationFromPos - -- *** Lenses - , destinationPosition - , destinationProgress - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic -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 --------------------------------------------------------------------------------- - -data Creature = Creature - { _creatureType :: !CreatureType - , _hitpoints :: !Hitpoints - , _hippocampus :: !Hippocampus - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Creature -instance Arbitrary Creature where arbitrary = genericArbitrary -makeLenses ''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 - --------------------------------------------------------------------------------- - -newWithType :: CreatureType -> Creature -newWithType _creatureType = - let _hitpoints = _creatureType ^. maxHitpoints - _hippocampus = initialHippocampus - in Creature {..} - -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/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs deleted file mode 100644 index 501a5b597221..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Creature.Hippocampus - (-- * Hippocampus - Hippocampus(..) - , initialHippocampus - -- ** Lenses - , destination - -- ** 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 -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - - -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) - } - 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 Nothing diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Draw/Util.hs deleted file mode 100644 index aa6c5fa4fc47..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs deleted file mode 100644 index a0c037a1b4ed..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs-boot deleted file mode 100644 index 519a862c6a5a..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Environment.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Environment.hs deleted file mode 100644 index b45a91eabed2..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/Item.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs deleted file mode 100644 index b50a5eab809d..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Item.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StandaloneDeriving #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Item - ( Item(..) - , itemType - , newWithType - , isEdible - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Test.QuickCheck -import Data.Aeson (ToJSON, FromJSON) -import Data.Aeson.Generic.DerivingVia --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes hiding (Item, description, isEdible) -import qualified Xanthous.Entities.RawTypes as Raw -import Xanthous.Game.State --------------------------------------------------------------------------------- - -data Item = Item - { _itemType :: ItemType - } - deriving stock (Eq, Show, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Draw via DrawRawChar "_itemType" Item - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - Item -makeLenses ''Item - -{-# ANN Item ("HLint: ignore Use newtype instead of data" :: String )#-} - --- deriving via (Brainless Item) instance Brain Item -instance Brain Item where step = brainVia Brainless - -instance Arbitrary Item where - arbitrary = Item <$> arbitrary - -instance Entity Item where - description = view $ itemType . Raw.description - entityChar = view $ itemType . Raw.char - entityCollision = const Nothing - -newWithType :: ItemType -> Item -newWithType = Item - -isEdible :: Item -> Bool -isEdible = Raw.isEdible . view itemType diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs deleted file mode 100644 index 14d02872ed4e..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs b/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs deleted file mode 100644 index 30039662f071..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/RawTypes.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DuplicateRecordFields #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.RawTypes - ( - EntityRaw(..) - , _Creature - , _Item - - -- * Creatures - , CreatureType(..) - , hostile - - -- * Items - , ItemType(..) - -- ** Item sub-types - -- *** Edible - , EdibleItem(..) - , isEdible - -- *** Wieldable - , WieldableItem(..) - , isWieldable - - -- * Lens classes - , HasAttackMessage(..) - , HasChar(..) - , HasDamage(..) - , HasDescription(..) - , HasEatMessage(..) - , HasEdible(..) - , HasFriendly(..) - , HasHitpointsHealed(..) - , HasLongDescription(..) - , HasMaxHitpoints(..) - , HasName(..) - , HasSpeed(..) - , HasWieldable(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude -import Test.QuickCheck -import Data.Aeson.Generic.DerivingVia -import Data.Aeson (ToJSON, FromJSON) --------------------------------------------------------------------------------- -import Xanthous.Messages (Message(..)) -import Xanthous.Data (TicksPerTile, Hitpoints) -import Xanthous.Data.EntityChar -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - -data CreatureType = CreatureType - { _name :: !Text - , _description :: !Text - , _char :: !EntityChar - , _maxHitpoints :: !Hitpoints - , _friendly :: !Bool - , _speed :: !TicksPerTile - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary CreatureType - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - 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 - , _attackMessage :: !(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 - , _edible :: Maybe EdibleItem - , _wieldable :: Maybe WieldableItem - } - deriving stock (Show, Eq, Ord, Generic) - deriving anyclass (NFData, CoArbitrary, Function) - deriving Arbitrary via GenericArbitrary ItemType - deriving (ToJSON, FromJSON) - via WithOptions '[ FieldLabelModifier '[Drop 1] ] - ItemType -makeFieldsNoPrefix ''ItemType - --- | 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/glittershark/xanthous/src/Xanthous/Entities/Raws.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs deleted file mode 100644 index d4cae7ccc299..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Entities.Raws - ( raws - , raw - , RawType(..) - , rawsWithType - , entityFromRaw - ) where --------------------------------------------------------------------------------- -import Data.FileEmbed -import qualified Data.Yaml as Yaml -import Xanthous.Prelude -import System.FilePath.Posix --------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes -import Xanthous.Game.State -import qualified Xanthous.Entities.Creature as Creature -import qualified Xanthous.Entities.Item as Item -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 - --------------------------------------------------------------------------------- - -entityFromRaw :: EntityRaw -> SomeEntity -entityFromRaw (Creature creatureType) - = SomeEntity $ Creature.newWithType creatureType -entityFromRaw (Item itemType) - = SomeEntity $ Item.newWithType itemType diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml deleted file mode 100644 index 2eac895190b3..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml +++ /dev/null @@ -1,13 +0,0 @@ -Creature: - name: gormlak - description: a gormlak - longDescription: | - A chittering imp-like creature with bright yellow horns. It adores shiny objects - and gathers in swarms. - char: - char: g - style: - foreground: red - maxHitpoints: 5 - speed: 125 - friendly: false diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml deleted file mode 100644 index c3f19dce91d1..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/noodles.yaml +++ /dev/null @@ -1,12 +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! diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml b/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml deleted file mode 100644 index bc7fde4d8b02..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Entities/Raws/stick.yaml +++ /dev/null @@ -1,14 +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: - - You bonk the {{creature.creatureType.name}} over the head with your stick. - - You bash the {{creature.creatureType.name}} on the noggin with your stick. - - You whack the {{creature.creatureType.name}} with your stick. diff --git a/users/glittershark/xanthous/src/Xanthous/Game.hs b/users/glittershark/xanthous/src/Xanthous/Game.hs deleted file mode 100644 index 89c23f0de850..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs deleted file mode 100644 index 1b15ad4ffa64..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Arbitrary.hs +++ /dev/null @@ -1,51 +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 - pure $ GameState {..} - - -instance CoArbitrary GameLevel -instance Function GameLevel -instance CoArbitrary GameState -instance Function GameState diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs b/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs deleted file mode 100644 index 2375ae8c557e..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Draw.hs +++ /dev/null @@ -1,143 +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 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.Character -import Xanthous.Entities.Item (Item) -import Xanthous.Game - ( characterPosition - , character - , revealedEntitiesAtPosition - ) -import Xanthous.Game.Prompt -import Xanthous.Orphans () --------------------------------------------------------------------------------- - -cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName -cursorPosition game - | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState 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, _) -> - txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit - (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg - (SContinue, _, _) -> 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 - :: GameState - -> Widget ResourceName -drawEntities game = vBox rows - where - allEnts = game ^. entities - entityPositions = EntityMap.positions allEnts - maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions - maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions - rows = mkRow <$> [0..maxY] - mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] - renderEntityAt pos - = renderTopEntity pos $ revealedEntitiesAtPosition pos game - renderTopEntity pos ents - = let neighbors = EntityMap.neighbors pos allEnts - in maybe (str " ") (drawWithNeighbors neighbors) - $ maximumBy (compare `on` drawPriority) - <$> fromNullable ents - -drawMap :: GameState -> Widget ResourceName -drawMap game - = viewport Resource.MapViewport Both - . cursorPosition game - $ drawEntities game - -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) - - -drawPanel :: GameState -> Panel -> Widget ResourceName -drawPanel game panel - = border - . hLimit 35 - . viewport (Resource.Panel panel) Vertical - . case panel of - InventoryPanel -> drawInventoryPanel - $ game - -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 game - = pure - . withBorderStyle unicode - $ case game ^. promptState of - NoPrompt -> drawMessages (game ^. messageHistory) - _ -> emptyWidget - <=> drawPromptState (game ^. promptState) - <=> - (maybe emptyWidget (drawPanel game) (game ^. activePanel) - <+> border (drawMap game) - ) - <=> drawCharacterInfo (game ^. character) diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Env.hs b/users/glittershark/xanthous/src/Xanthous/Game/Env.hs deleted file mode 100644 index 6e10d0f73581..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Env.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Env - ( GameEnv(..) - , eventChan - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude --------------------------------------------------------------------------------- -import Brick.BChan (BChan) -import Xanthous.Data.App (AppEvent) --------------------------------------------------------------------------------- - -data GameEnv = GameEnv - { _eventChan :: BChan AppEvent - } - deriving stock (Generic) -makeLenses ''GameEnv -{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-} diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs b/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs deleted file mode 100644 index 6242b855f1cc..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Lenses.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Lenses - ( positionedCharacter - , character - , characterPosition - , updateCharacterVision - , characterVisiblePositions - , characterVisibleEntities - , getInitialState - , initialStateFromSeed - , entitiesAtCharacter - , revealedEntitiesAtPosition - - -- * 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 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 () --------------------------------------------------------------------------------- - -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 - } - _autocommand = NoAutocommand - in GameState {..} - - -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 - -visionRadius :: Word -visionRadius = 12 -- TODO make this dynamic - --- | Update the revealed entities at the character's position based on their --- vision -updateCharacterVision :: GameState -> GameState -updateCharacterVision game - = game & revealedPositions <>~ characterVisiblePositions game - -characterVisiblePositions :: GameState -> Set Position -characterVisiblePositions game = - let charPos = game ^. characterPosition - in visiblePositions charPos visionRadius $ game ^. entities - -characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity -characterVisibleEntities game = - let charPos = game ^. characterPosition - in visibleEntities charPos visionRadius $ game ^. entities - -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 :: Position -> GameState -> (VectorBag SomeEntity) -revealedEntitiesAtPosition p gs - | p `member` characterVisiblePositions gs - = entitiesAtPosition - | p `member` (gs ^. revealedPositions) - = immobileEntitiesAtPosition - | otherwise - = mempty - where - entitiesAtPosition = gs ^. entities . EntityMap.atPosition p - immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition diff --git a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs b/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs deleted file mode 100644 index 30b5fe7545e0..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/Prompt.hs +++ /dev/null @@ -1,289 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveFunctor #-} --------------------------------------------------------------------------------- -module Xanthous.Game.Prompt - ( PromptType(..) - , SPromptType(..) - , SingPromptType(..) - , PromptCancellable(..) - , PromptResult(..) - , PromptState(..) - , MenuOption(..) - , mkMenuItems - , PromptInput - , Prompt(..) - , mkPrompt - , mkMenu - , mkPointOnMapPrompt - , 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) -import Xanthous.Data (Direction, Position) -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 - 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" - -data SPromptType :: PromptType -> Type where - SStringPrompt :: SPromptType 'StringPrompt - SConfirm :: SPromptType 'Confirm - SMenu :: SPromptType ('Menu a) - SDirectionPrompt :: SPromptType 'DirectionPrompt - SPointOnMap :: SPromptType 'PointOnMap - SContinue :: SPromptType 'Continue - -instance NFData (SPromptType pt) where - rnf SStringPrompt = () - rnf SConfirm = () - rnf SMenu = () - rnf SDirectionPrompt = () - rnf SPointOnMap = () - rnf SContinue = () - -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 Show (SPromptType pt) where - show SStringPrompt = "SStringPrompt" - show SConfirm = "SConfirm" - show SMenu = "SMenu" - show SDirectionPrompt = "SDirectionPrompt" - show SPointOnMap = "SPointOnMap" - show SContinue = "SContinue" - -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 - 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 - --------------------------------------------------------------------------------- - -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 - -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` () - -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 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 () - -deriving stock instance Show (PromptState pt) - -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 smallestNotIn $ 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 _ = () - -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) - --- 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 -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m -mkPrompt c pt@SStringPrompt cb = - let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" - in Prompt c pt ps () cb -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 - -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 - -isCancellable :: Prompt m -> Bool -isCancellable (Prompt Cancellable _ _ _ _) = True -isCancellable (Prompt Uncancellable _ _ _ _) = False - -submitPrompt :: Applicative m => Prompt m -> m () -submitPrompt (Prompt _ pt ps _ cb) = - case (pt, ps) of - (SStringPrompt, StringPromptState edit) -> - cb . StringResult . mconcat . getEditContents $ edit - (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 diff --git a/users/glittershark/xanthous/src/Xanthous/Game/State.hs b/users/glittershark/xanthous/src/Xanthous/Game/State.hs deleted file mode 100644 index f614cad47339..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Game/State.hs +++ /dev/null @@ -1,558 +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 - , 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 - -- ** 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.Util.QuickCheck (GenericArbitrary(..)) -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 --------------------------------------------------------------------------------- - -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 - -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 - 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 - } - 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/glittershark/xanthous/src/Xanthous/Generators.hs b/users/glittershark/xanthous/src/Xanthous/Generators.hs deleted file mode 100644 index ef37070b6ede..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators - ( 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.CaveAutomata as CaveAutomata -import qualified Xanthous.Generators.Dungeon as Dungeon -import Xanthous.Generators.Util -import Xanthous.Generators.LevelContents -import Xanthous.Generators.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 <$> pure 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 - -> m Level -generateLevel gen ps dims = 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 cells - _levelDoors <- randomDoors cells - _levelCharacterPosition <- chooseCharacterPosition cells - let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)] - downStaircase <- placeDownStaircase cells - let _levelStaircases = upStaircase <> downStaircase - _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition - 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/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs deleted file mode 100644 index be904662f3f7..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.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.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/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs deleted file mode 100644 index f30713ce1182..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.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) -import Xanthous.Generators.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/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs deleted file mode 100644 index 8ebcc7f4da83..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs +++ /dev/null @@ -1,133 +0,0 @@ --------------------------------------------------------------------------------- -module Xanthous.Generators.LevelContents - ( chooseCharacterPosition - , randomItems - , randomCreatures - , randomDoors - , placeDownStaircase - , tutorialMessage - ) 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.Util -import Xanthous.Random -import Xanthous.Data - ( positionFromV2, Position, _Position - , rotations, arrayNeighbors, Neighbors(..) - , neighborPositions - ) -import Xanthous.Data.EntityMap (EntityMap, _EntityMap) -import Xanthous.Entities.Raws (rawsWithType, RawType) -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) --------------------------------------------------------------------------------- - -chooseCharacterPosition :: MonadRandom m => Cells -> m Position -chooseCharacterPosition = randomPosition - -randomItems :: MonadRandom m => Cells -> m (EntityMap Item) -randomItems = randomEntities 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 => Cells -> m (EntityMap Creature) -randomCreatures = randomEntities Creature.newWithType (0.0007, 0.002) - -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. (MonadRandom m, RawType raw) - => (raw -> 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 - raw <- choose raws - let entity = newWithType raw - pure (pos, entity) - pure $ _EntityMap # entities - -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 diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs deleted file mode 100644 index 88aadd5aadd9..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --------------------------------------------------------------------------------- -module Xanthous.Generators.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 - -numAliveNeighborsM - :: forall a i m - . (MArray a Bool m, Ix i, Integral i) - => a (V2 i) Bool - -> V2 i - -> m Word -numAliveNeighborsM cells (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 (V2 minX minY, V2 maxX maxY) (i, j) - | x <= minX - || y <= minY - || x >= maxX - || y >= maxY - = pure True - | otherwise = - let nx = fromIntegral $ fromIntegral x + i - ny = fromIntegral $ fromIntegral y + j - in readArray cells $ V2 nx ny - -numAliveNeighbors - :: forall a i - . (IArray a Bool, Ix i, Integral i) - => a (V2 i) Bool - -> V2 i - -> Word -numAliveNeighbors cells (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 (V2 minX minY, V2 maxX maxY) (i, j) - | x <= minX - || y <= minY - || x >= maxX - || y >= maxY - = 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/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs deleted file mode 100644 index cc9c9d963f5c..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Xanthous.Generators.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.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/glittershark/xanthous/src/Xanthous/Messages.hs b/users/glittershark/xanthous/src/Xanthous/Messages.hs deleted file mode 100644 index 2b1b3da1e8c1..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Messages.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- -module Xanthous.Messages - ( Message(..) - , resolve - , MessageMap(..) - , lookupMessage - - -- * Game messages - , messages - , render - , lookup - , message - , message_ - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (lookup) --------------------------------------------------------------------------------- -import Control.Monad.Random.Class (MonadRandom) -import Data.Aeson (FromJSON, ToJSON, toJSON) -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.Arbitrary.Generic -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 = genericArbitrary - 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 - -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/glittershark/xanthous/src/Xanthous/Messages/Template.hs b/users/glittershark/xanthous/src/Xanthous/Messages/Template.hs deleted file mode 100644 index 5176880355f4..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Monad.hs b/users/glittershark/xanthous/src/Xanthous/Monad.hs deleted file mode 100644 index db602de56f3a..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Orphans.hs b/users/glittershark/xanthous/src/Xanthous/Orphans.hs deleted file mode 100644 index 1fe9708edbe0..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Orphans.hs +++ /dev/null @@ -1,352 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PackageImports #-} -{-# OPTIONS_GHC -Wno-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Orphans - ( ppTemplate - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (elements, (.=)) --------------------------------------------------------------------------------- -import Data.Aeson -import Data.Aeson.Types (typeMismatch) -import Data.List.NonEmpty (NonEmpty(..)) -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 "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 Xanthous.Util.JSON -import Xanthous.Util.QuickCheck --------------------------------------------------------------------------------- - -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 = sized node - where - node n | n > 0 = oneof $ leaves ++ branches (n `div` 2) - 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 = 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 - -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 - --------------------------------------------------------------------------------- - -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) diff --git a/users/glittershark/xanthous/src/Xanthous/Prelude.hs b/users/glittershark/xanthous/src/Xanthous/Prelude.hs deleted file mode 100644 index 4d79b026f14a..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Prelude.hs +++ /dev/null @@ -1,47 +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 - ) -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/glittershark/xanthous/src/Xanthous/Random.hs b/users/glittershark/xanthous/src/Xanthous/Random.hs deleted file mode 100644 index 6d34109df7f8..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Random.hs +++ /dev/null @@ -1,118 +0,0 @@ --------------------------------------------------------------------------------- -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --------------------------------------------------------------------------------- -module Xanthous.Random - ( Choose(..) - , ChooseElement(..) - , Weighted(..) - , evenlyWeighted - , weightedBy - , subRand - , chance - , chooseSubset - ) 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 --------------------------------------------------------------------------------- - -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) - -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 - --------------------------------------------------------------------------------- - -bools :: NonEmpty Bool -bools = True :| [False] diff --git a/users/glittershark/xanthous/src/Xanthous/Util.hs b/users/glittershark/xanthous/src/Xanthous/Util.hs deleted file mode 100644 index 524ad4819dac..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util.hs +++ /dev/null @@ -1,252 +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 - , maximum1 - , minimum1 - - -- * Combinators - , times, times_ - - -- * Type-level programming utils - , KnownBool(..) - ) 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 --------------------------------------------------------------------------------- - -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 - -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) - -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) - --------------------------------------------------------------------------------- - --- | 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 diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs b/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs deleted file mode 100644 index 9e158cc8e2d4..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Util/Graph.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs deleted file mode 100644 index 8e5c04f4bfa9..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Util/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs deleted file mode 100644 index 6ba63a2d8a3f..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs +++ /dev/null @@ -1,178 +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/glittershark/xanthous/src/Xanthous/Util/Inflection.hs b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs deleted file mode 100644 index 724f2339dd21..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Util/JSON.hs b/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs deleted file mode 100644 index 91d1328e4a10..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Util/Optparse.hs b/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs deleted file mode 100644 index dfa65372351d..000000000000 --- a/users/glittershark/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/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs deleted file mode 100644 index be12bc294513..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs +++ /dev/null @@ -1,42 +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 -import GHC.Generics (Rep) --------------------------------------------------------------------------------- - -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 - --------------------------------------------------------------------------------- - -newtype GenericArbitrary a = GenericArbitrary a - deriving newtype Generic - -instance (Generic a, GArbitrary rep, Rep a ~ rep) - => Arbitrary (GenericArbitrary a) where - arbitrary = genericArbitrary diff --git a/users/glittershark/xanthous/src/Xanthous/messages.yaml b/users/glittershark/xanthous/src/Xanthous/messages.yaml deleted file mode 100644 index c1835ef2327b..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/messages.yaml +++ /dev/null @@ -1,120 +0,0 @@ -welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Use hjklybnu to move. -dead: - - You have died... - - You die... - - You perish... - - You have perished... - -generic: - continue: Press enter to continue... - -save: - 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}} - -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? " - -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! - 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: - - The {{creature.creatureType.name}} hits you! - - The {{creature.creatureType.name}} attacks you! - 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}}\"" - -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? - # TODO: use actual hands - wielded : You wield the {{wieldedItem.itemType.name}} in your right hand. - -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. - -autoMove: - enemyInSight: - - There's a {{firstEntity.creatureType.name}} nearby! -### - -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 ,. |