From a124b947301c0bd074577c178a81d59c1a4d65e1 Mon Sep 17 00:00:00 2001 From: Avery Date: Sat, 18 Nov 2023 16:19:29 +0100 Subject: [PATCH] Do a lot of fiddling to make stuff less depending on Eff es --- src/Yaifl.hs | 10 +- src/Yaifl/Actions/Going.hs | 13 +-- src/Yaifl/Actions/Looking/Visibility.hs | 90 ++++++++--------- .../ChoosingNotableLocaleObjects.hs | 8 +- .../PrintingTheLocaleDescription.hs | 6 +- src/Yaifl/Model/Object.hs | 6 +- src/Yaifl/Model/ObjectSpecifics.hs | 45 ++++----- src/Yaifl/Model/Objects/Create.hs | 31 +++--- src/Yaifl/Model/Objects/Move.hs | 32 +++--- src/Yaifl/Model/Objects/Query.hs | 39 +++----- src/Yaifl/Model/Objects/RoomConnections.hs | 32 +++--- src/Yaifl/Model/Properties/Container.hs | 3 +- src/Yaifl/Model/Properties/Door.hs | 31 +++--- src/Yaifl/Model/Properties/Has.hs | 26 ++--- src/Yaifl/Model/Properties/Openable.hs | 3 +- src/Yaifl/Model/Properties/Query.hs | 97 +++++++++---------- src/Yaifl/Model/Properties/TH.hs | 6 +- src/Yaifl/Rules/WhenPlayBegins.hs | 10 +- test/Yaifl/Test/Chapter3/Common.hs | 2 + test/Yaifl/Test/Chapter3/StarryVoid.hs | 37 ++++--- 20 files changed, 264 insertions(+), 263 deletions(-) diff --git a/src/Yaifl.hs b/src/Yaifl.hs index 53938bd..58766a0 100644 --- a/src/Yaifl.hs +++ b/src/Yaifl.hs @@ -68,13 +68,13 @@ type PlainWorldModel = 'WorldModel ObjectSpecifics Direction () () ActivityColle -- toTextDir = toTextDir type HasStandardProperties s = ( - WMHasProperty s Enclosing - , WMHasProperty s Container - , WMHasProperty s Enterable - , WMHasProperty s Openable + WMWithProperty s Enclosing + , WMWithProperty s Container + , WMWithProperty s Enterable + , WMWithProperty s Openable , HasLookingProperties s , WMStdDirections s - , WMHasProperty s DoorSpecifics + , WMWithProperty s DoorSpecifics , HasDirectionalTerms s , Pointed (WMObjSpecifics s) ) diff --git a/src/Yaifl/Actions/Going.hs b/src/Yaifl/Actions/Going.hs index a0fd206..b4cf7d9 100644 --- a/src/Yaifl/Actions/Going.hs +++ b/src/Yaifl/Actions/Going.hs @@ -45,7 +45,7 @@ data GoingActionVariables wm = GoingActionVariables } deriving stock ( Generic ) goingAction :: - (WMStdDirections wm, WMHasProperty wm DoorSpecifics, WMHasProperty wm Enclosing) + (WMStdDirections wm, WMWithProperty wm DoorSpecifics, WMWithProperty wm Enclosing) => WithPrintingNameOfSomething wm => Action wm (GoingActionVariables wm) goingAction = Action @@ -69,7 +69,7 @@ describeRoomGoneInto = makeRule "describe room gone into rule" [] $ \a -> ifM (error "other actors cant report going yet") -carryOutGoingRules :: WMHasProperty wm Enclosing => ActionRulebook wm (GoingActionVariables wm) +carryOutGoingRules :: WMWithProperty wm Enclosing => ActionRulebook wm (GoingActionVariables wm) carryOutGoingRules = makeActionRulebook "carry out going rulebook" [ movePlayerAndVehicle , moveFloatingObjects @@ -82,7 +82,7 @@ checkLightInNewLocation = notImplementedRule "check light in new location rule" moveFloatingObjects :: Rule wm (Args wm (GoingActionVariables wm)) Bool moveFloatingObjects = notImplementedRule "move floating objects rule" -movePlayerAndVehicle :: WMHasProperty wm Enclosing => Rule wm (Args wm (GoingActionVariables wm)) Bool +movePlayerAndVehicle :: WMWithProperty wm Enclosing => Rule wm (Args wm (GoingActionVariables wm)) Bool movePlayerAndVehicle = makeRule "move player and vehicle rule" [] $ \a@Args{variables=v} -> do moveSuccessful <- case vehicleGoneBy v of Nothing -> move (source a) (roomGoneTo v) @@ -91,7 +91,7 @@ movePlayerAndVehicle = makeRule "move player and vehicle rule" [] $ \a@Args{vari goingActionSet :: forall wm es. - (ParseArgumentEffects wm es, WMStdDirections wm, WMHasProperty wm DoorSpecifics) + (ParseArgumentEffects wm es, WMStdDirections wm, WMWithProperty wm DoorSpecifics) => WithPrintingNameOfSomething wm => UnverifiedArgs wm -> Eff es (ArgumentParseResult (GoingActionVariables wm)) @@ -124,8 +124,9 @@ goingActionSet (UnverifiedArgs Args{..}) = do NoParameter -> do mbThrough <- getMatchingThing "through" -- TODO: this should be a door or complain - mbDoor <- join <$> traverse getDoorSpecificsMaybe mbThrough - pure $ backSide <$> mbDoor + --mbDoor <- join <$> traverse getDoorSpecificsMaybe mbThrough + --pure $ backSide <$> mbDoor + error "aaaaa door" ConstantParameter t -> error $ "got a " <> t mbRoomGoneTo <- join <$> traverse getRoomMaybe target addAnnotation $ "target was " <> show target diff --git a/src/Yaifl/Actions/Looking/Visibility.hs b/src/Yaifl/Actions/Looking/Visibility.hs index d4aa479..61f49a8 100644 --- a/src/Yaifl/Actions/Looking/Visibility.hs +++ b/src/Yaifl/Actions/Looking/Visibility.hs @@ -6,7 +6,6 @@ import Solitude import Breadcrumbs ( addAnnotation ) import Yaifl.Activities.Activity (WithPrintingNameOfADarkRoom, WithPrintingDescriptionOfADarkRoom) -import Yaifl.Model.Entity import Yaifl.Model.Object import Yaifl.Model.Objects.Query import Yaifl.Model.Objects.RoomData @@ -28,7 +27,7 @@ import Yaifl.Model.Objects.ObjectLike -- | An easier way to describe the 3 requirements to look. type HasLookingProperties wm = - (WMHasProperty wm Enclosing, WMHasProperty wm Enterable, WMHasProperty wm Container + (WMWithProperty wm Enclosing, WMWithProperty wm Enterable, WMWithProperty wm Container , Display (WMSayable wm) , IsString (WMSayable wm) , WithPrintingNameOfADarkRoom wm @@ -78,13 +77,10 @@ getVisibilityLevels e = do findVisibilityHolder :: NoMissingObjects wm es => HasLookingProperties wm - => CanBeAny wm o - => ObjectLike wm o - => o + => AnyObject wm -> Eff es (AnyObject wm) -findVisibilityHolder e' = do - obj <- getObject e' - mCont <- getContainerMaybe e' +findVisibilityHolder obj = do + let mCont = getContainerMaybe obj let n = obj ^. #name case (tagObject obj, isOpaqueClosedContainer <$?> mCont) of -- a nonopaque or open container thing @@ -94,8 +90,7 @@ findVisibilityHolder e' = do _ -> do addAnnotation $ "The visibility holder of " <> display n <> " is itself" --return it - return (toAny e') - + return obj -- Inform Designer's Manual, Page 146 -- we recalculate the light of the immediate holder of an object @@ -106,23 +101,21 @@ findVisibilityHolder e' = do recalculateLightOfParent :: NoMissingObjects wm es => HasLookingProperties wm - => ObjectLike wm o + => CanBeAny wm o => o -> Eff es Int -recalculateLightOfParent e = do - (parent :: Maybe EnclosingEntity) <- view (#objectData % #containedBy) <$$> getThingMaybe e - case parent of - --it's a room. - Nothing -> return 0 - Just p -> do - ol <- offersLight p - if - ol - then - (1+) <$> recalculateLightOfParent p - else - return 0 - +recalculateLightOfParent = asThingOrRoom + (\t -> do + parent <- getObject (t ^. #objectData % #containedBy) + ol <- offersLight parent + if + ol + then + (1+) <$> recalculateLightOfParent parent + else + return 0 + ) + (const $ return 0) . toAny -- | An object offers light if: -- - it is a lit thing (lit thing or lighted room) @@ -132,17 +125,16 @@ recalculateLightOfParent e = do offersLight :: NoMissingObjects wm es => HasLookingProperties wm - => ObjectLike wm o - => o + => AnyObject wm -> Eff es Bool -offersLight e = do - let parentOffersLight o = offersLight (o ^. #objectData % #containedBy) +offersLight obj = do + let parentOffersLight o = getObject (o ^. #objectData % #containedBy) >>= offersLight seeThruWithParent = maybe (return False) (\o' -> isSeeThrough o' &&^ parentOffersLight o') - o <- getThingMaybe e + t <- getThingMaybe obj - objectItselfHasLight e -- it is a lit thing (lit thing or lighted room) - ||^ seeThruWithParent o -- - it is see-through and its parent offers light - ||^ containsLitObj e -- - it contains a thing that has light + pure (objectItselfHasLight obj) -- it is a lit thing (lit thing or lighted room) + ||^ seeThruWithParent t -- - it is see-through thing and its parent offers light + ||^ containsLitObj obj -- - it contains a thing that has light -- | an object is see through if... isSeeThrough :: @@ -151,7 +143,9 @@ isSeeThrough :: => Thing wm -> Eff es Bool isSeeThrough e = do - (c, en, s) <- (,,) <$> getContainerMaybe e <*> getEnterableMaybe e <*> isSupporter e + let c = getContainerMaybe e + en = getEnterableMaybe e + s <- isSupporter e isContainer <- isType e "container" let isOpenContainer = fmap _containerOpenable c == Just Open && isContainer isTransparent = fmap _containerOpacity c == Just Transparent @@ -164,12 +158,11 @@ isSeeThrough e = do containsLitObj :: NoMissingObjects wm es => HasLookingProperties wm - => ObjectLike wm o - => o -- ^ the object + => AnyObject wm -- ^ the object -> Eff es Bool -containsLitObj e = do - enc <- getEnclosing e - enc & maybe (return False) (\encs -> anyM hasLight (DES.elems $ contents encs)) +containsLitObj obj = do + let enc = getEnclosingMaybe obj + enc & maybe (return False) (\encs -> anyM (getObject >=> hasLight) (DES.elems $ contents encs)) {- | (4) An object itself has light if: (a) it's a room with the lighted property, @@ -177,11 +170,9 @@ containsLitObj e = do If you want to include transitive light, you want `hasLight`. -} objectItselfHasLight :: - NoMissingObjects wm es - => ObjectLike wm o - => o -- ^ the object - -> Eff es Bool -objectItselfHasLight e = asThingOrRoom e + AnyObject wm -- ^ the object + -> Bool +objectItselfHasLight = asThingOrRoom ((Lit ==) . view (#objectData % #lit)) ((Lighted ==) . view (#objectData % #darkness)) @@ -195,11 +186,10 @@ objectItselfHasLight e = asThingOrRoom e hasLight :: NoMissingObjects wm es => HasLookingProperties wm - => ObjectLike wm o - => o + => AnyObject wm -> Eff es Bool -hasLight e = do - ts <- getThingMaybe e - objectItselfHasLight e +hasLight obj = do + ts <- getThingMaybe obj + pure (objectItselfHasLight obj) ||^ (maybe (return False) isSeeThrough ts - &&^ containsLitObj e) \ No newline at end of file + &&^ containsLitObj obj) \ No newline at end of file diff --git a/src/Yaifl/Activities/ChoosingNotableLocaleObjects.hs b/src/Yaifl/Activities/ChoosingNotableLocaleObjects.hs index 6e4e10e..071c9c1 100644 --- a/src/Yaifl/Activities/ChoosingNotableLocaleObjects.hs +++ b/src/Yaifl/Activities/ChoosingNotableLocaleObjects.hs @@ -10,8 +10,8 @@ import Yaifl.Model.Entity ( Store(..), HasID(..) ) import Yaifl.Model.Object( Object(..), AnyObject ) import Yaifl.Model.Objects.Query ( getObject ) import Yaifl.Model.Properties.Enclosing ( Enclosing(..) ) -import Yaifl.Model.Properties.Has ( WMHasProperty ) -import Yaifl.Model.Properties.Query ( getEnclosing ) +import Yaifl.Model.Properties.Has ( WMWithProperty ) +import Yaifl.Model.Properties.Query ( getEnclosingMaybe ) import Yaifl.Rules.Rule (makeRule) import qualified Data.EnumMap as DEM import qualified Data.EnumSet as DES @@ -21,11 +21,11 @@ import Yaifl.Actions.Looking.Locale type WithChoosingNotableLocaleObjects wm = (WithActivity "choosingNotableLocaleObjects" wm (AnyObject wm) (LocalePriorities wm)) choosingNotableLocaleObjectsImpl :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => Activity wm (AnyObject wm) (LocalePriorities wm) choosingNotableLocaleObjectsImpl = makeActivity "Choosing notable locale objects" [makeRule "" [] (\v -> do - e' <- getEnclosing v + let e' = getEnclosingMaybe v case e' of Nothing -> (do addAnnotation $ "Tried to choose notable locale objects from " <> display (v ^. #name) <> " which doesn't enclose." diff --git a/src/Yaifl/Activities/PrintingTheLocaleDescription.hs b/src/Yaifl/Activities/PrintingTheLocaleDescription.hs index 5eedd5e..f12537a 100644 --- a/src/Yaifl/Activities/PrintingTheLocaleDescription.hs +++ b/src/Yaifl/Activities/PrintingTheLocaleDescription.hs @@ -193,9 +193,9 @@ alsoSee = Rule "You can also see" [] (\v -> -- has a common parent and therefore we are listing the contents -- of something. this will happen unless the author -- manually adds some notable object that isn't present in the room - allHolders <- sequence $ DEM.foldl' (\xs li -> flip cons xs $ asThingOrRoom (localeObject li) - (\t -> Just $ t ^. #objectData % #containedBy) - (const Nothing)) [] lp + let allHolders = DEM.foldl' (\xs li -> flip cons xs $ asThingOrRoom + (\t -> Just $ t ^. #objectData % #containedBy) + (const Nothing) (localeObject li)) [] lp case allHolders of -- no items [] -> error "impossible - no items found?" diff --git a/src/Yaifl/Model/Object.hs b/src/Yaifl/Model/Object.hs index f61cffa..017afe2 100644 --- a/src/Yaifl/Model/Object.hs +++ b/src/Yaifl/Model/Object.hs @@ -15,6 +15,7 @@ is an object. Namely, there's no need for e.g. directions to be objects. {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FunctionalDependencies #-} module Yaifl.Model.Object ( -- * Objects @@ -129,8 +130,6 @@ newtype Room wm = Room (Object wm (RoomData wm) (WMObjSpecifics wm)) newtype AnyObject wm = AnyObject (Object wm (Either ThingData (RoomData wm)) (WMObjSpecifics wm)) deriving newtype (Eq, Ord, Generic) - - instance HasField x (Object wm ThingData (WMObjSpecifics wm)) a => HasField x (Thing wm) a where getField (Thing o) = getField @x o @@ -166,6 +165,7 @@ instance HasID (Room wm) where makeFieldLabelsNoPrefix ''Object +instance Taggable (Room wm) EnclosingTag instance Taggable (Room wm) RoomTag instance Taggable (Thing wm) ThingTag @@ -200,7 +200,7 @@ _Thing :: Prism' (AnyObject wm) (Thing wm) _Thing = prism' (AnyObject . first Left . coerce) (fmap Thing . bitraverse leftToMaybe Just . (\(AnyObject a) -> a)) -- | A slightly more descriptive prism for objects specifically. -class CanBeAny wm o where +class CanBeAny wm o | o -> wm where toAny :: o -> AnyObject wm fromAny :: AnyObject wm -> Maybe o diff --git a/src/Yaifl/Model/ObjectSpecifics.hs b/src/Yaifl/Model/ObjectSpecifics.hs index d2a4edd..3aa62a7 100644 --- a/src/Yaifl/Model/ObjectSpecifics.hs +++ b/src/Yaifl/Model/ObjectSpecifics.hs @@ -9,20 +9,20 @@ module Yaifl.Model.ObjectSpecifics import Solitude -import Yaifl.Metadata (previousRoom, ObjectType(..)) +import Yaifl.Metadata ( ObjectType(..) ) import Yaifl.Model.Object import Yaifl.Model.Objects.Create import Yaifl.Model.Objects.ThingData import Yaifl.Model.Properties.Enclosing ( Enclosing ) -import Yaifl.Model.Properties.Has ( HasProperty(..), WMHasProperty ) +import Yaifl.Model.Properties.Has ( MayHaveProperty(..), WMWithProperty ) import Yaifl.Model.WorldModel ( WMObjSpecifics, WorldModel(..), WMSayable, WMDirection ) import Yaifl.Model.Properties.Container import Yaifl.Model.Properties.Door import Yaifl.Model.Properties.Openable ( Openable ) import Yaifl.Model.Objects.Effects -import Yaifl.Model.Objects.RoomData import Yaifl.Model.Entity import Yaifl.Model.Objects.RoomConnections +import Yaifl.Model.Direction (WMStdDirections) data ObjectSpecifics = NoSpecifics @@ -43,20 +43,20 @@ class WMHasObjSpecifics (wm :: WorldModel) where instance WMHasObjSpecifics ('WorldModel ObjectSpecifics a b c ac r se) where inj _ = id -instance HasProperty ObjectSpecifics Enclosing where - propertyL = _EnclosingSpecifics `thenATraverse` (_ContainerSpecifics % containerEnclosing) +instance MayHaveProperty ObjectSpecifics Enclosing where + propertyAT = _EnclosingSpecifics `thenATraverse` (_ContainerSpecifics % containerEnclosing) -instance HasProperty ObjectSpecifics Container where - propertyL = castOptic _ContainerSpecifics +instance MayHaveProperty ObjectSpecifics Container where + propertyAT = castOptic _ContainerSpecifics -instance HasProperty ObjectSpecifics Enterable where - propertyL = _ContainerSpecifics % containerEnterable +instance MayHaveProperty ObjectSpecifics Enterable where + propertyAT = _ContainerSpecifics % containerEnterable -instance HasProperty ObjectSpecifics Openable where - propertyL = _OpenableSpecifics `thenATraverse` (_ContainerSpecifics % containerOpenable) +instance MayHaveProperty ObjectSpecifics Openable where + propertyAT = _OpenableSpecifics `thenATraverse` (_ContainerSpecifics % containerOpenable) -instance HasProperty ObjectSpecifics DoorSpecifics where - propertyL = castOptic _DoorSpecifics +instance MayHaveProperty ObjectSpecifics DoorSpecifics where + propertyAT = castOptic _DoorSpecifics localST :: State st :> es @@ -75,21 +75,22 @@ localST f l = do -- it isn't portable on creation, and then the check will be whenever we modify an object -- make sure that it isn't breaking an invariant. addDoor :: - forall wm es. WMHasObjSpecifics wm - => WMHasProperty wm Enclosing + forall wm es. + WMHasObjSpecifics wm + => WMWithProperty wm Enclosing + => WMStdDirections wm + => NoMissingObjects wm es => AddObjects wm es => WMSayable wm -- ^ name -> Maybe (WMSayable wm) -- ^ description - -> Room wm - -> WMDirection wm - -> Room wm - -> WMDirection wm + -> (Room wm, WMDirection wm) + -> (Room wm, WMDirection wm) -> Maybe ThingData -- ^ Optional details; if 'Nothing' then the default is used. -> Eff es (Thing wm) -addDoor n mbDes fr frDir ba baDir mbD = do - let ds = blankDoorSpecifics (tagRoom fr) (tagRoom ba) +addDoor n mbDes f b mbD = do + let ds = blankDoorSpecifics (tagRoom (fst f)) (tagRoom (fst b)) d <- addThingInternal n (fromMaybe "" mbDes) (ObjectType "door") (Just $ inj (Proxy @wm) $ DoorSpecifics ds) (Just $ (\x -> x & #portable .~ FixedInPlace & #pushableBetweenRooms .~ False) $ fromMaybe blankThingData mbD) - addDoorToConnection (tag ds d) fr ba + addDoorToConnection (tag @DoorSpecifics @DoorTag ds d) f b pure d \ No newline at end of file diff --git a/src/Yaifl/Model/Objects/Create.hs b/src/Yaifl/Model/Objects/Create.hs index 8e57dd7..0c5b531 100644 --- a/src/Yaifl/Model/Objects/Create.hs +++ b/src/Yaifl/Model/Objects/Create.hs @@ -23,9 +23,10 @@ import Yaifl.Model.Objects.Query import Yaifl.Model.Objects.RoomData ( RoomData, blankRoomData ) import Yaifl.Model.Objects.ThingData import Yaifl.Model.Properties.Enclosing ( Enclosing ) -import Yaifl.Model.Properties.Has ( WMHasProperty ) +import Yaifl.Model.Properties.Has ( WMWithProperty ) import Yaifl.Model.WorldModel ( WMObjSpecifics, WMSayable ) import Yaifl.Model.Objects.Effects +import Yaifl.Model.Objects.ObjectLike makeObject :: Pointed s @@ -45,7 +46,7 @@ makeObject n d ty isT specifics details = do addObject :: Pointed s - => WMHasProperty wm Enclosing + => WMWithProperty wm Enclosing => AddObjects wm es => (Object wm d s -> Eff es ()) -> WMSayable wm -- ^ Name. @@ -61,17 +62,21 @@ addObject updWorld n d ty isT specifics details = addAnnotation "object created" updWorld obj addAnnotation "object added to world" - lastRoom <- use #previousRoom + lastRoomE <- use #previousRoom tickGlobalTime - failHorriblyIfMissing $ asThingOrRoomM e - (\t -> do + + failHorriblyIfMissing $ do + obj' <- getObject e + lastRoom <- getRoom lastRoomE + asThingOrRoom + (\t -> do withoutSpan $ when (t ^. #objectData % #containedBy == coerceTag voidID) (move t lastRoom >> pass)) - (\r -> #previousRoom .= tagRoom r) + (\r -> #previousRoom .= tagRoom r) obj' pure obj addThingInternal :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => WMSayable wm -- ^ Name. -> WMSayable wm -- ^ Description. @@ -84,7 +89,7 @@ addThingInternal name desc objtype specifics details = True specifics (fromMaybe blankThingData details) addThing' :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => WMSayable wm -- ^ Name. -> WMSayable wm -- ^ Description. @@ -97,7 +102,7 @@ runLocalState :: a1 -> Eff '[State a1] a2 -> Maybe a1 runLocalState bl upd = Just $ snd $ runPureEff $ runStateLocal bl upd addThing :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => WMSayable wm -- ^ Name. -> WMSayable wm -- ^ Description. @@ -105,7 +110,7 @@ addThing :: addThing n d = addThing' n d pass addRoomInternal :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => WMSayable wm -- ^ Name. -> WMSayable wm -- ^ Description. @@ -120,7 +125,7 @@ addRoomInternal name desc objtype specifics details = do return e addRoom' :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => WMSayable wm -- ^ Name. -> WMSayable wm -- ^ Description. @@ -130,7 +135,7 @@ addRoom' n d rd = addRoomInternal n d (ObjectType "room") Nothing (Just $ snd $ runPureEff $ runStateLocal blankRoomData rd) addRoom :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => WMSayable wm -- ^ Name. -> WMSayable wm -- ^ Description. @@ -138,7 +143,7 @@ addRoom :: addRoom n d = addRoom' n d pass addBaseObjects :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => AddObjects wm es => Eff es () addBaseObjects = do diff --git a/src/Yaifl/Model/Objects/Move.hs b/src/Yaifl/Model/Objects/Move.hs index cc6ee69..072d0c7 100644 --- a/src/Yaifl/Model/Objects/Move.hs +++ b/src/Yaifl/Model/Objects/Move.hs @@ -12,45 +12,43 @@ import Yaifl.Model.Object import Yaifl.Model.Objects.Query import Yaifl.Model.Objects.ThingData import Yaifl.Model.Properties.Enclosing -import Yaifl.Model.Properties.Has (WMHasProperty) +import Yaifl.Model.Properties.Has import Yaifl.Model.Properties.Query import Yaifl.Model.WorldModel import qualified Data.EnumSet as ES import Yaifl.Model.Objects.Effects -import Yaifl.Model.Objects.ObjectLike move :: Breadcrumbs :> es => State Metadata :> es => ObjectQuery wm es => Display (WMSayable wm) - => WMHasProperty wm Enclosing - => ThingLike wm o - => EnclosingLike wm l + => WMWithProperty wm Enclosing + => EnclosingObject l => ObjectLike wm l - => o + => Thing wm -> l -> Eff es Bool -move oObj oLoc = withoutMissingObjects moveBlock moveHandler +move objectToMove oLoc = withoutMissingObjects moveBlock moveHandler where moveBlock = withSpan' "move" ""$ do - o' <- refreshThing oObj - (loc :: Enclosing) <- getAs oLoc - let (c :: EnclosingEntity) = o' ^. #objectData % #containedBy + objectToMove' <- refreshThing objectToMove + let loc :: Enclosing = oLoc ^. enclosingL + let (c :: EnclosingEntity) = objectToMove' ^. #objectData % #containedBy c' <- getObject c oLoc' <- getObject oLoc - (oldLocEnc :: Enclosing) <- getAs c - addTag "object to move" (display $ getID o') + let (oldLocEnc :: Enclosing) = getEnclosing c c' + addTag "object to move" (display $ getID objectToMove') addTag "current location" (display $ getID c') addTag "new location" (display $ getID oLoc') - modifySpan (\s -> s { _spanName = display (o' ^. #name) }) - let (movedObj, oldLocation, newLocation) = moveObjects (tag oldLocEnc (getID oLoc')) o' oldLocEnc loc + modifySpan (\s -> s { _spanName = display (objectToMove' ^. #name) }) + let (movedObj, oldLocation, newLocation) = moveObjects (tag oldLocEnc (getID oLoc')) objectToMove' oldLocEnc loc setThing movedObj - setEnclosing c oldLocation - setEnclosing (getID oLoc) newLocation + setEnclosing c' oldLocation + setEnclosing oLoc' newLocation --at this point we know it's a success return True - moveHandler = handleMissingObject ("Failed to move " <> display (getID oObj) <> " to " <> display (getID oLoc)) False + moveHandler = handleMissingObject ("Failed to move " <> display (getID objectToMove) <> " to " <> display (getID oLoc)) False 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') diff --git a/src/Yaifl/Model/Objects/Query.hs b/src/Yaifl/Model/Objects/Query.hs index b9745ca..7ef6369 100644 --- a/src/Yaifl/Model/Objects/Query.hs +++ b/src/Yaifl/Model/Objects/Query.hs @@ -10,7 +10,6 @@ module Yaifl.Model.Objects.Query , getThingMaybe , getRoomMaybe , asThingOrRoom - , asThingOrRoomM , getLocation -- * Modify , modifyObject @@ -85,28 +84,15 @@ getRoomMaybe :: getRoomMaybe e = withoutMissingObjects (preview _Room <$> getObject (getID e)) (const $ pure Nothing) asThingOrRoom :: - NoMissingObjects wm es - => ObjectLike wm o - => o - -> (Thing wm -> a) + (Thing wm -> a) -> (Room wm -> a) - -> Eff es a -asThingOrRoom o tf rf = do - a <- getObject o - case (preview _Thing a, preview _Room a) of - (Just x, _) -> tf <$> getThing x - (_, Just x) -> rf <$> getRoom x + -> AnyObject wm + -> a +asThingOrRoom tf rf a = case (preview _Thing a, preview _Room a) of + (Just x, _) -> tf x + (_, Just x) -> rf x _ -> error "impossible" -asThingOrRoomM :: - NoMissingObjects wm es - => ObjectLike wm o - => o - -> (Thing wm -> Eff es a) - -> (Room wm -> Eff es a) - -> Eff es a -asThingOrRoomM o tf rf = join $ asThingOrRoom o tf rf - modifyObjectFrom :: State Metadata :> es => (o -> Eff es (Object wm any s)) @@ -127,7 +113,7 @@ modifyThing :: => o -> (Thing wm -> Thing wm) -> Eff es () -modifyThing o u = modifyObjectFrom (fmap (\(Thing a) -> a) . getThing) (setThing . Thing) o ((\(Thing a) -> a) . u . Thing) +modifyThing o u = modifyObjectFrom (fmap coerce refreshThing) (setThing . Thing) o ((\(Thing a) -> a) . u . Thing) modifyRoom :: NoMissingObjects wm es @@ -135,17 +121,16 @@ modifyRoom :: => o -> (Room wm -> Room wm) -> Eff es () -modifyRoom o u = modifyObjectFrom (fmap (\(Room a) -> a) . getRoom) (setRoom . Room) o ((\(Room a) -> a) . u . Room) +modifyRoom o u = modifyObjectFrom (fmap coerce refreshRoom) (setRoom . Room) o ((\(Room a) -> a) . u . Room) modifyObject :: NoMissingObjects wm es - => ObjectLike wm o - => o + => AnyObject wm -> (AnyObject wm -> AnyObject wm) -> Eff es () -modifyObject e s = asThingOrRoomM e +modifyObject e s = asThingOrRoom (`modifyThing` anyModifyToThing s) - (`modifyRoom` anyModifyToRoom s) + (`modifyRoom` anyModifyToRoom s) e anyModifyToThing :: (AnyObject s -> AnyObject s) @@ -165,7 +150,7 @@ getLocation :: getLocation t = do t' <- getThing t o <- getObject (t' ^. #objectData % #containedBy) - join $ asThingOrRoom o getLocation return + asThingOrRoom getLocation return o refreshRoom :: NoMissingObjects wm es diff --git a/src/Yaifl/Model/Objects/RoomConnections.hs b/src/Yaifl/Model/Objects/RoomConnections.hs index e004c16..a6495d1 100644 --- a/src/Yaifl/Model/Objects/RoomConnections.hs +++ b/src/Yaifl/Model/Objects/RoomConnections.hs @@ -20,7 +20,7 @@ import Solitude hiding (Down) import Yaifl.Model.Direction import Yaifl.Model.Entity -import Yaifl.Metadata ( whenConstructing ) +import Yaifl.Metadata ( whenConstructing, noteError ) import Yaifl.Model.Object import Yaifl.Model.Objects.Query import Yaifl.Model.Objects.RoomData @@ -29,8 +29,6 @@ import Yaifl.Model.WorldModel ( WMDirection ) import Breadcrumbs import Data.Text.Display import Yaifl.Model.Objects.Effects -import Yaifl.Model.Properties.Door -import Yaifl.Model.Properties.Has getAllConnections :: Room wm @@ -170,15 +168,27 @@ isBelow :: isBelow = isDownOf addDoorToConnection :: - NoMissingObjects wm es - => WMHasProperty wm DoorSpecifics - => DoorLike wm d - => d + WMStdDirections wm + => NoMissingObjects wm es + => DoorEntity -> (Room wm, WMDirection wm) -> (Room wm, WMDirection wm) -> Eff es () addDoorToConnection d (front, frontDir) (back, backDir) = do - modifyAndVerifyConnection fr frDir ba (#doorThrough ?~ Just d) - -- check that this is a connection that exists - error "" - --verifyExistenceOfConnection front frontDir back backDir + modifyAndVerifyConnection front frontDir back (#doorThrough ?~ d) + modifyAndVerifyConnection back backDir front (#doorThrough ?~ d) + +modifyAndVerifyConnection :: + forall wm es. + WMStdDirections wm + => NoMissingObjects wm es + => Room wm + -> WMDirection wm + -> Room wm + -> (Connection -> Connection) + -> Eff es () +modifyAndVerifyConnection fromRoom fromDir dest f = do + if connectionInDirection Nothing fromRoom fromDir == Just (tagRoom dest) + then modifyRoom @wm fromRoom (connectionLens fromDir % _Just %~ f) + else noteError (const ()) ("Tried to add a connection to the room " <> display fromRoom <> " but it had no connection in direction " + <> display fromDir <> ". Directions that do exist are " <> show (getAllConnections fromRoom)) diff --git a/src/Yaifl/Model/Properties/Container.hs b/src/Yaifl/Model/Properties/Container.hs index ea8ce82..ea68592 100644 --- a/src/Yaifl/Model/Properties/Container.hs +++ b/src/Yaifl/Model/Properties/Container.hs @@ -25,12 +25,13 @@ module Yaifl.Model.Properties.Container import Solitude import Yaifl.Model.Properties.Enclosing ( Enclosing ) -import Yaifl.Model.Properties.Has ( WMHasProperty ) +import Yaifl.Model.Properties.Has ( WMWithProperty ) import Yaifl.Model.Properties.Query ( defaultPropertySetter, defaultPropertyGetter, modifyProperty ) import Yaifl.Model.Properties.TH ( makeSpecificsWithout ) import Yaifl.Model.Properties.Openable ( Openable(..) ) import Yaifl.Model.Objects.Effects import Yaifl.Model.Objects.ObjectLike +import Yaifl.Model.Object -- | If the container is see-through. data Opacity = Opaque | Transparent diff --git a/src/Yaifl/Model/Properties/Door.hs b/src/Yaifl/Model/Properties/Door.hs index 8f568d8..381ceeb 100644 --- a/src/Yaifl/Model/Properties/Door.hs +++ b/src/Yaifl/Model/Properties/Door.hs @@ -3,7 +3,6 @@ module Yaifl.Model.Properties.Door ( DoorSpecifics(..) - , DoorLike , blankDoorSpecifics , getDoorSpecificsMaybe , isOpen @@ -13,13 +12,13 @@ module Yaifl.Model.Properties.Door import Solitude -import Yaifl.Model.Objects.Query import Yaifl.Model.Properties.Has import Yaifl.Model.Properties.Query import Yaifl.Model.Properties.TH import Yaifl.Model.Objects.Effects import Yaifl.Model.Properties.Openable import Yaifl.Model.Entity +import Yaifl.Model.Object data DoorSpecifics = Door { isOneWay :: Bool @@ -35,20 +34,28 @@ makeFieldLabelsNoPrefix ''DoorSpecifics makeSpecificsWithout [] ''DoorSpecifics isClosed :: - NoMissingRead wm es - => WMHasProperty wm Openable - => ObjectLike wm o + WMWithProperty wm Openable + => CanBeAny wm o => o - -> Eff es Bool -isClosed o = (Just Closed ==) <$> getOpenableMaybe o + -> Bool +isClosed o = Just Closed == getOpenableMaybe o isOpen :: - NoMissingRead wm es - => WMHasProperty wm Openable - => ObjectLike wm o + WMWithProperty wm Openable + => CanBeAny wm o => o - -> Eff es Bool -isOpen o = (Just Open ==) <$> getOpenableMaybe o + -> Bool +isOpen o = Just Open == getOpenableMaybe o +instance Taggable DoorSpecifics DoorTag +{-} type DoorLike wm o = PropertyLike wm DoorSpecifics o + + +instance PropertyLike wm DoorSpecifics DoorEntity where + getAs o = do + a <- getObject o + e <- getDoorSpecificsMaybe a + getPropertyOrThrow "door" a e + -} \ No newline at end of file diff --git a/src/Yaifl/Model/Properties/Has.hs b/src/Yaifl/Model/Properties/Has.hs index 29b3fae..585197b 100644 --- a/src/Yaifl/Model/Properties/Has.hs +++ b/src/Yaifl/Model/Properties/Has.hs @@ -2,8 +2,8 @@ module Yaifl.Model.Properties.Has ( -- * Has - HasProperty(..) - , WMHasProperty + MayHaveProperty(..) + , WMWithProperty ) where import Solitude @@ -11,23 +11,23 @@ import Yaifl.Model.WorldModel ( WMObjSpecifics ) -- | An `AffineTraversal` is an optic that focuses on 0-1 objects; it's a `Prism` without -- the condition that you can build it back up again. -class HasProperty o v where - default propertyL :: AffineTraversal' o v - propertyL = atraversal Left const - propertyL :: AffineTraversal' o v +class MayHaveProperty o v where + default propertyAT :: AffineTraversal' o v + propertyAT = atraversal Left const + propertyAT :: AffineTraversal' o v -instance (HasProperty a v, HasProperty b v) => HasProperty (Either a b) v where - propertyL = propertyL `eitherJoin` propertyL +instance (MayHaveProperty a v, MayHaveProperty b v) => MayHaveProperty (Either a b) v where + propertyAT = propertyAT `eitherJoin` propertyAT -instance HasProperty a v => HasProperty (Maybe a) v where - propertyL = atraversal (\case +instance MayHaveProperty a v => MayHaveProperty (Maybe a) v where + propertyAT = atraversal (\case Nothing -> Left Nothing - Just x -> case x ^? propertyL of + Just x -> case x ^? propertyAT of Nothing -> Left $ Just x Just y -> Right y) (\case Nothing -> const Nothing - Just a -> \v -> Just $ a & propertyL .~ v) + Just a -> \v -> Just $ a & propertyAT .~ v) -- | A helper to define that a world model `wm` has a Property. -type WMHasProperty wm v = HasProperty (WMObjSpecifics wm) v \ No newline at end of file +type WMWithProperty wm v = MayHaveProperty (WMObjSpecifics wm) v \ No newline at end of file diff --git a/src/Yaifl/Model/Properties/Openable.hs b/src/Yaifl/Model/Properties/Openable.hs index 53b5d1e..e8e2a3a 100644 --- a/src/Yaifl/Model/Properties/Openable.hs +++ b/src/Yaifl/Model/Properties/Openable.hs @@ -7,13 +7,14 @@ module Yaifl.Model.Properties.Openable ) where + import Solitude -import Yaifl.Model.Objects.Query import Yaifl.Model.Properties.Has import Yaifl.Model.Properties.Query import Yaifl.Model.Properties.TH import Yaifl.Model.Objects.Effects +import Yaifl.Model.Object -- | Whether the thing is open or not. data Openable = Open | Closed diff --git a/src/Yaifl/Model/Properties/Query.hs b/src/Yaifl/Model/Properties/Query.hs index 96e26c3..593fd62 100644 --- a/src/Yaifl/Model/Properties/Query.hs +++ b/src/Yaifl/Model/Properties/Query.hs @@ -3,10 +3,11 @@ module Yaifl.Model.Properties.Query ( , defaultPropertyGetter , defaultPropertySetter , modifyProperty + , getEnclosingMaybe , getEnclosing , setEnclosing - , PropertyLike(..) - , EnclosingLike + , HasProperty(..) + , EnclosingObject(..) ) where import Solitude @@ -15,10 +16,9 @@ import Yaifl.Model.Entity import Yaifl.Model.Object import Yaifl.Model.Objects.Query import Yaifl.Model.Properties.Enclosing ( Enclosing ) -import Yaifl.Model.Properties.Has ( HasProperty(..), WMHasProperty ) +import Yaifl.Model.Properties.Has import Effectful.Error.Static ( Error, throwError ) import Yaifl.Model.Objects.Effects -import Yaifl.Model.Objects.ObjectLike getPropertyOrThrow :: HasID i @@ -31,80 +31,73 @@ getPropertyOrThrow t o = maybe (throwError $ MissingObject ("Could not find " <> defaultPropertySetter :: NoMissingObjects wm es - => WMHasProperty wm v - => ObjectLike wm o + => WMWithProperty wm v + => CanBeAny wm o => o -> v -> Eff es () -defaultPropertySetter e v = modifyObject e (#specifics % propertyL .~ v) +defaultPropertySetter e v = modifyObject (toAny e) (#specifics % propertyAT .~ v) defaultPropertyGetter :: - NoMissingRead wm es - => WMHasProperty wm v - => ObjectLike wm o + forall wm o v. + WMWithProperty wm v + => CanBeAny wm o => o - -> Eff es (Maybe v) -defaultPropertyGetter e = do - o <- getObject e - return $ preview (#specifics % propertyL) o + -> Maybe v +defaultPropertyGetter o = preview (#specifics % propertyAT) (toAny o) modifyProperty :: - (o -> Eff es (Maybe p)) - -> (o -> p -> Eff es ()) + CanBeAny wm o + => (AnyObject wm -> Maybe p) + -> (AnyObject wm -> p -> Eff es ()) -> o -> (p -> p) -> Eff es () modifyProperty g s o f = do - e <- g o + let e = g (toAny o) when (isNothing e) (do --logVerbose "Trying to modify a property of an object which does not exist" pass) - whenJust e (s o . f) + whenJust e (s (toAny o) . f) -getEnclosing :: - NoMissingObjects wm es - => WMHasProperty wm Enclosing - => ObjectLike wm o - => o - -> Eff es (Maybe Enclosing) -getEnclosing e = asThingOrRoomM e - defaultPropertyGetter - (pure . Just . view (#objectData % #enclosing)) +getEnclosingMaybe :: + forall wm. + WMWithProperty wm Enclosing + => AnyObject wm + -> Maybe Enclosing +getEnclosingMaybe e = asThingOrRoom + (const $ defaultPropertyGetter e) + (Just . view (#objectData % #enclosing)) e setEnclosing :: + forall wm es o. NoMissingObjects wm es - => WMHasProperty wm Enclosing - => ObjectLike wm o + => WMWithProperty wm Enclosing + => CanBeAny wm o => o -> Enclosing -> Eff es () -setEnclosing e v = asThingOrRoomM e +setEnclosing e v = asThingOrRoom (`defaultPropertySetter` v) - (\o -> modifyRoom o (#objectData % #enclosing .~ v)) + (\o -> modifyRoom o (#objectData % #enclosing .~ v)) (toAny @wm e) -asThingKind :: - o - -> a - -> (Object wm s a) -asThingKind = error "" +getEnclosing :: + WMWithProperty wm Enclosing + => EnclosingEntity + -> AnyObject wm + -> Enclosing +getEnclosing _ = fromMaybe (error "property witness was violated") . getEnclosingMaybe -class PropertyLike wm prop o where - getAs :: (WMHasProperty wm prop, NoMissingObjects wm es) => o -> Eff es prop +-- | A lens that is guaranteed by witnesses +class HasProperty w o v where + propertyL :: w -> Lens' o v -type EnclosingLike wm o = PropertyLike wm Enclosing o -instance PropertyLike wm a a where - getAs = pure +instance MayHaveProperty o v => HasProperty w o v where + propertyL _ = lens (fromMaybe (error "property witness was violated") . preview propertyAT) (flip (set propertyAT)) -instance PropertyLike wm Enclosing (TaggedEntity EnclosingTag) where - getAs o = do - a <- getObject o - e <- getEnclosing a - getPropertyOrThrow "enclosing" a e -instance PropertyLike wm Enclosing (TaggedEntity RoomTag) where - getAs o = do - a <- getRoom o - getAs a +class Taggable o EnclosingTag => EnclosingObject o where + enclosingL :: Lens' o Enclosing -instance PropertyLike wm Enclosing (Room wm) where - getAs o = pure $ o ^. #objectData % #enclosing +instance EnclosingObject (Room wm) where + enclosingL = #objectData % #enclosing \ No newline at end of file diff --git a/src/Yaifl/Model/Properties/TH.hs b/src/Yaifl/Model/Properties/TH.hs index 28f165d..10964c5 100644 --- a/src/Yaifl/Model/Properties/TH.hs +++ b/src/Yaifl/Model/Properties/TH.hs @@ -37,11 +37,11 @@ makePropertyFunction :: Name -> SpecificsFunctions -> Q [Dec] makePropertyFunction n sf = do return $ (case sf of GetX -> replaceTH - "getXSUBHEREMaybe :: (NoMissingRead wm es, WMHasProperty wm XSUBHERE, ObjectLike wm o) => o -> Eff es (Maybe XSUBHERE)\ngetXSUBHEREMaybe = defaultPropertyGetter" + "getXSUBHEREMaybe :: (CanBeAny wm o, WMWithProperty wm XSUBHERE) => o -> Maybe XSUBHERE\ngetXSUBHEREMaybe = defaultPropertyGetter" SetX -> replaceTH - "setXSUBHERE :: (NoMissingObjects wm es, WMHasProperty wm XSUBHERE, ObjectLike wm o) => o -> XSUBHERE-> Eff es ()\nsetXSUBHERE = defaultPropertySetter" + "setXSUBHERE :: (CanBeAny wm o, NoMissingObjects wm es, WMWithProperty wm XSUBHERE) => o -> XSUBHERE-> Eff es ()\nsetXSUBHERE = defaultPropertySetter" ModifyX -> replaceTH - "modifyXSUBHERE :: (NoMissingObjects wm es, WMHasProperty wm XSUBHERE, ObjectLike wm o) => o -> (XSUBHERE -> XSUBHERE) -> Eff es ()\nmodifyXSUBHERE = modifyProperty getXSUBHEREMaybe setXSUBHERE" + "modifyXSUBHERE :: (CanBeAny wm o, NoMissingObjects wm es, WMWithProperty wm XSUBHERE) => o -> (XSUBHERE -> XSUBHERE) -> Eff es ()\nmodifyXSUBHERE = modifyProperty getXSUBHEREMaybe setXSUBHERE" ) (toText $ nameBase n) replaceTH :: Text -> Text -> [Dec] diff --git a/src/Yaifl/Rules/WhenPlayBegins.hs b/src/Yaifl/Rules/WhenPlayBegins.hs index 9dbadee..cf0e017 100644 --- a/src/Yaifl/Rules/WhenPlayBegins.hs +++ b/src/Yaifl/Rules/WhenPlayBegins.hs @@ -15,20 +15,21 @@ import Yaifl.Model.Objects.Move ( move ) import Yaifl.Model.Objects.Query ( getCurrentPlayer ) import Yaifl.Text.Print ( Print, printText, setStyle ) import Yaifl.Model.Properties.Enclosing ( Enclosing ) -import Yaifl.Model.Properties.Has ( WMHasProperty ) +import Yaifl.Model.Properties.Has ( WMWithProperty ) import Yaifl.Rules.Rule import Yaifl.Rules.Rulebook ( Rulebook(..) ) import Yaifl.Rules.Run ( failRuleWithError ) import Yaifl.Rules.RuleEffects import Yaifl.Model.Objects.Effects import Yaifl.Rules.Args +import Yaifl.Model.Objects.ObjectLike whenPlayBeginsName :: Text whenPlayBeginsName = "when play begins" -- | The rulebook that runs at the start of the game. whenPlayBeginsRules :: - WMHasProperty wm Enclosing + WMWithProperty wm Enclosing => Rulebook wm () Bool whenPlayBeginsRules = Rulebook whenPlayBeginsName @@ -75,10 +76,11 @@ initRoomDescription = do positionPlayer :: NoMissingObjects wm es - => WMHasProperty wm Enclosing + => WMWithProperty wm Enclosing => Eff es (Maybe Bool) positionPlayer = do - fr <- use #firstRoom + fre <- use #firstRoom + fr <- getRoom fre pl <- getCurrentPlayer m <- move pl fr if m then return Nothing else failRuleWithError "Failed to move the player." \ No newline at end of file diff --git a/test/Yaifl/Test/Chapter3/Common.hs b/test/Yaifl/Test/Chapter3/Common.hs index c0f1192..74fc480 100644 --- a/test/Yaifl/Test/Chapter3/Common.hs +++ b/test/Yaifl/Test/Chapter3/Common.hs @@ -9,6 +9,7 @@ import Yaifl.Test.Chapter3.SlightlyWrong import Yaifl.Test.Chapter3.PortRoyal import qualified Data.Map as M import Yaifl.Test.Chapter3.UpAndUp +import Yaifl.Test.Chapter3.StarryVoid spec :: Bool -> Map String (IO Text) spec allTenses = M.fromList @@ -17,4 +18,5 @@ spec allTenses = M.fromList , ("Slightly Wrong", testHarness allTenses "Slightly Wrong" ex4TestMeWith defaultOptions ex4World) , ("Port Royal", testHarness allTenses "Port Royal" portRoyalTestMeWith defaultOptions portRoyalWorld) , ("Up and Up", testHarness allTenses "Up and Up" upAndUpTestMeWith defaultOptions upAndUp) + , ("Starry Void", testHarness allTenses "Starry Void" starryVoidTestMeWith defaultOptions starryVoidWorld) ] diff --git a/test/Yaifl/Test/Chapter3/StarryVoid.hs b/test/Yaifl/Test/Chapter3/StarryVoid.hs index 0288550..6c4b95c 100644 --- a/test/Yaifl/Test/Chapter3/StarryVoid.hs +++ b/test/Yaifl/Test/Chapter3/StarryVoid.hs @@ -11,30 +11,35 @@ import Yaifl.Model.Objects.Query import Yaifl.Model.Objects.RoomConnections import Yaifl.Model.Properties.Has import Yaifl.Model.Properties.Openable -import Yaifl.Rules.Args import Yaifl.Rules.Rule import Yaifl.Rules.RuleEffects import Yaifl.Text.AdaptiveNarrative import Yaifl.Text.DynamicText import Yaifl.Text.SayQQ +import Yaifl.Model.Properties.Door import Yaifl.Model.Direction +import Yaifl.Rules.Args (getPlayer) -boothDesc :: WMHasProperty wm Openable => Room wm -> DynamicText wm -boothDesc tcr = DynamicText $ Right ("description of magician's booth door", RuleLimitedEffect $ withThing $ \t -> do - player <- getPlayer - picr <- (== tcr) <$> getLocation player - cl <- isClosed t - [sayingTell|{?if picr}A magician's booth stands in the corner, painted dark blue with glittering gold stars. - {?else if cl} A crack of light indicates the way back out to the center ring. - {?else} The door stands open to the outside.{?end if}|] - ) +boothDesc :: WMWithProperty wm Openable => Room wm -> DynamicText wm +boothDesc tcr = DynamicText $ Right ("description of magician's booth door", RuleLimitedEffect $ + withThing $ \t -> + do + p <- getPlayer + picr <- (== tcr) <$> getLocation p + let cl = isClosed t + [sayingTell|{?if picr}A magician's booth stands in the corner, painted dark blue with glittering gold stars. + {?else if cl} A crack of light indicates the way back out to the center ring. + {?else} The door stands open to the outside.{?end if}|] + ) -starryVoid :: Game PlainWorldModel () -starryVoid = do +starryVoidWorld :: Game PlainWorldModel () +starryVoidWorld = do setTitle "Starry Void" tcr <- addRoom "The Centre Ring" "" tsv <- addRoom "The Starry Void" "" - tmb <- addDoor "The magician's booth" (Just $ boothDesc tcr) tcr tsv Nothing - tcr `isInsideFrom` tsv - addDoorToConnection tmb (Out, tcr) (In, tsv) - pass \ No newline at end of file + tsv `isInsideFrom` tcr + tmb <- addDoor "The magician's booth" (Just $ boothDesc tcr) (tsv, Out) (tcr, In) Nothing + pass + +starryVoidTestMeWith :: [Text] +starryVoidTestMeWith = ["examine booth", "open door of the booth", "in", "examine door", "close door", "look", "examine crack of light"] \ No newline at end of file