Finish Port Royal except a strange bug where it doesn't show previous…

… directions

run_no

@@ -1 +1 @@
-243
+257

src/Yaifl.hs

@@ -22,39 +22,39 @@ import Effectful.Dispatch.Dynamic ( interpret, localSeqUnlift )
 import Effectful.Optics ( (?=), (%=), use, (<<%=) )
 import Effectful.Reader.Static ( runReader, Reader )
 import Effectful.Writer.Static.Local
+
 import Yaifl.Actions.Action
-import Yaifl.Activities.Activity
-import Yaifl.Actions.Parser
-import Yaifl.Text.AdaptiveNarrative (AdaptiveNarrative, blankAdaptiveNarrative)
-import Yaifl.Model.Direction
-import Yaifl.Model.Entity
-import Yaifl.Metadata
-import Yaifl.Model.Object
-import Yaifl.Model.Objects.Create
-import Yaifl.Text.Print
-import Yaifl.Model.Properties.Enclosing
-import Yaifl.Model.Properties.Has
 import Yaifl.Actions.ActionProcessing
-import Yaifl.Rules.Rule
-import Yaifl.Rules.RuleEffects
-import Yaifl.Rules.WhenPlayBegins
-import Yaifl.World
-import Yaifl.Model.WorldModel
-
 import Yaifl.Actions.Going
 import Yaifl.Actions.Looking
+import Yaifl.Actions.Looking.Locale
+import Yaifl.Actions.Looking.Visibility
+import Yaifl.Actions.Parser
+import Yaifl.Activities.Activity
 import Yaifl.Activities.ChoosingNotableLocaleObjects
 import Yaifl.Activities.ListingContents
 import Yaifl.Activities.PrintingLocaleParagraphAbout
 import Yaifl.Activities.PrintingTheLocaleDescription
-import Yaifl.Actions.Looking.Locale
+import Yaifl.Metadata
+import Yaifl.Model.Direction
+import Yaifl.Model.Entity
+import Yaifl.Model.Object
 import Yaifl.Model.ObjectSpecifics
+import Yaifl.Model.Objects.Create
 import Yaifl.Model.Properties.Container
 import Yaifl.Model.Properties.Door
+import Yaifl.Model.Properties.Enclosing
+import Yaifl.Model.Properties.Has
 import Yaifl.Model.Properties.Openable
+import Yaifl.Model.WorldModel
+import Yaifl.Rules.Rule
+import Yaifl.Rules.RuleEffects
+import Yaifl.Rules.WhenPlayBegins
+import Yaifl.Text.AdaptiveNarrative (AdaptiveNarrative, blankAdaptiveNarrative)
+import Yaifl.Text.Print
 import Yaifl.Text.ResponseCollection
 import Yaifl.Text.Say
-import Yaifl.Actions.Looking.Visibility
+import Yaifl.World
 
 import qualified Data.Map as DM
 import qualified Data.Text as T
@@ -106,7 +106,7 @@ blankWorld mkAcColl mkRsColl = World
 
 blankActions :: HasProperty (WMObjSpecifics s) Enclosing => WorldActions s
 blankActions = WorldActions
