Flesh out going

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

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

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

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
 

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 ::

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,27 +100,34 @@ 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
       -- but I think in general we don't bother setting an implicit one
       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"]

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)
 

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