From 493ff7950dfefb677820cfca39f16a3a1dd7f487 Mon Sep 17 00:00:00 2001 From: avery Date: Sun, 29 Dec 2024 15:54:00 +0000 Subject: [PATCH] Finally fix up that useless EnclosingObject class and do it all with taggedobject --- yaifl/run_no | 2 +- yaifl/src/Yaifl.hs | 1 - yaifl/src/Yaifl/Game/Actions/Closing.hs | 1 - yaifl/src/Yaifl/Game/Actions/Examining.hs | 2 +- yaifl/src/Yaifl/Game/Actions/GettingOff.hs | 8 +- yaifl/src/Yaifl/Game/Actions/Going.hs | 13 ++- .../Yaifl/Game/Actions/Looking/Visibility.hs | 2 - yaifl/src/Yaifl/Game/Create/Object.hs | 4 +- yaifl/src/Yaifl/Game/Create/RoomConnection.hs | 6 +- yaifl/src/Yaifl/Game/Create/Rule.hs | 14 ++- yaifl/src/Yaifl/Game/Move.hs | 16 ++-- yaifl/src/Yaifl/Game/ObjectSpecifics.hs | 14 +-- yaifl/src/Yaifl/Game/Parser.hs | 4 +- yaifl/src/Yaifl/Model/Actions/Args.hs | 3 +- yaifl/src/Yaifl/Model/Entity.hs | 8 +- yaifl/src/Yaifl/Model/Kinds/AnyObject.hs | 10 +-- yaifl/src/Yaifl/Model/Kinds/Container.hs | 11 +-- yaifl/src/Yaifl/Model/Kinds/Enclosing.hs | 5 +- yaifl/src/Yaifl/Model/Kinds/Person.hs | 8 +- yaifl/src/Yaifl/Model/Kinds/Room.hs | 8 +- yaifl/src/Yaifl/Model/Kinds/Supporter.hs | 2 + yaifl/src/Yaifl/Model/Kinds/Thing.hs | 11 +-- yaifl/src/Yaifl/Model/ObjectLike.hs | 10 +-- yaifl/src/Yaifl/Model/Query.hs | 88 +++++++++---------- yaifl/src/Yaifl/Model/Tag.hs | 66 ++++++-------- yaifl/test/Yaifl/Test/Chapter3/Laura.hs | 2 - 26 files changed, 135 insertions(+), 184 deletions(-) diff --git a/yaifl/run_no b/yaifl/run_no index deadc0f..e9244f9 100644 --- a/yaifl/run_no +++ b/yaifl/run_no @@ -1 +1 @@ -751 \ No newline at end of file +752 \ No newline at end of file diff --git a/yaifl/src/Yaifl.hs b/yaifl/src/Yaifl.hs index ccb85b9..f8f6630 100644 --- a/yaifl/src/Yaifl.hs +++ b/yaifl/src/Yaifl.hs @@ -39,7 +39,6 @@ import Yaifl.Model.Metadata import Yaifl.Model.Kinds.Direction import Yaifl.Model.Entity import Yaifl.Game.ObjectSpecifics -import Yaifl.Game.Create.Object import Yaifl.Model.Kinds.Container import Yaifl.Model.Kinds.Door import Yaifl.Model.Kinds.Enclosing diff --git a/yaifl/src/Yaifl/Game/Actions/Closing.hs b/yaifl/src/Yaifl/Game/Actions/Closing.hs index acaed66..d4dc1a8 100644 --- a/yaifl/src/Yaifl/Game/Actions/Closing.hs +++ b/yaifl/src/Yaifl/Game/Actions/Closing.hs @@ -4,7 +4,6 @@ module Yaifl.Game.Actions.Closing where import Yaifl.Model.Action import Yaifl.Prelude import Yaifl.Model.Actions.Args -import Yaifl.Model.Action import Yaifl.Model.HasProperty import Yaifl.Model.Kinds.Openable import Yaifl.Model.Rules.Rulebook diff --git a/yaifl/src/Yaifl/Game/Actions/Examining.hs b/yaifl/src/Yaifl/Game/Actions/Examining.hs index 87fd939..f7c88d0 100644 --- a/yaifl/src/Yaifl/Game/Actions/Examining.hs +++ b/yaifl/src/Yaifl/Game/Actions/Examining.hs @@ -140,7 +140,7 @@ examineContainers = Rule "examine containers rule" forPlayer' $ \a@Args{..} -> d -- if the noun is closed and the noun is opaque, make no decision; flip (maybe (return (Nothing, Nothing))) (getContainerMaybe =<< o) $ \cont -> do p <- getPlayer - playerInObject <- enclosingContains (tag (cont ^. #enclosing) obj) p + playerInObject <- enclosingContains (tagEntity (cont ^. #enclosing) obj) p if isOpaqueClosedContainer cont then return (Nothing, Nothing) else do -- if something described which is not scenery is in the noun and something which -- is not the player is in the noun and the noun is not falsely-unoccupied: diff --git a/yaifl/src/Yaifl/Game/Actions/GettingOff.hs b/yaifl/src/Yaifl/Game/Actions/GettingOff.hs index a6b92a6..0cc7fd0 100644 --- a/yaifl/src/Yaifl/Game/Actions/GettingOff.hs +++ b/yaifl/src/Yaifl/Game/Actions/GettingOff.hs @@ -9,12 +9,10 @@ import Yaifl.Text.Say import Yaifl.Model.Kinds.Thing ( thingContainedBy ) import Yaifl.Model.HasProperty import Yaifl.Model.Kinds.Enclosing -import Yaifl.Model.Kinds.Container -import Yaifl.Model.Tag +import Yaifl.Model.Tag ( getTaggedObject, tagObject ) import Yaifl.Model.Kinds.Supporter import Yaifl.Game.Move (move) import Yaifl.Model.Query -import Yaifl.Model.Entity import Yaifl.Model.Metadata import Yaifl.Text.AdaptiveNarrative import Yaifl.Text.Verb (Tense(..)) @@ -23,7 +21,7 @@ data GettingOffResponses wm type GettingOffAction wm = Action wm () ('TakesOneOf 'TakesThingParameter 'TakesNoParameter) (SupporterThing wm) -gettingOffAction :: forall wm. (WithPrintingNameOfSomething wm, WMWithProperty wm Enclosing, WMWithProperty wm Container, WMWithProperty wm Supporter) => GettingOffAction wm +gettingOffAction :: forall wm. (WithPrintingNameOfSomething wm, WMWithProperty wm Enclosing, WMWithProperty wm Supporter) => GettingOffAction wm gettingOffAction = (makeAction "getting off") { name = "getting off" , understandAs = ["get off", "get up"] @@ -67,7 +65,7 @@ standardGettingOff :: standardGettingOff = makeRule "standard getting off rule" [] $ \Args{source=s, variables=v} -> do let supporterHolder = thingContainedBy (getTaggedObject v) e' <- getEnclosingObject supporterHolder - move s (tagObject @_ @EnclosingTag (snd e') (fst e')) + move s e' rulePass reportGettingOff :: diff --git a/yaifl/src/Yaifl/Game/Actions/Going.hs b/yaifl/src/Yaifl/Game/Actions/Going.hs index b118528..cbe940e 100644 --- a/yaifl/src/Yaifl/Game/Actions/Going.hs +++ b/yaifl/src/Yaifl/Game/Actions/Going.hs @@ -149,13 +149,13 @@ goingActionSet (UnverifiedArgs Args{..}) = do -- if the noun is a door, let the target be the noun; -- now the door gone through is the target; -- now the target is the other side of the target from the room gone from; - Just (Right door) -> pure $ (\ds -> getConnectionViaDoor (tag ds (getID door)) roomGoneFrom) =<< getDoorMaybe door + Just (Right door) -> pure $ (\ds -> getConnectionViaDoor (tagEntity ds (getID door)) roomGoneFrom) =<< getDoorMaybe door Nothing -> do mbThrough <- getMatchingThing "through" pure $ do door <- mbThrough ds <- getDoorMaybe door - getConnectionViaDoor (tag ds (getID door)) roomGoneFrom + getConnectionViaDoor (tagEntity ds (getID door)) roomGoneFrom case mbTargetAndConn of Nothing -> flip (cantGoThatWay source) roomGoneFrom =<< getMatchingThing "through" Just (target, conn) -> do @@ -269,15 +269,14 @@ inTheRegion r = Precondition (lookupRegion r >>= \(Right o) -> pure $ "in the re -} throughTheDoor :: forall d wm. - TaggedAs d DoorTag + HasID d => d -> Precondition wm (Args wm (GoingActionVariables wm)) -throughTheDoor d = Precondition (pure "through a specific door") $ \v -> pure $ (getID <$> doorGoneThrough (variables v)) == Just (getID $ toTag @d @DoorTag d) +throughTheDoor d = Precondition (pure "through a specific door") $ \v -> pure $ (getID <$> doorGoneThrough (variables v)) == Just (getID d) throughTheClosedDoor :: forall d wm. - TaggedAs d DoorTag - => WMWithProperty wm Openability + WMWithProperty wm Openability => ThingLike wm d => d -> Precondition wm (Args wm (GoingActionVariables wm)) @@ -285,4 +284,4 @@ throughTheClosedDoor d = Precondition (pure "through a specific closed door") $ o <- getThing d pure $ isClosed o && - (getID <$> doorGoneThrough (variables v)) == Just (getID $ toTag @d @DoorTag d) \ No newline at end of file + (getID <$> doorGoneThrough (variables v)) == Just (getID d) \ No newline at end of file diff --git a/yaifl/src/Yaifl/Game/Actions/Looking/Visibility.hs b/yaifl/src/Yaifl/Game/Actions/Looking/Visibility.hs index 08db6cc..51c9ef0 100644 --- a/yaifl/src/Yaifl/Game/Actions/Looking/Visibility.hs +++ b/yaifl/src/Yaifl/Game/Actions/Looking/Visibility.hs @@ -18,11 +18,9 @@ import Yaifl.Model.HasProperty import Yaifl.Model.Query import Yaifl.Model.Kinds.Supporter import Yaifl.Model.WorldModel -import Yaifl.Model.Actions.Args import qualified Data.EnumSet as DES import Yaifl.Model.Kinds.AnyObject import Yaifl.Model.Metadata -import Yaifl.Text.Say -- | An easier way to describe the requirements to look. type HasLookingProperties wm = diff --git a/yaifl/src/Yaifl/Game/Create/Object.hs b/yaifl/src/Yaifl/Game/Create/Object.hs index b0d259f..bbc51a2 100644 --- a/yaifl/src/Yaifl/Game/Create/Object.hs +++ b/yaifl/src/Yaifl/Game/Create/Object.hs @@ -95,7 +95,7 @@ addObject updWorld n d ty isT specifics details mbLocation = Just loc -> do encLoc <- getObject loc asThingOrRoom - (void . move @_ @_ @(EnclosingThing wm) t . tagObject @EnclosingEntity @EnclosingTag loc) + (void . move @(EnclosingThing wm) @_ @_ t . tagObject @EnclosingEntity @EnclosingTag loc) (void . move t) encLoc ) @@ -116,7 +116,7 @@ addThingInternal :: addThingInternal name ia desc objtype specifics details mbLoc = do t <- Thing <$> addObject (setThing . Thing) name desc objtype True specifics (fromMaybe (blankThingData ia) details) mbLoc - pure (tagThing t) + pure (tagThingEntity t) addThing :: forall wm es. diff --git a/yaifl/src/Yaifl/Game/Create/RoomConnection.hs b/yaifl/src/Yaifl/Game/Create/RoomConnection.hs index 465835d..eba9d55 100644 --- a/yaifl/src/Yaifl/Game/Create/RoomConnection.hs +++ b/yaifl/src/Yaifl/Game/Create/RoomConnection.hs @@ -48,7 +48,6 @@ import Yaifl.Model.Rules (RuleEffects) import Yaifl.Prelude hiding (Down) import Yaifl.Model.Kinds.Supporter (SupporterEntity) import Yaifl.Game.Move (move) -import Yaifl.Model.Tag import Yaifl.Model.Kinds.Enclosing getAllConnections :: @@ -275,6 +274,5 @@ isNowOn :: -> Eff es () isNowOn t e = do t' <- getThing t - e' <- getEnclosingObject (coerceTag e) - let e'' = TaggedObject (coerceTag @_ @EnclosingTag e, fst e') - void $ move t' e'' \ No newline at end of file + e' <- getEnclosingObject e + void $ move t' e' \ No newline at end of file diff --git a/yaifl/src/Yaifl/Game/Create/Rule.hs b/yaifl/src/Yaifl/Game/Create/Rule.hs index 4307543..0311ca9 100644 --- a/yaifl/src/Yaifl/Game/Create/Rule.hs +++ b/yaifl/src/Yaifl/Game/Create/Rule.hs @@ -18,10 +18,8 @@ import Yaifl.Prelude import Yaifl.Model.Action ( Action, WorldActions ) import Yaifl.Game.Actions.Collection (ActionCollection) import Yaifl.Model.Kinds.Object -import Yaifl.Model.Entity import Yaifl.Model.ObjectLike import Yaifl.Model.Query -import Yaifl.Model.Tag import Yaifl.Model.Actions.Args import Yaifl.Model.Rules.Rulebook import Yaifl.Model.Rules.RuleEffects @@ -112,8 +110,8 @@ theObject' o = Precondition } whenIn :: - TaggedAs e EnclosingTag - => ObjectLike wm e + ObjectLike wm e + => IsEnclosing e => e -> Precondition wm (Args wm v) whenIn e = Precondition @@ -122,12 +120,12 @@ whenIn e = Precondition pure $ "when in the location " <> display (e' ^. #name) , checkPrecondition = \args -> do hierarchy <- getContainingHierarchy (args ^. #source) - pure $ elem (toTag e) hierarchy + pure $ elem (getEnclosingEntity e) hierarchy } whenPlayerIsIn :: - TaggedAs e EnclosingTag - => ObjectLike wm e + ObjectLike wm e + => IsEnclosing e => e -> Precondition wm a whenPlayerIsIn e = Precondition @@ -136,7 +134,7 @@ whenPlayerIsIn e = Precondition pure $ "when in the location " <> display (e' ^. #name) , checkPrecondition = const $ do hierarchy <- getPlayer' >>= getContainingHierarchy - pure $ elem (toTag e) hierarchy + pure $ elem (getEnclosingEntity e) hierarchy } aKindOf :: diff --git a/yaifl/src/Yaifl/Game/Move.hs b/yaifl/src/Yaifl/Game/Move.hs index 5d61147..23eefde 100644 --- a/yaifl/src/Yaifl/Game/Move.hs +++ b/yaifl/src/Yaifl/Game/Move.hs @@ -21,12 +21,13 @@ import qualified Data.EnumSet as ES import Yaifl.Model.Kinds.AnyObject move :: + forall l wm es. Breadcrumbs :> es => State Metadata :> es => ObjectQuery wm es => Display (WMText wm) => WMWithProperty wm Enclosing - => EnclosingObject l + => IsEnclosingObject l => ObjectLike wm l => Thing wm -> l @@ -35,16 +36,17 @@ move objectToMove oLoc = failHorriblyIfMissing moveBlock where moveBlock = withSpan' "move" "" $ do objectToMove' <- refreshThing objectToMove - let loc :: Enclosing = oLoc ^. enclosingL + let loc :: Enclosing = getEnclosing oLoc let (c :: EnclosingEntity) = thingContainedBy objectToMove' c' <- getObject c oLoc' <- getObject oLoc - let (oldLocEnc :: Enclosing) = getEnclosing c c' + let (taggedEnc :: TaggedAnyEnclosing wm) = tagObject c c' + let (oldLocEnc :: Enclosing) = getEnclosing taggedEnc addTag "object to move" (display $ objectToMove') addTag "current location" (display $ c') addTag "new location" (display $ oLoc') modifySpan (\s -> s { _spanName = display (objectToMove' ^. #name) }) - let (movedObj, oldLocation, newLocation) = moveObjects (tag oldLocEnc (getID oLoc')) objectToMove' oldLocEnc loc + let (movedObj, oldLocation, newLocation) = moveObjects (tagEntity oldLocEnc (getID oLoc')) objectToMove' oldLocEnc loc setThing movedObj setEnclosing c' oldLocation setEnclosing oLoc' newLocation @@ -54,9 +56,9 @@ move objectToMove oLoc = failHorriblyIfMissing moveBlock moveObjects :: EnclosingEntity -> Thing wm -> Enclosing -> Enclosing -> (Thing wm, Enclosing, Enclosing) moveObjects newId t oldLoc newLocEncl = let (newLoc', t') = nowContains newId newLocEncl t in (t', oldLoc `noLongerContains` t, newLoc') noLongerContains :: Enclosing -> Thing wm -> Enclosing -noLongerContains cont obj = cont & (#contents %~ ES.delete (tagThing obj)) +noLongerContains cont obj = cont & (#contents %~ ES.delete (tagThingEntity obj)) nowContains :: EnclosingEntity -> Enclosing -> Thing wm -> (Enclosing, Thing wm) -nowContains contId cont obj = (cont & (#contents %~ ES.insert (tagThing obj)), obj & (#objectData % #containedBy .~ contId)) +nowContains contId cont obj = (cont & (#contents %~ ES.insert (tagThingEntity obj)), obj & (#objectData % #containedBy .~ contId)) updateToContain :: NoMissingObjects wm es @@ -66,4 +68,4 @@ updateToContain :: -> Thing wm -> Eff es () updateToContain cont enc obj = do - setEnclosing cont (enc & (#contents %~ ES.insert (tagThing obj))) \ No newline at end of file + setEnclosing cont (enc & (#contents %~ ES.insert (tagThingEntity obj))) \ No newline at end of file diff --git a/yaifl/src/Yaifl/Game/ObjectSpecifics.hs b/yaifl/src/Yaifl/Game/ObjectSpecifics.hs index 7051e98..85b24a8 100644 --- a/yaifl/src/Yaifl/Game/ObjectSpecifics.hs +++ b/yaifl/src/Yaifl/Game/ObjectSpecifics.hs @@ -148,9 +148,9 @@ addDoor n (arg #front -> f) (arg #back -> b) ia des (argDef #described Described -- A door is always fixed in place. -- A door is never pushable between rooms. updateMultiLocatedObject d - let tagged = tag @Door @DoorTag ds d + let tagged = tagEntity @Door @DoorTag ds d addDoorToConnection tagged f b - pure (tag ds d) + pure (tagEntity ds d) addBackdrop :: forall wm es. @@ -194,9 +194,9 @@ updateMultiLocatedObject tl = do case getMultiLocatedMaybe t of Nothing -> noteError (const ()) "the object had no multilocated component" Just ml -> mapM_ (\x -> do - obj <- getObject x - let enc = getEnclosing x obj - updateToContain obj enc t) (S.toList $ ml ^. #locations) + obj <- getEnclosingObject x + let enc = getEnclosing obj + updateToContain (getTaggedObject obj) enc t) (S.toList $ ml ^. #locations) addDevice :: forall wm es. @@ -247,7 +247,7 @@ addContainer n ia d ! paramF #portable p ! paramF #modify m ! done - pure $ tag @Container @ContainerTag cs c + pure $ tagEntity @Container @ContainerTag cs c addSupporter :: forall wm es. @@ -272,7 +272,7 @@ addSupporter n ia d ! paramF #location l ! paramF #modify m ! done - pure $ tag @_ @SupporterTag sup c + pure $ tagEntity @_ @SupporterTag sup c addPerson :: forall wm es. diff --git a/yaifl/src/Yaifl/Game/Parser.hs b/yaifl/src/Yaifl/Game/Parser.hs index e7b461b..adecc08 100644 --- a/yaifl/src/Yaifl/Game/Parser.hs +++ b/yaifl/src/Yaifl/Game/Parser.hs @@ -292,10 +292,10 @@ tryFindingObject t = failHorriblyIfMissing $ do (const $ return $ (obj, enc)) obj - (playerLocObj, domainEnc) <- getUppermostDomain =<< getEnclosingObject (thingContainedBy pl) + (playerLocObj, domainEnc) <- (\t -> getUppermostDomain (getTaggedObject t, getEnclosing t)) =<< getEnclosingObject (thingContainedBy pl) -- okay, if we bother doing a proper scanning loop it'll go here -- but for now, we just want to consider anything recursively present. that'll do. - allItems <- getAllObjectsInEnclosing IncludeScenery IncludeDoors (tag domainEnc playerLocObj) + allItems <- getAllObjectsInEnclosing IncludeScenery IncludeDoors (tagEntity domainEnc playerLocObj) findObjectsFrom t allItems True diff --git a/yaifl/src/Yaifl/Model/Actions/Args.hs b/yaifl/src/Yaifl/Model/Actions/Args.hs index 9a5b2d2..d9585e2 100644 --- a/yaifl/src/Yaifl/Model/Actions/Args.hs +++ b/yaifl/src/Yaifl/Model/Actions/Args.hs @@ -26,7 +26,6 @@ module Yaifl.Model.Actions.Args import Yaifl.Prelude hiding (show) -import Yaifl.Model.ObjectLike import Yaifl.Model.Kinds.Object import Yaifl.Model.WorldModel import Yaifl.Model.Effects @@ -157,7 +156,7 @@ instance Display (Args wm v) where instance {-# OVERLAPPING #-} Refreshable wm v => Refreshable wm (Args wm v) where refresh av = do v <- refresh (variables av) - o <- getThing (tagThing $ source av) + o <- refresh $ source av return $ av { source = o, variables = v } -- | Before 'Args' are parsed, the variable is just a command string diff --git a/yaifl/src/Yaifl/Model/Entity.hs b/yaifl/src/Yaifl/Model/Entity.hs index 85806e1..a113048 100644 --- a/yaifl/src/Yaifl/Model/Entity.hs +++ b/yaifl/src/Yaifl/Model/Entity.hs @@ -47,17 +47,17 @@ instance HasID Entity where instance Display Entity where displayBuilder i = "(ID: " <> show i <> ")" --- | An entity tagged with a phantom @tag@ for keeping some semblance of type safety +-- | An entity tagged with a phantom @tagEntity@ for keeping some semblance of type safety -- when indirectly storing references to other objects. The tagging mechanisms are in -- @Yaifl.Model.Objects.Tag@. -newtype TaggedEntity tag = TaggedEntity { unTag :: Entity } +newtype TaggedEntity tagEntity = TaggedEntity { unTag :: Entity } deriving stock (Show, Generic) deriving newtype (Eq, Num, Read, Bounded, Hashable, Enum, Ord, Real, Integral) -- | Tag an entity without a witness. unsafeTagEntity :: - Entity -- ^ Entity to tag - -> TaggedEntity tag + Entity -- ^ Entity to tagEntity + -> TaggedEntity tagEntity unsafeTagEntity = TaggedEntity instance HasID (TaggedEntity t) where diff --git a/yaifl/src/Yaifl/Model/Kinds/AnyObject.hs b/yaifl/src/Yaifl/Model/Kinds/AnyObject.hs index 6aa200c..6ea10db 100644 --- a/yaifl/src/Yaifl/Model/Kinds/AnyObject.hs +++ b/yaifl/src/Yaifl/Model/Kinds/AnyObject.hs @@ -58,15 +58,7 @@ instance CanBeAny wm (AnyObject wm) where toAny = id fromAny = Just -instance CanBeAny wm (TaggedObject (Thing wm) ThingTag) where - toAny = toAny . snd . unTagObject - fromAny o = (\t -> TaggedObject (tag t (getID t), t)) <$> fromAny o - -instance CanBeAny wm (TaggedObject (Room wm) RoomTag) where - toAny = toAny . snd . unTagObject - fromAny o = (\t -> TaggedObject (tag t (getID t), t)) <$> fromAny o - instance IsObject (AnyObject wm) where isThing = isJust . fromAny @wm @(Thing wm) -type TaggedAnyEnclosing wm = TaggedObject (AnyObject wm) EnclosingTag +type TaggedAnyEnclosing wm = TaggedObject (AnyObject wm) EnclosingTag \ No newline at end of file diff --git a/yaifl/src/Yaifl/Model/Kinds/Container.hs b/yaifl/src/Yaifl/Model/Kinds/Container.hs index ebac58c..706b2b5 100644 --- a/yaifl/src/Yaifl/Model/Kinds/Container.hs +++ b/yaifl/src/Yaifl/Model/Kinds/Container.hs @@ -39,7 +39,7 @@ import Yaifl.Model.HasProperty ( WMWithProperty ) import Yaifl.Model.Kinds.AnyObject import Yaifl.Model.Kinds.Enclosing import Yaifl.Model.Kinds.Openable -import Yaifl.Model.Query ( defaultPropertySetter, defaultPropertyGetter, modifyProperty, ObjectLike (..) ) +import Yaifl.Model.Query ( defaultPropertySetter, defaultPropertyGetter, modifyProperty, ObjectLike (..), IsEnclosing ) import Yaifl.Model.TH ( makeSpecificsWithout ) import Yaifl.Model.Tag import Yaifl.Model.Kinds.Object @@ -167,11 +167,4 @@ instance Taggable ContainerEntity EnclosingTag instance Taggable Container EnclosingTag instance Taggable Container ContainerTag -instance TaggedAs (TaggedContainer wm) ContainerTag where - toTag = fst . unTagObject - -instance TaggedAs (TaggedContainer wm) EnclosingTag where - toTag = coerceTag . fst . unTagObject - -instance TaggedAs (TaggedEntity ContainerTag) EnclosingTag where - toTag = coerceTag \ No newline at end of file +instance IsEnclosing ContainerEntity \ No newline at end of file diff --git a/yaifl/src/Yaifl/Model/Kinds/Enclosing.hs b/yaifl/src/Yaifl/Model/Kinds/Enclosing.hs index e672e9b..765b591 100644 --- a/yaifl/src/Yaifl/Model/Kinds/Enclosing.hs +++ b/yaifl/src/Yaifl/Model/Kinds/Enclosing.hs @@ -37,7 +37,4 @@ blankEnclosing = Enclosing -- | Shorthand for enclosing entities. type EnclosingEntity = TaggedEntity EnclosingTag -instance Taggable Enclosing EnclosingTag - -instance HasID x => TaggedAs (x, Enclosing) EnclosingTag where - toTag (o, e) = tag e o \ No newline at end of file +instance Taggable Enclosing EnclosingTag \ No newline at end of file diff --git a/yaifl/src/Yaifl/Model/Kinds/Person.hs b/yaifl/src/Yaifl/Model/Kinds/Person.hs index 2d44b56..0998c2f 100644 --- a/yaifl/src/Yaifl/Model/Kinds/Person.hs +++ b/yaifl/src/Yaifl/Model/Kinds/Person.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} module Yaifl.Model.Kinds.Person where import Yaifl.Prelude @@ -57,11 +58,14 @@ getPerson :: -> Person getPerson = fromMaybe (error "person property witness was violated") . getPersonMaybe . getTaggedObject -instance EnclosingObject Person where - enclosingL = castOptic #carrying +type TaggedPerson wm = TaggedObject (Thing wm) PersonTag + +instance WMWithProperty wm Person => IsEnclosingObject (TaggedPerson wm) where + getEnclosing = view #carrying . getPerson isNowCarriedBy :: NoMissingObjects wm es + => WMWithProperty wm Person => WMWithProperty wm Enclosing => ThingLike wm t => t diff --git a/yaifl/src/Yaifl/Model/Kinds/Room.hs b/yaifl/src/Yaifl/Model/Kinds/Room.hs index ab79773..48a40c9 100644 --- a/yaifl/src/Yaifl/Model/Kinds/Room.hs +++ b/yaifl/src/Yaifl/Model/Kinds/Room.hs @@ -117,13 +117,7 @@ instance Taggable (Room wm) RoomTag tagRoom :: Room wm -> TaggedEntity RoomTag -tagRoom r = tag r (r ^. #objectId) - -instance (TaggedAs (Room wm) RoomTag) where - toTag = tagRoom - -instance (TaggedAs (Room wm) EnclosingTag) where - toTag = coerceTag . tagRoom +tagRoom r = tagEntity r (r ^. #objectId) instance IsObject (Room wm) where isThing = const False diff --git a/yaifl/src/Yaifl/Model/Kinds/Supporter.hs b/yaifl/src/Yaifl/Model/Kinds/Supporter.hs index 96625ec..53fdc6d 100644 --- a/yaifl/src/Yaifl/Model/Kinds/Supporter.hs +++ b/yaifl/src/Yaifl/Model/Kinds/Supporter.hs @@ -56,5 +56,7 @@ onThe = coerceTag instance Taggable Supporter SupporterTag instance Taggable (TaggedEntity SupporterTag) EnclosingTag +instance IsEnclosing SupporterEntity + makeFieldLabelsNoPrefix ''Supporter makeSpecificsWithout [] ''Supporter \ No newline at end of file diff --git a/yaifl/src/Yaifl/Model/Kinds/Thing.hs b/yaifl/src/Yaifl/Model/Kinds/Thing.hs index 490afff..2527ec3 100644 --- a/yaifl/src/Yaifl/Model/Kinds/Thing.hs +++ b/yaifl/src/Yaifl/Model/Kinds/Thing.hs @@ -8,9 +8,8 @@ module Yaifl.Model.Kinds.Thing , blankThingData , Thing(..) - , tagThing + , tagThingEntity , EnclosingThing - , TaggedPerson , defaultPlayerID , thingIsLit , thingIsWorn @@ -100,15 +99,11 @@ type EnclosingThing wm = TaggedObject (Thing wm) EnclosingTag instance Taggable (Thing wm) ThingTag -type TaggedPerson wm = TaggedObject (Thing wm) PersonTag -instance TaggedAs (TaggedPerson wm) EnclosingTag where - toTag = coerceTag @_ @EnclosingTag . fst . unTagObject - -- | Tag a thing entity. -tagThing :: +tagThingEntity :: Thing wm -> TaggedEntity ThingTag -tagThing r = tag r (r ^. #objectId) +tagThingEntity r = tagEntity r (r ^. #objectId) instance IsObject (Thing wm) where isThing = const True diff --git a/yaifl/src/Yaifl/Model/ObjectLike.hs b/yaifl/src/Yaifl/Model/ObjectLike.hs index b787f3f..51ff76c 100644 --- a/yaifl/src/Yaifl/Model/ObjectLike.hs +++ b/yaifl/src/Yaifl/Model/ObjectLike.hs @@ -1,6 +1,6 @@ {-| Module : Yaifl.Model.Objects.ObjectLike -Copyright : (c) Avery 2022-2023 +Copyright : (c) Avery 2022-2024 License : MIT Maintainer : ppkfs@outlook.com @@ -40,13 +40,13 @@ class HasID o => ThingLike wm o where class HasID o => RoomLike wm o where getRoom :: (HasCallStack, NoMissingRead wm es) => o -> Eff es (Room wm) -instance (ObjectLike wm o) => ObjectLike wm (TaggedObject o tag) where +instance (ObjectLike wm o) => ObjectLike wm (TaggedObject o tagEntity) where getObject = getObject . unTagObject -instance (RoomLike wm o) => RoomLike wm (TaggedObject o tag) where +instance (RoomLike wm o) => RoomLike wm (TaggedObject o tagEntity) where getRoom = getRoom . snd . unTagObject -instance (ThingLike wm o) => ThingLike wm (TaggedObject o tag) where +instance (ThingLike wm o) => ThingLike wm (TaggedObject o tagEntity) where getThing = getThing . snd . unTagObject instance ObjectLike wm (Thing wm) where @@ -68,7 +68,7 @@ instance ObjectLike wm (TaggedEntity anyTag) where getObject e = getObject (unTag e) instance ThingLike wm DoorEntity where - getThing = getThing . (toTag @_ @ThingTag) + getThing = getThing . coerceTag @_ @ThingTag instance ObjectLike wm Entity where getObject e = if isThing (getID e) diff --git a/yaifl/src/Yaifl/Model/Query.hs b/yaifl/src/Yaifl/Model/Query.hs index 0c6fe35..06abca7 100644 --- a/yaifl/src/Yaifl/Model/Query.hs +++ b/yaifl/src/Yaifl/Model/Query.hs @@ -34,12 +34,12 @@ module Yaifl.Model.Query , defaultPropertySetter , modifyProperty , getEnclosingMaybe - , getEnclosing , setEnclosing - , EnclosingObject(..) + , IsEnclosingObject(..) + , IsEnclosing(..) + , getEnclosingObject , getPlayer' , getDescribableContents - , getEnclosingObject , enclosingContains , getAllObjectsInEnclosing , getCommonAncestor @@ -76,8 +76,8 @@ import Data.Bitraversable class Refreshable wm av where refresh :: forall es. (NoMissingObjects wm es) => av -> Eff es av -instance {-# OVERLAPPING #-} Refreshable wm o => Refreshable wm (TaggedObject o tag) where - refresh (TaggedObject (i, o)) = TaggedObject . (i, ) <$> refresh o +instance {-# OVERLAPPING #-} (HasID o, Refreshable wm o) => Refreshable wm (TaggedObject o tagEntity) where + refresh obj = tagObject obj <$> refresh (getTaggedObject obj) instance (Refreshable wm a, Refreshable wm b) => Refreshable wm (a, b) where refresh (a, b) = refresh a >>= \a' -> refresh b >>= return . (a', ) @@ -97,7 +97,7 @@ instance Refreshable wm Int where refresh = pure instance Refreshable wm (Thing wm) where - refresh t = getThing (tagThing t) + refresh t = getThing (tagThingEntity t) instance Refreshable wm (AnyObject wm) where refresh t = getObject (getID t) @@ -227,7 +227,7 @@ refreshThing tl = do r <- getThing tl ifM (traceGuard Medium) (do - r'' <- getThing (tagThing r) + r'' <- getThing (tagThingEntity r) when ((r'' ^. #modifiedTime) /= (r ^. #modifiedTime)) $ noteRuntimeError (const ()) $ "Refreshed thing with ID" <> show (display $ view #name r) <> " and found an outdated object" return r'') (pure r) @@ -249,8 +249,8 @@ unwrapAny :: AnyObject wm -> Either (TaggedEntity ThingTag) (TaggedEntity RoomTag) unwrapAny a = case (preview _Thing a, preview _Room a) of - (Just x, _) -> Left (tag x (a ^. #objectId)) - (_, Just x) -> Right (tag x (a ^. #objectId)) + (Just x, _) -> Left (tagEntity x (a ^. #objectId)) + (_, Just x) -> Right (tagEntity x (a ^. #objectId)) _ -> error "impossible" data IncludeScenery = IncludeScenery | ExcludeScenery @@ -276,15 +276,15 @@ getAllObjectsInEnclosing :: -> EnclosingEntity -> Eff es [Thing wm] getAllObjectsInEnclosing incScenery incDoors r = do - (_, enc) <- getEnclosingObject r - - let allItemIDs = ES.toList $ enc ^. #contents + e <- getEnclosingObject r + let e' = getEnclosing e + let allItemIDs = ES.toList $ e' ^. #contents things <- mapM getThing allItemIDs -- recurse downwards recursedThings <- mconcat <$> mapM (\t -> do let mbE = getEnclosingMaybe (toAny t) case mbE of - Just enc' -> getAllObjectsInEnclosing incScenery incDoors (tag enc' t) + Just enc' -> getAllObjectsInEnclosing incScenery incDoors (tagEntity enc' t) Nothing -> return []) things enclosingItself <- getThingMaybe r return $ ordNub (maybeToList enclosingItself <> things <> recursedThings) @@ -411,22 +411,37 @@ setEnclosing e v = asThingOrRoom (`defaultPropertySetter` v) (\o -> modifyRoom o (#objectData % #enclosing .~ v)) (toAny @wm e) -getEnclosing :: - WMWithProperty wm Enclosing - => EnclosingEntity - -> AnyObject wm - -> Enclosing -getEnclosing _ = fromMaybe (error "property witness was violated") . getEnclosingMaybe +class IsEnclosingObject o where + getEnclosing :: o -> Enclosing + default getEnclosing :: CanBeAny wm o => WMWithProperty wm Enclosing => o -> Enclosing + getEnclosing = fromMaybe (error "property witness was violated") . getEnclosingMaybe . toAny -getEnclosingObject :: - NoMissingObjects wm es - => WMWithProperty wm Enclosing - => EnclosingEntity - -> Eff es (AnyObject wm, Enclosing) -getEnclosingObject e = do - o <- getObject e - let enc = getEnclosing e o - pure (o, enc) +class IsEnclosing o where + getEnclosingEntity :: o -> EnclosingEntity + default getEnclosingEntity :: HasID o => o -> EnclosingEntity + getEnclosingEntity = unsafeTagEntity . getID + +instance IsEnclosing RoomEntity where + getEnclosingEntity = coerceTag + +instance IsEnclosing EnclosingEntity where + getEnclosingEntity = id + +instance WMWithProperty wm Enclosing => IsEnclosingObject (TaggedObject (AnyObject wm) EnclosingTag) where + getEnclosing = fromMaybe (error "property witness was violated") . getEnclosingMaybe . getTaggedObject + +instance WMWithProperty wm Enclosing => IsEnclosingObject (TaggedObject (Thing wm) EnclosingTag) where + getEnclosing = fromMaybe (error "property witness was violated") . getEnclosingMaybe . toAny . getTaggedObject + +instance IsEnclosingObject (Room wm) where + getEnclosing = view (#objectData % #enclosing) + +getEnclosingObject :: (IsEnclosing o, HasCallStack, NoMissingRead wm es) => o -> Eff es (TaggedAnyEnclosing wm) +getEnclosingObject theObj = do + let e = getEnclosingEntity theObj + o <- getObject e + let taggedObj = tagObject e o + pure $ taggedObj getPlayer' :: NoMissingObjects wm es @@ -484,20 +499,3 @@ getCommonAncestor t1' t2' = do makeItScenery :: Eff '[State (Thing wm)] () makeItScenery = (#objectData % #isScenery .= True) - --- My hope is that this can vanish at some point but enclosing is the weird one --- we want this class because we want an easier way of doing `propertyAT` for enclosing -class EnclosingObject o where - enclosingL :: Getter o Enclosing - -instance EnclosingObject (Room wm) where - enclosingL = castOptic $ #objectData % #enclosing - -instance WMWithProperty wm Enclosing => EnclosingObject (AnyObject wm, Enclosing) where - enclosingL = to (\o -> getEnclosing @wm (toTag o) ( fst o)) - -instance (TaggedAs (TaggedObject (Thing wm) tag) EnclosingTag, WMWithProperty wm Enclosing) => EnclosingObject (TaggedObject (Thing wm) tag) where - enclosingL = to (\o -> getEnclosing @wm (toTag o) (toAny . snd . unTagObject $ o)) - -instance WMWithProperty wm Enclosing => EnclosingObject (TaggedAnyEnclosing wm) where - enclosingL = to (\(TaggedObject (e, o)) -> getEnclosing e o) \ No newline at end of file diff --git a/yaifl/src/Yaifl/Model/Tag.hs b/yaifl/src/Yaifl/Model/Tag.hs index cd0ee6c..594379d 100644 --- a/yaifl/src/Yaifl/Model/Tag.hs +++ b/yaifl/src/Yaifl/Model/Tag.hs @@ -1,96 +1,84 @@ {-| Module : Yaifl.Model.Objects.Tag -Copyright : (c) Avery 2023 +Copyright : (c) Avery 2023-2024 License : MIT Maintainer : ppkfs@outlook.com -Machinery to tag entities given a witness such that we can safely avoid Maybe when +Machinery to tagEntity entities given a witness such that we can safely avoid Maybe when doing queries. For example, we can require that the object reference of the object that contains something is an object with an enclosing property. -} module Yaifl.Model.Tag ( -- * Tagging things Taggable(..) - , TaggedAs(..) , coerceTag -- ** Tagging - , TaggedObject(..) + , TaggedObject + , unTagObject , unsafeTagObject , getTaggedObject + , getTag , tagObject ) where import Yaifl.Prelude import Yaifl.Model.Entity -{- -A tagged entity can do getX -which means a tagged object can also do getX - --} -- | A tagged object is a tuple of a tagged entity, and the object itself -newtype TaggedObject o tag = TaggedObject { unTagObject :: (TaggedEntity tag, o) } +newtype TaggedObject o tagEntity = TaggedObject { unTagObject :: (TaggedEntity tagEntity, o) } deriving stock (Generic) -instance HasID (TaggedObject o tag) where +instance HasID (TaggedObject o tagEntity) where getID = getID . fst . unTagObject --- | Unsafely tag an object when we know it's sensible. +-- | Unsafely tagEntity an object when we know it's sensible. unsafeTagObject :: HasID o => o - -> TaggedObject o tag + -> TaggedObject o tagEntity unsafeTagObject o = TaggedObject (unsafeTagEntity $ getID o, o) -instance TaggedAs (TaggedObject o tag) tag where - toTag = fst . unTagObject - -- | An entity @e@ can be tagged as a `TaggedEntity` @taggableTo@ (a phantom type) -- given a witness of type @taggableWith@. class Taggable taggableWith taggableTo where - tag :: HasID e => taggableWith -> e -> TaggedEntity taggableTo - default tag :: HasID e => taggableWith -> e -> TaggedEntity taggableTo - tag _ = unsafeTagEntity . getID + tagEntity :: HasID e => taggableWith -> e -> TaggedEntity taggableTo + default tagEntity :: HasID e => taggableWith -> e -> TaggedEntity taggableTo + tagEntity _ = unsafeTagEntity . getID --- you can always tag something as itself +-- you can always tagEntity something as itself instance Taggable (TaggedEntity a) a +instance Taggable DoorEntity ThingTag + +instance Taggable (TaggedObject o tag) tag getTaggedObject :: - TaggedObject o tag + TaggedObject o tagEntity -> o getTaggedObject = snd . unTagObject +getTag :: + TaggedObject o tagEntity + -> TaggedEntity tagEntity +getTag = fst . unTagObject + tagObject :: Taggable tagWith taggableTo => HasID e => tagWith -> e -> TaggedObject e taggableTo -tagObject ev e = TaggedObject (tag ev e, e) +tagObject ev e = TaggedObject (tagEntity ev e, e) --- | An @a@ that is already tagged does not need a witness. -class TaggedAs a taggedAs where - toTag :: a -> TaggedEntity taggedAs - -instance TaggedAs (TaggedEntity a) a where - toTag = id - --- | Weakening the tag on a room to an enclosing +-- | Weakening the tagEntity on a room to an enclosing instance Taggable (TaggedEntity RoomTag) EnclosingTag where - tag = const . coerce - -instance TaggedAs (TaggedEntity RoomTag) EnclosingTag where - toTag = coerce - -instance TaggedAs (TaggedEntity DoorTag) ThingTag where - toTag = coerce + tagEntity = const . coerce instance Taggable (TaggedEntity PersonTag) EnclosingTag --- | If we can tag a `TaggedEntity a` as a @b@, we can just coerce the entity +-- | If we can tagEntity a `TaggedEntity a` as a @b@, we can just coerce the entity -- rather than passing it twice. coerceTag :: Taggable (TaggedEntity a) b => TaggedEntity a -> TaggedEntity b -coerceTag a = tag a (unTag a) \ No newline at end of file +coerceTag a = tagEntity a (unTag a) \ No newline at end of file diff --git a/yaifl/test/Yaifl/Test/Chapter3/Laura.hs b/yaifl/test/Yaifl/Test/Chapter3/Laura.hs index 276b446..59e1c1f 100644 --- a/yaifl/test/Yaifl/Test/Chapter3/Laura.hs +++ b/yaifl/test/Yaifl/Test/Chapter3/Laura.hs @@ -17,8 +17,6 @@ import Yaifl.Model.Query import Yaifl.Model.Effects (traverseRooms) import Yaifl.Model.Tag import Yaifl.Model.Kinds.Room -import qualified Data.List.NonEmpty as NE -import Yaifl.Model.Kinds (isNowCarriedBy) import Yaifl.Model.Kinds.Person ex19 :: (Text, [Text], Game PlainWorldModel ())