-  { actions = DM.empty
+  { actionsMap = DM.empty
   , whenPlayBegins = whenPlayBeginsRules
   , actionProcessing = actionProcessingRules
   }
@@ -176,6 +176,7 @@ type UnderlyingEffStack wm = '[State (World wm), IOE]
 
 newWorld ::
   HasLookingProperties wm
+  => HasDirectionalTerms wm
   => WMStdDirections wm
   => WMHasProperty wm DoorSpecifics
   => Eff (EffStack wm) ()
@@ -245,8 +246,8 @@ runCreationAsLookup ::
 runCreationAsLookup = interpret $ \_ -> \case
   GenerateEntity bThing -> if bThing then
     (#stores % #entityCounter % _1) <<%= (+1) else (#stores % #entityCounter % _2) <<%= (\x -> x-1)
-  AddRoom aRoom -> #stores % #rooms % at (getID aRoom) ?= aRoom
-  AddThing aThing -> #stores % #things % at (getID aThing) ?= aThing
+  AddRoomToWorld aRoom -> #stores % #rooms % at (getID aRoom) ?= aRoom
+  AddThingToWorld aThing -> #stores % #things % at (getID aThing) ?= aThing
 
 runQueryAsLookup ::
   HasCallStack
@@ -308,6 +309,7 @@ runGame = convertToUnderlyingStack
 addBaseActions ::
   (HasLookingProperties wm)
   => WMStdDirections wm
+  => HasDirectionalTerms wm
   => WMHasProperty wm DoorSpecifics
   => State (WorldActions wm) :> es
   => Eff es ()
@@ -334,17 +336,22 @@ addOutOfWorld ::
   -> OutOfWorldAction wm
   -> Eff es ()
 addOutOfWorld cs e = forM_ cs $ \c ->
-  #actions % at c ?= OtherAction e
+  #actionsMap % at c ?= OtherAction e
 
 addGoingSynonyms ::
   forall wm es.
-  (State (WorldActions wm) :> es, Bounded (WMDirection wm), Enum (WMDirection wm), Show (WMDirection wm))
+  State (WorldActions wm) :> es
+  => HasDirectionalTerms wm
+  => Bounded (WMDirection wm)
+  => Enum (WMDirection wm)
+  => Show (WMDirection wm)
   => Eff es ()
 addGoingSynonyms = do
-  forM_ (universe @(WMDirection wm)) $ \dir ->
-    let dirN = (T.toLower . fromString . show) dir in
-    #actions % at dirN ?= Interpret (InterpretAs ("go " <> dirN) NoParameter)
-  -- #actions % at "look after going" ?= Interpret (InterpretAs )
+  forM_ (universe @(WMDirection wm)) $ \dir -> do
+    let allTerms = toTextDir (Proxy @wm) dir
+        dirN = (T.toLower . fromString . show) dir
+    forM_ allTerms $ \term ->
+      actionsMapL % at term ?= Interpret (InterpretAs ("go " <> dirN) NoParameter)
 
 makeTypeDAG :: Map ObjectType (Set ObjectType)
 makeTypeDAG = fromList

src/Yaifl/Actions/Action.hs

@@ -18,6 +18,7 @@ module Yaifl.Actions.Action
   , runAction
   , makeActionRulebook
   , actionName
+  , actionsMapL
   ) where
 
 import Solitude
@@ -114,15 +115,19 @@ data ActionPhrase wm =
   Interpret (InterpretAs wm)
   | RegularAction (WrappedAction wm)
   | OtherAction (OutOfWorldAction wm)
+  deriving stock ( Generic )
 
 data WorldActions (wm :: WorldModel) = WorldActions
-  { actions :: Map Text (ActionPhrase wm)
+  { actionsMap :: Map Text (ActionPhrase wm)
   , whenPlayBegins :: Rulebook wm () Bool
   , actionProcessing :: ActionProcessing wm
   } deriving stock ( Generic )
 
 makeFieldLabelsNoPrefix ''WorldActions
 
+actionsMapL :: Lens' (WorldActions wm) (Map Text (ActionPhrase wm))
+actionsMapL = #actionsMap
+
 -- | Run an action. This assumes that all parsing has been completed.
 runAction ::
   forall wm es.
@@ -147,4 +152,4 @@ addAction ::
   State (WorldActions wm) :> es
   => Action wm v
   -> Eff es ()
-addAction ac = #actions % at (ac ^. #name) ?= RegularAction (WrappedAction ac)
+addAction ac = #actionsMap % at (ac ^. #name) ?= RegularAction (WrappedAction ac)

src/Yaifl/Actions/Going.hs

@@ -23,6 +23,10 @@ import Yaifl.Text.Say
 import Breadcrumbs
 import Yaifl.Model.Objects.Move
 import Yaifl.Model.Properties.Enclosing
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Data.Text.Display
+import Yaifl.Model.WorldModel (WMDirection)
 
 data GoingActionVariables wm = GoingActionVariables
   { --The going action has a room called the room gone from (matched as "from").
@@ -122,7 +126,7 @@ goingActionSet (UnverifiedArgs Args{..}) = do
   mbRoomGoneTo <- join <$> traverse getRoomMaybe target
   addAnnotation $ "target was " <> show target
   case mbRoomGoneTo of
-    Nothing -> cantGoThatWay source =<< getMatchingThing "through"
+    Nothing -> flip (cantGoThatWay source) roomGoneFrom =<< getMatchingThing "through"
     Just roomGoneTo -> pure $ Right $ GoingActionVariables
       { thingGoneWith
       , roomGoneFrom
@@ -132,16 +136,22 @@ goingActionSet (UnverifiedArgs Args{..}) = do
 
 cantGoThatWay ::
   RuleEffects wm es
+  => Display (WMDirection wm)
   => WithPrintingNameOfSomething wm
   => Thing wm
   -> Maybe (Thing wm)
+  -> Room wm
   -> Eff es (ArgumentParseResult a)
-cantGoThatWay source mbDoorThrough = do
-  whenM (isPlayer source) $
+cantGoThatWay source mbDoorThrough fromRoom = do
+  whenM (isPlayer source) $ do
+    let possExits = Map.keys $ getAllConnections fromRoom
     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.|]
+      Nothing -> do
+        rn <- sayText (fromRoom ^. #name)
+        [saying|#{We} #{can't go} that way.|]
+        sayLn $ " Perhaps we could try one of " <> T.intercalate ", " (map display possExits) <> " out of " <> rn <> " ?"
+      Just door -> [sayingLn|#{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))

src/Yaifl/Actions/Parser.hs

@@ -26,6 +26,7 @@ import Data.List.Split
 import Data.List (lookup)
 import Effectful.Error.Static
 import Yaifl.Model.Objects.Effects
+import Data.Char (isSpace)
 
 runActionHandlerAsWorldActions ::
   forall es wm a.
@@ -52,7 +53,7 @@ runActionHandlerAsWorldActions = interpret $ \_ -> \case
     possVerbs <- findVerb t
     ac <- case possVerbs of
       [] -> return . Left $ "I have no idea what you meant by '" <> t <> "'."
-      xs:x:_ -> return $ Left $ "Did you mean " <> prettyPrintList (map (show . view _1) [xs, x]) <> "?"
+      xs:x:_ -> return $ Left $ "Did you mean one of" <> prettyPrintList (map (show . view _1) [xs, x]) <> "?"
       [(matched, r, Interpret (InterpretAs x params))] -> do
         addAnnotation $ "Matched " <> matched <> " and interpreting this as " <> x
         runActionHandlerAsWorldActions $ parseAction (actionOpts { hidePrompt = True }) params (x <> r)
@@ -76,7 +77,7 @@ findVerb ::
   -> Eff es [(Text, Text, ActionPhrase wm)]
 findVerb cmd = do
   let cmd' = T.toLower cmd
-  ac <- use #actions
+  ac <- use #actionsMap
   let possVerbs = mapMaybe (\case
         (_, RegularAction a@(WrappedAction (Action{understandAs}))) ->
           case mapMaybe (\ua -> (ua,) <$> ua `T.stripPrefix` cmd') understandAs
@@ -89,7 +90,11 @@ findVerb cmd = do
         (e, OtherAction o@(OutOfWorldAction _ _)) -> case e `T.stripPrefix` cmd' of
           Nothing -> Nothing
           Just r -> Just (e, r, OtherAction o)) (Map.toList ac)
-  return possVerbs
+      removePartialInMiddleOfWord (_matchPart, "", _) = True
+      removePartialInMiddleOfWord (_matchPart, x, _) = case T.uncons x of
+        Nothing -> True
+        Just (a, _b) -> isSpace a
+  return $ filter removePartialInMiddleOfWord possVerbs
 
 findSubjects ::
   forall wm es.

src/Yaifl/Model/Direction.hs

@@ -24,6 +24,9 @@ module Yaifl.Model.Direction (
 
 import Solitude hiding (Down)
 import Yaifl.Model.WorldModel ( WMDirection, WorldModel(..) )
+import Data.Text.Display
+import qualified Data.Text as T
+import Data.Text.Lazy.Builder (fromText)
 
 -- | A *Direction* is a compass direction, in contrast to a WMDirection (which is probably just compass directions
 -- but it may include more).
@@ -42,6 +45,9 @@ data Direction =
   | Down
   deriving stock (Eq, Show, Read, Ord, Enum, Generic, Bounded)
 
+instance Display Direction where
+  displayBuilder = fromText . T.toLower . show
+
 class HasOpposite d where
   opposite :: d -> d
 
@@ -74,7 +80,8 @@ type WMStdDirections (wm :: WorldModel) = (
   , Enum (WMDirection wm)
   , Show (WMDirection wm)
   , Ord (WMDirection wm)
-  , HasOpposite (WMDirection wm))
+  , HasOpposite (WMDirection wm)
+  , Display (WMDirection wm))
 
 -- | A way to get all the strings which a direction may be parsed into.
 -- This is kind of a human-facing `Show` with multiple options.
@@ -92,7 +99,7 @@ instance HasDirectionalTerms ('WorldModel s Direction b c ac r sa) where
     NorthEast -> ["ne", "northeast", "north-east", "north east"]
     SouthEast -> ["se", "southeast", "south-east", "south east"]
     SouthWest -> ["sw", "southwest", "south-west", "south west"]
-    In -> ["nw", "northwest", "north-west", "north west"]
-    Out -> ["nw", "northwest", "north-west", "north west"]
-    Up -> ["nw", "northwest", "north-west", "north west"]
-    Down -> ["nw", "northwest", "north-west", "north west"]
+    In -> ["in", "inside"]
+    Out -> ["out", "outside"]
+    Up -> ["up", "upwards", "above"]
+    Down -> ["down", "downwards", "below"]

src/Yaifl/Model/Objects/RoomConnections.hs

@@ -3,12 +3,19 @@
 module Yaifl.Model.Objects.RoomConnections
   ( isWestOf
   , isSouthOf
+  , isEastOf
+  , isNorthOf
+  , isInsideFrom
+  , isOutsideFrom
+  , isAbove
+  , isBelow
   , getMapConnection
+  , getAllConnections
   ) where
 
 import qualified Data.Map as Map
 
-import Solitude
+import Solitude hiding (Down)
 
 import Yaifl.Model.Direction
 import Yaifl.Model.Entity (HasID(..), Entity)
@@ -22,6 +29,11 @@ import Breadcrumbs
 import Data.Text.Display
 import Yaifl.Model.Objects.Effects
 
+getAllConnections ::
+  Room wm
+  -> Map (WMDirection wm) Connection
+getAllConnections r = r ^. #objectData % #mapConnections % coerced
+
 hasSpecificConnectionTo ::
   WMStdDirections wm
   => Maybe ConnectionExplicitness
@@ -116,7 +128,7 @@ isDirectionFromInternal mkRev dir r2' r1' = withoutMissingObjects (do
     --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
+      -- 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
@@ -130,4 +142,48 @@ isDirectionFromInternal mkRev dir r2' r1' = withoutMissingObjects (do
     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", "North", "East"]
+makeDirections True ["West", "South", "North", "East", "In", "Out", "Up", "Down"]
+
+isInsideFrom ::
+  Breadcrumbs :> es
+  => ObjectQuery wm es
+  => State Metadata :> es
+  => Display (WMSayable wm)
+  => WMStdDirections wm
+  => Room wm
+  -> Room wm
+  -> Eff es ()
+isInsideFrom = isInOf
+
+isOutsideFrom ::
+  Breadcrumbs :> es
+  => ObjectQuery wm es
+  => State Metadata :> es
+  => Display (WMSayable wm)
+  => WMStdDirections wm
+  => Room wm
+  -> Room wm
+  -> Eff es ()
+isOutsideFrom = isOutOf
+
+isAbove ::
+  Breadcrumbs :> es
+  => ObjectQuery wm es
+  => State Metadata :> es
+  => Display (WMSayable wm)
+  => WMStdDirections wm
+  => Room wm
+  -> Room wm
+  -> Eff es ()
+isAbove = isUpOf
+
+isBelow ::
+  Breadcrumbs :> es
+  => ObjectQuery wm es
+  => State Metadata :> es
+  => Display (WMSayable wm)
+  => WMStdDirections wm
+  => Room wm
+  -> Room wm
+  -> Eff es ()
+isBelow = isDownOf

test/Yaifl/Test/Chapter3/Common.hs

@@ -6,11 +6,13 @@ import Solitude
 import Yaifl.Test.Chapter3.Bic
 import Yaifl.Test.Chapter3.Verbosity
 import Yaifl.Test.Chapter3.SlightlyWrong
+import Yaifl.Test.Chapter3.PortRoyal
 import qualified Data.Map as M
 
 spec :: Bool -> Map String (IO Text)
 spec allTenses = M.fromList
   [ ("Bic", testHarness allTenses "Bic" [] defaultOptions ex2World)
   , ("Verbosity", testHarness allTenses "Verbosity" ex3TestMeWith defaultOptions ex3World)
   , ("Slightly Wrong", testHarness allTenses "Slightly Wrong" ex4TestMeWith defaultOptions ex4World)
+  , ("Port Royal", testHarness allTenses "Port Royal" portRoyalTestMeWith defaultOptions portRoyalWorld)
   ]