diff --git a/src/Yaifl.hs b/src/Yaifl.hs index 5a1b0d8..4fcdfe3 100644 --- a/src/Yaifl.hs +++ b/src/Yaifl.hs @@ -84,7 +84,7 @@ type HasStandardProperties s = ( , WMHasProperty s Openable , HasLookingProperties s , WMStdDirections s - , WMHasProperty s Door + , WMHasProperty s DoorSpecifics , HasDirectionalTerms s) blankWorld :: @@ -175,7 +175,7 @@ type UnderlyingEffStack wm = '[State (World wm), IOE] newWorld :: HasLookingProperties wm => WMStdDirections wm - => WMHasProperty wm Door + => WMHasProperty wm DoorSpecifics => Eff (EffStack wm) () newWorld = do addBaseObjects @@ -306,7 +306,7 @@ runGame = convertToUnderlyingStack addBaseActions :: (HasLookingProperties wm) => WMStdDirections wm - => WMHasProperty wm Door + => WMHasProperty wm DoorSpecifics => State (WorldActions wm) :> es => Eff es () addBaseActions = do diff --git a/src/Yaifl/Actions/Action.hs b/src/Yaifl/Actions/Action.hs index 7af9828..1a25f51 100644 --- a/src/Yaifl/Actions/Action.hs +++ b/src/Yaifl/Actions/Action.hs @@ -115,9 +115,11 @@ runAction :: -> WrappedAction wm -> Eff es (Maybe Bool) runAction uArgs (WrappedAction act) = withSpan "run action" (act ^. #name) $ \aSpan -> do - mbArgs <- (\v -> fmap (const v) (unArgs uArgs)) <$$> (runParseArguments (act ^. #parseArguments) uArgs) + mbArgs <- (\v -> fmap (const v) (unArgs uArgs)) <$$> runParseArguments (act ^. #parseArguments) uArgs case mbArgs of - Left err -> noteError (const $ Just False) err + Left err -> do + addAnnotation err + pure (Just False) Right args -> do -- running an action is simply evaluating the action processing rulebook. (ActionProcessing ap) <- use @(WorldActions wm) #actionProcessing diff --git a/src/Yaifl/Actions/Going.hs b/src/Yaifl/Actions/Going.hs index cf47e68..d0ce034 100644 --- a/src/Yaifl/Actions/Going.hs +++ b/src/Yaifl/Actions/Going.hs @@ -6,20 +6,22 @@ import Solitude import Yaifl.Actions.Action import Yaifl.Model.Entity ( Entity ) -import Yaifl.Metadata ( isPlayer) -import Yaifl.Model.Object( Thing, Room, isType, Object, AnyObject ) +import Yaifl.Metadata ( isPlayer ) +import Yaifl.Model.Object( Thing, Room, isType, AnyObject ) import Yaifl.Model.Objects.Query import Yaifl.Model.Objects.ThingData import Yaifl.Rules.Args import Yaifl.Rules.Rule -import Yaifl.Rules.Rulebook -import Effectful.Error.Static import Yaifl.Rules.RuleEffects import Yaifl.Model.Direction import Yaifl.Model.Properties.Has import Yaifl.Model.Properties.Door import Yaifl.Model.Objects.RoomConnections import Yaifl.Model.Objects.Effects +import Yaifl.Text.SayQQ +import Yaifl.Text.Say +import Breadcrumbs +import Yaifl.Model.Objects.Move data GoingActionVariables wm = GoingActionVariables { --The going action has a room called the room gone from (matched as "from"). @@ -36,6 +38,7 @@ data GoingActionVariables wm = GoingActionVariables goingAction :: (WMStdDirections wm, WMHasProperty wm DoorSpecifics) + => WithPrintingNameOfSomething wm => Action wm (GoingActionVariables wm) goingAction = Action "going" @@ -46,14 +49,36 @@ goingAction = Action (makeActionRulebook "before going rulebook" []) (makeActionRulebook "check going rulebook" checkGoingRules) carryOutGoingRules - (makeActionRulebook "report going rulebook" []) + (makeActionRulebook "report going rulebook" [ describeRoomGoneInto ]) + +describeRoomGoneInto :: Rule wm (Args wm (GoingActionVariables wm)) Bool +describeRoomGoneInto = notImplementedRule "describe room gone into rule" + +carryOutGoingRules :: ActionRulebook wm (GoingActionVariables wm) +carryOutGoingRules = makeActionRulebook "carry out going rulebook" + [ movePlayerAndVehicle + , moveFloatingObjects + , checkLightInNewLocation + ] + +checkLightInNewLocation :: Rule wm (Args wm (GoingActionVariables wm)) Bool +checkLightInNewLocation = notImplementedRule "check light in new location rule" + +moveFloatingObjects :: Rule wm (Args wm (GoingActionVariables wm)) Bool +moveFloatingObjects = notImplementedRule "move floating objects rule" + +movePlayerAndVehicle :: Rule wm (Args wm (GoingActionVariables wm)) Bool +movePlayerAndVehicle = makeRule "move player and vehicle rule" [] $ \v -> do + moveSuccessful <- case vehicleGoneBy v of + Nothing -> move (source v) (roomGoneTo v) + Just x -> error "" + error "" -carryOutGoingRules :: ActionRulebook wm v0 -carryOutGoingRules = makeActionRulebook "carry out going rulebook" [] goingActionSet :: forall wm es. (ParseArgumentEffects wm es, WMStdDirections wm, WMHasProperty wm DoorSpecifics) + => WithPrintingNameOfSomething wm => UnverifiedArgs wm -> Eff es (ArgumentParseResult (GoingActionVariables wm)) goingActionSet (UnverifiedArgs Args{..}) = do @@ -74,29 +99,42 @@ goingActionSet (UnverifiedArgs Args{..}) = do -- if the noun is a direction: -- let direction D be the noun; -- let the target be the room-or-door direction D from the room gone from; - DirectionParameter dir -> pure $ getMapConnection @wm dir roomGoneFrom + DirectionParameter dir -> do + addAnnotation $ "going in direction " <> show dir + addAnnotation $ "possible exits are " <> show (roomGoneFrom ^. #objectData % #mapConnections) + pure $ getMapConnection @wm dir roomGoneFrom -- 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; ObjectParameter door -> setDoorGoneThrough door NoParameter -> do - mbDoor <- getDoorSpecifics =<< getMatchingThing "through" - maybe (pure Nothing) (pure . Just . backSide) mbDoor - - case target of - Nothing -> cantGoThatWay =<< getMatchingThing "through" - Just t -> pure $ Right $ GoingActionVariables + mbThrough <- getMatchingThing "through" + mbDoor <- join <$> traverse getDoorSpecifics mbThrough + pure $ backSide <$> mbDoor + mbRoomGoneTo <- join <$> traverse getRoomMaybe target + addAnnotation $ "target was " <> show target + case mbRoomGoneTo of + Nothing -> cantGoThatWay source =<< getMatchingThing "through" + Just roomGoneTo -> pure $ Right $ GoingActionVariables { thingGoneWith , roomGoneFrom - , roomGoneTo = t + , roomGoneTo = roomGoneTo , vehicleGoneBy } -getDoorMaybe :: Thing wm -> AnyObject wm -getDoorMaybe = error "" - -cantGoThatWay :: Maybe (Thing wm) -> Eff es (ArgumentParseResult a) -cantGoThatWay = error "" +cantGoThatWay :: + RuleEffects wm es + => WithPrintingNameOfSomething wm + => Thing wm + -> Maybe (Thing wm) + -> Eff es (ArgumentParseResult a) +cantGoThatWay source mbDoorThrough = do + whenM (isPlayer source) $ + case mbDoorThrough of + -- say "[We] [can't go] that way." (A); + Nothing -> [saying|#{We} #{can't go} that way.|] + Just door -> [saying|#{We} #{can't}, since {the door} #{lead} nowhere.|] + pure $ Left "Can't go that way" getMatchingThing :: RuleEffects wm es => Text -> Eff es (Maybe (Thing wm)) getMatchingThing matchElement = do @@ -108,12 +146,12 @@ getMatchingThing matchElement = do setDoorGoneThrough :: AnyObject wm -> Eff es (Maybe Entity) setDoorGoneThrough = error "" +getDoorMaybe :: Thing wm -> AnyObject wm +getDoorMaybe = error "" + actorInEnterableVehicle :: Thing wm4 -> Eff es (Maybe (Thing wm)) actorInEnterableVehicle _ = pure Nothing -getNouns :: UnverifiedArgs wm -> Text -getNouns = error "" --variables . unArgs - getMatching :: Text -> Eff es (Maybe Entity) getMatching = const $ return Nothing @@ -127,12 +165,10 @@ checkGoingRules = [ ] cantGoThroughClosedDoors :: Rule wm (Args wm (GoingActionVariables wm)) Bool -cantGoThroughClosedDoors = makeRule "stand up before going" [] $ \_v -> do - return Nothing +cantGoThroughClosedDoors = notImplementedRule "stand up before going" cantGoThroughUndescribedDoors :: Rule wm (Args wm (GoingActionVariables wm)) Bool -cantGoThroughUndescribedDoors = makeRule "stand up before going" [] $ \_v -> do - return Nothing +cantGoThroughUndescribedDoors = notImplementedRule "stand up before going" cantTravelInNotAVehicle :: Rule wm (Args wm (GoingActionVariables wm)) Bool cantTravelInNotAVehicle = makeRule "can't travel in what's not a vehicle" [] $ \v -> do diff --git a/src/Yaifl/Actions/Parser.hs b/src/Yaifl/Actions/Parser.hs index 570c580..7aa4b79 100644 --- a/src/Yaifl/Actions/Parser.hs +++ b/src/Yaifl/Actions/Parser.hs @@ -135,6 +135,7 @@ findSubjects cmd w@(WrappedAction a) = runErrorNoCallStack $ failHorriblyIfMissi parseArgumentType :: forall wm es. (Enum (WMDirection wm), Bounded (WMDirection wm), HasDirectionalTerms wm) + => Breadcrumbs :> es => ActionParameterType -> Text -> Eff es (Either Text (ActionParameter wm)) @@ -144,7 +145,9 @@ parseArgumentType TakesNoParameter "" = pure $ Right NoParameter parseArgumentType (TakesOneOf ap1 ap2) t = do mbRes <- parseArgumentType ap1 t case mbRes of - Left _err -> parseArgumentType ap2 t + Left err -> do + addAnnotation err + parseArgumentType ap2 t Right res -> pure $ Right res parseArgumentType a t = pure $ Left $ "not implemented yet" <> show a <> " " <> t diff --git a/src/Yaifl/Model/ObjectSpecifics.hs b/src/Yaifl/Model/ObjectSpecifics.hs index 1ad2632..c261c26 100644 --- a/src/Yaifl/Model/ObjectSpecifics.hs +++ b/src/Yaifl/Model/ObjectSpecifics.hs @@ -17,7 +17,7 @@ import Yaifl.Model.Properties.Enclosing ( Enclosing ) import Yaifl.Model.Properties.Has ( HasProperty(..), WMHasProperty ) import Yaifl.Model.WorldModel ( WMObjSpecifics, WorldModel(..), WMSayable ) import Yaifl.Model.Properties.Container -import Yaifl.Model.Properties.Door ( Door, blankDoor ) +import Yaifl.Model.Properties.Door import Yaifl.Model.Properties.Openable ( Openable ) import Yaifl.Model.Objects.Effects @@ -26,7 +26,7 @@ data ObjectSpecifics = | EnclosingSpecifics Enclosing | ContainerSpecifics Container | OpenableSpecifics Openable - | DoorSpecifics Door + | DoorSpecifics DoorSpecifics deriving stock (Eq, Show, Read) makePrisms ''ObjectSpecifics @@ -49,7 +49,7 @@ instance HasProperty ObjectSpecifics Enterable where instance HasProperty ObjectSpecifics Openable where propertyL = _OpenableSpecifics `thenATraverse` (_ContainerSpecifics % containerOpenable) -instance HasProperty ObjectSpecifics Door where +instance HasProperty ObjectSpecifics DoorSpecifics where propertyL = castOptic _DoorSpecifics localST :: diff --git a/src/Yaifl/Model/Objects/RoomConnections.hs b/src/Yaifl/Model/Objects/RoomConnections.hs index 02726c3..583f003 100644 --- a/src/Yaifl/Model/Objects/RoomConnections.hs +++ b/src/Yaifl/Model/Objects/RoomConnections.hs @@ -86,6 +86,9 @@ addDirectionFromOneWay :: -> Eff es () addDirectionFromOneWay = isDirectionFromInternal False +-- | the ordering here is that r2' `isSouthOf` (for example) r1 means +-- the connection to be made explicitly is from r1 (south) -> r2 +-- then the implicit reverse connection is r2 (opposite south) -> r1 isDirectionFromInternal :: State Metadata :> es => Breadcrumbs :> es @@ -97,19 +100,19 @@ isDirectionFromInternal :: -> Room wm -> Room wm -> Eff es () -isDirectionFromInternal mkRev dir r1' r2' = withoutMissingObjects (do +isDirectionFromInternal mkRev dir r2' r1' = withoutMissingObjects (do let opp = opposite dir r1 <- refreshRoom r1' r2 <- refreshRoom r2' -- we log a warning if we're in construction and we are overriding an explicit connection -- apparently inform just doesn't let you do this, so... - -- r1 is explicitly dir of r2; it is r2 we need to check + -- r2 is explicitly dir of r1; it is r1 we need to check -- r2 is implicitly (opposite dir) of r1. -- e.g. if r1 `isWestOf` r2, then r2 has an explicit west connection and r1 has an implicit east connection. - whenConstructing (isJust $ hasSpecificConnectionTo (Just Explicit) r2 dir) + whenConstructing (isJust $ hasSpecificConnectionTo (Just Explicit) r1 dir) -- TODO: this should be a nonblocking failure (addAnnotation $ "Overriding an explicitly set map direction of room " <> "")--show r1) - modifyRoom r2 (makeConnection Explicit dir r1) + modifyRoom r1 (makeConnection Explicit dir r2) --only make the reverse if we want to when mkRev $ do -- something weird is happening if we're overriding an implicit direction with another implicit direction @@ -117,7 +120,14 @@ isDirectionFromInternal mkRev dir r1' r2' = withoutMissingObjects (do whenConstructing (isJust $ hasSpecificConnectionTo (Just Implicit) r2 opp) (addAnnotation $ "Not using an implicit direction to overwrite an implicitly set map direction of room " <> "") --show r1) -- and don't bother if there's any connection at all - unless (isJust $ r1 ^? connectionLens opp) $ modifyRoom r1 (makeConnection Implicit dir r2) + if isJust $ r2 ^? connectionLens opp + then do + modifyRoom r2 (makeConnection Implicit opp r1) + addAnnotation $ "made implicit connection from " <> display (view #name r2) <> " going " <> show opp <> " to " <> display (view #name r1) + else + addAnnotation $ "did not make implicit connection from " <> display (view #name r2) <> " going " <> show opp <> " to " <> display (view #name r1) + <> " because it's already made." + addAnnotation $ "made connection from " <> display (view #name r1) <> " going " <> show dir <> " to " <> display (view #name r2) pass) (handleMissingObject "failed to make direction" ()) -makeDirections True ["West", "South"] +makeDirections True ["West", "South", "North", "East"] diff --git a/src/Yaifl/Text/Say.hs b/src/Yaifl/Text/Say.hs index 0a66c4d..ab05813 100644 --- a/src/Yaifl/Text/Say.hs +++ b/src/Yaifl/Text/Say.hs @@ -126,6 +126,15 @@ instance SayableValue (SayLiteral "it") wm where instance SayableValue (SayLiteral "see") wm where sayTell = sayVerb @"see" +instance SayableValue (SayLiteral "go") wm where + sayTell = sayVerb @"go" + +instance SayableValue (SayLiteral "can't") wm where + sayTell = sayVerb @"can't" + +instance SayableValue (SayLiteral "lead") wm where + sayTell = sayVerb @"lead" + instance SayableValue (SayLiteral "are") wm where sayTell s = sayVerb @"be" (coerce s) diff --git a/src/Yaifl/Text/Verb.hs b/src/Yaifl/Text/Verb.hs index 491476f..9d93f18 100644 --- a/src/Yaifl/Text/Verb.hs +++ b/src/Yaifl/Text/Verb.hs @@ -257,13 +257,6 @@ toBeAbleTo = makeVerb "do" toAuxiliaryHave :: Verb toAuxiliaryHave = makeVerb "auxiliary-have" - -{-onst $ const $ const $ \case - FirstPersonSingular -> "am" - ThirdPersonSingular -> "is" - _ -> "are" -} - - (#|) :: Text -> Text -> Text (#|) "" b = b (#|) a "" = a