Begin adding support for parser ambiguity

run_no

@@ -1 +1 @@
-491
+495

src/Yaifl/Game/Actions/Examining.hs

@@ -57,7 +57,7 @@ actionRequiresLight :: ExamineRule wm
 actionRequiresLight = notImplementedRule "action requires light"
 
 examineUndescribed :: ExamineRule wm
-examineUndescribed = makeRule "examine undescribed things rule" forPlayer' $ \Args{..} -> do
+examineUndescribed = makeRule "examine undescribed things rule" forPlayer' $ \Args{} -> do
   --unless (examiningTextPrinted variables) $ sayResponse (#examiningResponses % #examineUndescribedA) (error "")
   rulePass
 

src/Yaifl/Game/Activities/PrintingTheLocaleDescription.hs

@@ -24,7 +24,6 @@ import Yaifl.Game.Actions.Looking.Locale
 import Yaifl.Text.Say
 import qualified Data.EnumMap.Strict as DEM
 import Yaifl.Text.ListWriter
-import Yaifl.Model.ObjectKind
 import Yaifl.Model.Metadata
 
 data YouCanAlsoSeeResponses =

src/Yaifl/Game/ObjectSpecifics.hs

@@ -163,7 +163,10 @@ addDevice ::
   -> "description" :? WMSayable wm -- ^ Description.
   -> "device" :? Device
   -> Eff es ThingEntity
-addDevice n ia d (argDef #device identityElement -> dev) = addThing @wm n ia d ! #specifics (inj (Proxy @wm) (DeviceSpecifics dev)) ! done
+addDevice n ia d (argDef #device identityElement -> dev) = addThing @wm n ia d
+  ! #specifics (inj (Proxy @wm) (DeviceSpecifics dev))
+  ! #type (ObjectKind "device")
+  ! done
 
 addPerson ::
   forall wm es.
@@ -176,4 +179,11 @@ addPerson ::
   -> "description" :? WMSayable wm -- ^ Description.
   -> "carrying" :? Enclosing
   -> Eff es ThingEntity
-addPerson n (Arg g) ia d (argF #carrying -> e) = addThing @wm n ia d ! #specifics (inj (Proxy @wm) (PersonSpecifics (Person g (fromMaybe defaultPersonEnclosing e)))) ! done
+addPerson n (Arg g) ia d (argF #carrying -> e) = addThing @wm n ia d
+  ! #specifics (inj (Proxy @wm) (PersonSpecifics (Person g (fromMaybe defaultPersonEnclosing e))))
+  ! #type (case g of
+    Male -> ObjectKind "man"
+    Female -> ObjectKind "woman"
+    NonBinary -> ObjectKind "person"
+    Other _ -> ObjectKind "person")
+  ! done

src/Yaifl/Game/Parser.hs

@@ -11,7 +11,7 @@ import Effectful.Optics ( use )
 import Yaifl.Model.Action
 import Yaifl.Text.AdaptiveNarrative (AdaptiveNarrative)
 import Yaifl.Model.Kinds.Direction ( HasDirectionalTerms(..) )
-import Yaifl.Model.Metadata ( Metadata, noteError, getGlobalTime )
+import Yaifl.Model.Metadata
 import Yaifl.Model.Query
 import Yaifl.Text.Print
 import Yaifl.Model.Actions.Args
@@ -223,7 +223,8 @@ tryFindingObject t = failHorriblyIfMissing $ do
   pl <- getCurrentPlayer
   playerLoc <- getLocation pl
   allItems <- getAllObjectsInRoom IncludeScenery IncludeDoors playerLoc
-  let scores = zip (map (scoreParserMatch t) allItems) allItems
+  let phraseSet = S.fromList . words $ t
+  let scores = zip (map (scoreParserMatch phraseSet) allItems) allItems
   threshold <- use @Metadata #parserMatchThreshold
   match <- filterM (\(f, _) -> f >>= \x -> pure (x > threshold)) scores
   case match of
@@ -233,15 +234,16 @@ tryFindingObject t = failHorriblyIfMissing $ do
 
 scoreParserMatch ::
   RuleEffects wm es
-  => Text -> Thing wm -> Eff es Double
-scoreParserMatch phrase thing = do
-  let phraseSet = S.fromList . words $ phrase
+  => S.Set Text -> Thing wm -> Eff es Double
+scoreParserMatch phraseSet thing = do
   -- a total match between the phrase and either the thing's name or any of the thing's understand as gives 1
   -- otherwise, we see how many of the words of the phrase are represented in the above
   -- then the match is how many words of the phrase were successfully matched
   matchingAgainst <- (:(toList $ thing ^. #understandAs)) . S.fromList . words <$> sayText (thing ^. #name)
+  -- and also get the matches of its *kind*
+  kindSynonyms <- map (S.fromList . words) . mconcat . S.toList <$> mapKindsOf thing (view #understandAs)
   -- for each set, keep only the words that match
-  let filterSets = S.unions $ map (S.intersection phraseSet) matchingAgainst
+  let filterSets = S.unions $ map (S.intersection phraseSet) (matchingAgainst <> kindSynonyms)
   pure (fromIntegral (S.size filterSets) / fromIntegral (S.size phraseSet))
 
 

src/Yaifl/Model/Action.hs

@@ -138,10 +138,14 @@ data ActionPhrase (wm :: WorldModel) =
   | OtherAction (OutOfWorldAction wm)
   deriving stock ( Generic )
 
+data CommandStatus = None | Low | Medium | High | Maximal
+  deriving stock (Eq, Show, Read, Ord, Enum, Generic)
+
 data WorldActions (wm :: WorldModel) = WorldActions
   { actionsMap :: Map Text (ActionPhrase wm)
   , whenPlayBegins :: Rulebook wm Unconstrained () Bool
   , actionProcessing :: ActionProcessing wm
+  , currentCommandStatus :: CommandStatus
   } deriving stock ( Generic )
 
 makeFieldLabelsNoPrefix ''WorldActions

src/Yaifl/Model/Effects.hs

@@ -23,6 +23,7 @@ module Yaifl.Model.Effects
   , ObjectTraverse(..)
   , traverseRooms
   , traverseThings
+  , traverseThings_
   , traverseRegions
   , generateEntity
   -- ** Type synonyms
@@ -71,6 +72,12 @@ makeEffect ''ObjectLookup
 makeEffect ''ObjectUpdate
 makeEffect ''ObjectTraverse
 
+traverseThings_ ::
+  ObjectTraverse wm :> es
+  => (Thing wm -> Eff es (Maybe (Thing wm)))
+  -> Eff es ()
+traverseThings_ f = traverseThings (\t -> f t >> return Nothing)
+
 -- | Error payload for when an object is not present in the world.
 -- However, most places currently just throw instead of doing any kind of error recovery...
 data MissingObject = MissingObject

src/Yaifl/Model/Metadata.hs

@@ -33,6 +33,7 @@ module Yaifl.Model.Metadata (
   , getGlobalTime
   , tickGlobalTime
   , isKind
+  , mapKindsOf
 
   , kindIsUnderstoodAs
   , kindPluralIsUnderstoodAs
@@ -199,7 +200,7 @@ isKind o = isKindInternal (o ^. #objectType)
       -> ObjectKind
       -> Eff es Bool
     isKindInternal obj e' = do
-      td <- gets $ preview (#kindDAG % at obj % _Just % #childKinds)
+      td <- gets $ preview (#kindDAG % at obj % _Just % #parentKinds)
       case td of
         Nothing -> noteError (const False) ("Found no type entry for " <> show obj)
         Just iv ->
@@ -210,16 +211,39 @@ isKind o = isKindInternal (o ^. #objectType)
           else
             anyM (`isKindInternal` e') iv
 
+mapKindsOf ::
+  forall es k o a.
+  WithMetadata es
+  => Ord a
+  => Is k A_Getter
+  => LabelOptic' "objectType" k o ObjectKind
+  => o -- ^ The object.
+  -> (ObjectKindInfo -> a)
+  -> Eff es (S.Set a)
+mapKindsOf o f = mapKindsInternal (o ^. #objectType)
+  where
+  mapKindsInternal :: ObjectKind -> Eff es (S.Set a)
+  mapKindsInternal ty = do
+    td <- gets @Metadata $ preview (#kindDAG % at ty % _Just)
+    case td of
+      Nothing -> noteError (const $ S.fromList []) ("Found no kind entry for " <> show ty)
+      Just oki ->
+        if S.null (oki ^. #parentKinds)
+        then pure $ S.fromList [f oki]
+        else S.insert (f oki) . mconcat <$> mapM mapKindsInternal (S.toList (oki ^. #parentKinds))
+
 kindIsUnderstoodAs ::
-  ObjectKind
-  -> [ObjectKind]
+  WithMetadata es
+  => ObjectKind
+  -> [Text]
   -> Eff es ()
-kindIsUnderstoodAs kind otherKinds = do
-  pass
+kindIsUnderstoodAs kind otherKinds =
+  #kindDAG % at kind % _Just % #understandAs %= (otherKinds<>)
 
 kindPluralIsUnderstoodAs ::
-  ObjectKind
-  -> [ObjectKind]
+  WithMetadata es
+  => ObjectKind
+  -> [Text]
   -> Eff es ()
-kindPluralIsUnderstoodAs kind otherKinds = do
-  pass
+kindPluralIsUnderstoodAs kind otherKinds =
+  #kindDAG % at kind % _Just % #pluralUnderstandAs %= (otherKinds<>)

src/Yaifl/Model/ObjectKind.hs

@@ -5,8 +5,6 @@ module Yaifl.Model.ObjectKind
 
 import Solitude
 import Yaifl.Model.Kinds.Object
-import Effectful.Optics
-import qualified Data.Set as S
 
 makeKindDAG :: Map ObjectKind (Set ObjectKind)
 makeKindDAG = fromList
@@ -19,15 +17,18 @@ makeKindDAG = fromList
   , ("supporter", fromList ["thing"])
   , ("backdrop", fromList ["thing"])
   , ("person", fromList ["animal"])
+  , ("man", fromList ["person"])
+  , ("woman", fromList ["person"])
   , ("animal", fromList ["thing"])
+  , ("device", fromList ["thing"])
   -- same as direction, probably useless
   , ("region", fromList [])
   , ("door", fromList ["thing"])
   -- we also haven't (yet) got concepts
   ]
 
 data ObjectKindInfo = ObjectKindInfo
-  { childKinds :: Set ObjectKind
+  { parentKinds :: Set ObjectKind
   , understandAs :: [Text]
   , pluralUnderstandAs :: [Text]
   }

src/Yaifl/Model/Rules/Rulebook.hs

@@ -140,8 +140,8 @@ data Rulebook wm x v r = Rulebook
 getRuleNames ::
   Rulebook wm x v r
   -> [Text]
-getRuleNames r = map (\r -> case r ^. #name of
-  "" -> r ^. #name <> " blank rule"
+getRuleNames r = map (\r' -> case r' ^. #name of
+  "" -> r' ^. #name <> " blank rule"
   x -> x) (rules r)
 
 blankRulebook ::

src/Yaifl/Text/Responses.hs

@@ -32,7 +32,6 @@ constResponse t = Response $ const [sayingTell|{t}|]
 
 sayResponse ::
   RuleEffects wm es
-  => SayableValue (WMSayable wm) wm
   => Reader a :> es
   => Is k A_Lens
   => LabelOptic' "responses" k a (resp -> Response wm v)
@@ -47,7 +46,6 @@ sayResponse aL v = do
 
 sayTellResponse ::
   RuleEffects wm es
-  => SayableValue (WMSayable wm) wm
   => Reader a :> es
   => Writer Text :> es
   => Is k A_Lens

test/Yaifl/Test/Chapter3/Bic.hs

@@ -28,12 +28,15 @@ ex2World = do
   setTitle "Bic"
   addRoom "The Staff Break Room"
     ! done
+
   addThing "Bic pen"
     ! #modify (#nameProperness .= Improper)
     ! done
+
   addThing "orange"
     ! #description "It's a small hard pinch-skinned thing from the lunch room, probably with lots of pips and no juice."
     ! done
+
   addThing "napkin"
     ! #description "Slightly crumpled."
     ! done

test/Yaifl/Test/Chapter3/FirstNameBasis.hs

@@ -22,20 +22,26 @@ ex11 = ("First Name Basis", firstNameBasisTestMeWith, firstNameBasisWorld)
 firstNameBasisWorld :: Game PlainWorldModel ()
 firstNameBasisWorld = do
   setTitle "First Name Basis"
-  _tcl <- addRoom "The Crew Lounge"
+  addRoom "The Crew Lounge"
     ! #description [wrappedText|Deliberately spartan: the crew feels weight restrictions here first, so there aren't any chairs, just a few thin pads on the ground.|]
     ! done
+
   thp <- addDevice "holographic projector"
       ! #initialAppearance "The one major source of entertainment is the holographic projector, a top of the line Misthon 9000, on which you view every beam you can get."
       ! #description (text "projector description" $ withThing $ \t -> do
-          let ds = getDeviceMaybe t
-          let isOn = fromMaybe False $ ds ^? _Just % #switchedOn
-          [sayingTell|{?if isOn}The projector is now playing a documentary about the early politics of the Mars colony.{?else}
-The air above the projector is disappointingly clear.{?end if}|]) ! defaults
+          let isOn = fromMaybe False $ getDeviceMaybe t ^? _Just % #switchedOn
+          [sayingTell|{?if isOn}The projector is now playing a documentary about the early politics of the Mars colony.{?else}The air above the projector is disappointingly clear.{?end if}|])
+      ! done
 
   thp `isUnderstoodAs` ["holo", "holograph", "Misthon", "9000"]
-  lewis <- addPerson "Lewis" ! #gender Male ! #description "A wiry, excitable engineer who just signed aboard last week." ! defaults
-  harper <- addPerson "Harper" ! #gender Male ! #description "Harper's a good guy: taciturn when sober, affectionate when drunk, but rarely annoying in either state." ! defaults
+  addPerson "lewis"
+    ! #gender Male
+    ! #description "A wiry, excitable engineer who just signed aboard last week."
+    ! done
+  addPerson "Harper"
+    ! #gender Male
+    ! #description "Harper's a good guy: taciturn when sober, affectionate when drunk, but rarely annoying in either state."
+    ! done
   "man" `kindIsUnderstoodAs` ["man", "guy", "chap", "lad", "male"]
   "man" `kindPluralIsUnderstoodAs` ["men", "guys", "chaps", "lads", "males"]
   pass