Skip to content

Commit e253aae

Browse files
PPKFSPPKFS
committed
Another example done
1 parent 6da4441 commit e253aae

File tree

15 files changed

+221
-137
lines changed

15 files changed

+221
-137
lines changed

‎yaifl/src/Yaifl.hs‎

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -356,8 +356,7 @@ runTurnsFromBuffer = do
356356

357357
runTurn ::
358358
forall wm es.
359-
IOE :> es
360-
=> State (WorldActions wm) :> es
359+
State (WorldActions wm) :> es
361360
=> SayableValue (WMText wm) wm
362361
=> RuleEffects wm es
363362
=> Eff es ()
@@ -366,7 +365,6 @@ runTurn = do
366365
wa <- get @(WorldActions wm)
367366
-- runRulebook Nothing False (wa ^. #turnSequence) ()
368367
i <- waitForInput
369-
print i
370368
whenJust i $ \actualInput -> do
371369
printPrompt actionOpts
372370
withStyle (Just bold) $ printText actualInput

‎yaifl/src/Yaifl/Core/Action.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ import Yaifl.Core.Kinds.Thing
4141
import Effectful.Error.Static
4242
import Yaifl.Core.Actions.GoesWith
4343
import Yaifl.Core.Rules.RuleEffects
44+
import Yaifl.Core.Refreshable
4445

4546
type ParseArgumentEffects wm es = (WithMetadata es, NoMissingObjects wm es, RuleEffects wm es)
4647

‎yaifl/src/Yaifl/Core/Activity.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ import Yaifl.Prelude hiding ( Reader, runReader )
2222
import Breadcrumbs ( withSpan )
2323
import GHC.TypeLits
2424
import Effectful.Reader.Static
25-
import Yaifl.Core.Actions.Args ( Refreshable )
25+
import Yaifl.Core.Refreshable ( Refreshable )
2626
import Yaifl.Core.Effects
2727
import Yaifl.Core.Kinds.AnyObject
2828
import Yaifl.Core.WorldModel

‎yaifl/src/Yaifl/Core/Kinds/Object.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@ data Object wm objData objSpecifics = Object
6161
, pluralName :: Maybe (WMText wm)
6262
, namePrivacy :: NamePrivacy
6363
, indefiniteArticle :: Maybe (WMText wm)
64-
, understandAs :: Set (Set Text)
64+
, understandAs :: Set Text
6565
, namePlurality :: NamePlurality
6666
, nameProperness :: NameProperness
6767
, description :: WMText wm

‎yaifl/src/Yaifl/Core/Query/Object.hs‎

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -111,7 +111,4 @@ isUnderstoodAs ::
111111
-> [Text]
112112
-> Eff es ()
113113
isUnderstoodAs o ls = do
114-
modifyObject o (#understandAs %~ S.union (makeUnderstandAsSets ls))
115-
116-
makeUnderstandAsSets :: [Text] -> Set (Set Text)
117-
makeUnderstandAsSets = S.fromList . map (S.fromList . words)
114+
modifyObject o (#understandAs %~ S.union (S.fromList ls))

‎yaifl/src/Yaifl/Std/Actions/Going.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Yaifl.Core.Kinds.Thing
3232
import Yaifl.Core.Kinds.AnyObject
3333
import Yaifl.Std.Kinds.Door
3434
import Yaifl.Core.Query.Enclosing
35+
import Yaifl.Core.Refreshable
3536

3637
data GoingActionVariables wm = GoingActionVariables
3738
{ --The going action has a room called the room gone from (matched as "from").

‎yaifl/src/Yaifl/Std/Actions/Looking/Visibility.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,8 @@ import Yaifl.Std.Kinds.Supporter
1919
import Yaifl.Core.WorldModel
2020
import qualified Data.EnumSet as DES
2121
import Yaifl.Core.Kinds.AnyObject
22-
import Yaifl.Core.Actions.Args
2322
import Yaifl.Core.Query.Enclosing
23+
import Yaifl.Core.Refreshable
2424

2525
-- | An easier way to describe the requirements to look.
2626
type HasLookingProperties wm =

‎yaifl/src/Yaifl/Std/Create/Rule.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ import Yaifl.Core.Query.Enclosing
3030
import Yaifl.Core.Kinds.Thing
3131
import Yaifl.Std.Kinds.Person
3232
import Yaifl.Std.Rulebooks.ActionProcessing
33+
import Yaifl.Core.Refreshable
3334

3435
newtype ActionOrActivity wm resps goesWith v = ActionRule (Lens' (ActionCollection wm) (Action wm resps goesWith v))
3536
deriving stock (Generic)

‎yaifl/src/Yaifl/Std/Parser.hs‎

Lines changed: 133 additions & 119 deletions
Original file line numberDiff line numberDiff line change
@@ -7,37 +7,131 @@ import Yaifl.Prelude
77

88
import Breadcrumbs
99
import Effectful.Dispatch.Dynamic
10+
import Effectful.Error.Static
1011

11-
import Yaifl.Core.Action
12-
import Yaifl.Text.AdaptiveNarrative (AdaptiveNarrative)
13-
import Yaifl.Std.Kinds.Direction ( HasDirectionalTerms(..) )
14-
import Yaifl.Core.Metadata
15-
import Yaifl.Core.Query.Object
16-
import Yaifl.Text.Print
17-
import Yaifl.Core.Actions.Args
18-
import Yaifl.Core.WorldModel ( WMDirection, WMText )
19-
import qualified Data.Map as Map
20-
import qualified Data.Text as T
21-
import Yaifl.Core.Rules.Rulebook
12+
import Data.Char (isSpace)
13+
import Data.List (lookup, delete)
2214
import Data.List.Split
23-
import Data.List (lookup)
24-
import Effectful.Error.Static
2515
import Yaifl.Core.Effects
26-
import Data.Char (isSpace)
27-
import qualified Data.Set as S
16+
import Yaifl.Core.Kinds.AnyObject
17+
import Yaifl.Core.Kinds.Enclosing
2818
import Yaifl.Core.Kinds.Object
29-
import Yaifl.Text.Say
3019
import Yaifl.Core.Kinds.Thing
31-
import Yaifl.Text.ListWriter
32-
import Yaifl.Core.Kinds.AnyObject
20+
import Yaifl.Core.Metadata
21+
import Yaifl.Core.Query.Enclosing
22+
import Yaifl.Core.Query.Object
23+
import Yaifl.Core.Refreshable
24+
import Yaifl.Core.Rules.RuleEffects
3325
import Yaifl.Core.Tag
26+
import Yaifl.Std.Actions.Imports
3427
import Yaifl.Std.Actions.Looking.Visibility
35-
import Yaifl.Core.Kinds.Enclosing
36-
import Yaifl.Core.Query.Enclosing
28+
import Yaifl.Std.Kinds.Direction ( HasDirectionalTerms(..) )
3729
import Yaifl.Std.Kinds.Person
38-
import Yaifl.Core.Actions.GoesWith
3930
import Yaifl.Std.Rulebooks.ActionProcessing
40-
import Yaifl.Core.Rules.RuleEffects
31+
import Yaifl.Text.AdaptiveNarrative (AdaptiveNarrative)
32+
import Yaifl.Text.ListWriter
33+
import Yaifl.Text.Print
34+
35+
import qualified Data.Map as Map
36+
import qualified Data.Set as S
37+
import qualified Data.Text as T
38+
39+
type ActionHandlerConstraints es wm =
40+
(Ord (WMDirection wm)
41+
, Enum (WMDirection wm)
42+
, Bounded (WMDirection wm)
43+
, HasDirectionalTerms wm
44+
, Breadcrumbs :> es
45+
, HasLookingProperties wm
46+
, IOE :> es
47+
, Input :> es
48+
, ObjectLookup wm :> es
49+
, ObjectTraverse wm :> es
50+
, ObjectUpdate wm :> es
51+
, Print :> es
52+
, State (ActivityCollector wm) :> es
53+
, State (AdaptiveNarrative wm) :> es
54+
, State (ResponseCollector wm) :> es
55+
, State Metadata :> es
56+
, State (WorldActions wm) :> es
57+
)
58+
59+
-- | The main action handling routine.
60+
runActionHandlerAsWorldActions ::
61+
forall es wm a.
62+
ActionHandlerConstraints es wm
63+
=> Eff (ActionHandler wm : es) a
64+
-> Eff es a
65+
runActionHandlerAsWorldActions = interpret $ \_ -> \case
66+
ParseAction actionOpts additionalArgs t -> withSpan' "action" t $ failHorriblyIfMissing $ do
67+
addPostPromptSpacing
68+
--we assume that the verb is the first thing in the command;
69+
--TODO: ask other people for things
70+
possVerbs <- findVerb t
71+
72+
ac <- case possVerbs of
73+
[] -> return $ Left ("I have no idea what you meant by '" <> t <> "'.")
74+
_ -> do
75+
filterFirstStringM "." $ map (inject . handleVerbAction actionOpts additionalArgs) possVerbs
76+
whenLeft_ ac (\t' -> do
77+
noteError (const ()) $ "Failed to parse the command " <> t <> " because " <> t'
78+
runActionHandlerAsWorldActions $ failHorriblyIfMissing $ say t')
79+
return ac
80+
81+
handleVerbAction ::
82+
forall es wm.
83+
ActionHandlerConstraints es wm
84+
=> ActionOptions wm
85+
-> [NamedActionParameter wm]
86+
-> (Text, Text, ActionPhrase wm)
87+
-> Eff es (Either Text Bool)
88+
handleVerbAction actionOpts additionalArgs = \case
89+
-- this phrase should be interpreted as a different action
90+
(matched, r, Interpret (InterpretAs x params)) -> do
91+
addAnnotation $ "Matched " <> matched <> " and interpreting this as " <> x
92+
runActionHandlerAsWorldActions $ parseAction (actionOpts { hidePrompt = True }) params (x <> r)
93+
-- this is a meta action
94+
(matched, _, OtherAction (OutOfWorldAction name runIt)) -> do
95+
addAnnotation $ "Action parse was successful; going with the out of world action " <> name <> " after matching " <> matched
96+
runActionHandlerAsWorldActions $ failHorriblyIfMissing $ runIt
97+
pure $ Right True
98+
-- the happy normal path. We have found a matching action and now can do the typed argument parsing.
99+
(matched, r, RegularAction (WrappedAction (a :: Action wm resps goesWith v))) -> do
100+
addAnnotation $ "Action parse was successful; going with the verb " <> view actionName a <> " after matching " <> matched
101+
runActionHandlerAsWorldActions $ do
102+
-- attempt to work out our nouns
103+
-- TODO: handle more additional args
104+
-- TODO: we should probably parse them once instead of per-action
105+
nouns <- parseNouns (Proxy @goesWith) (matches a) (listToMaybe additionalArgs) (T.strip r)
106+
107+
let actuallyRunIt parsedArgs match = failHorriblyIfMissing $ do
108+
-- this is where the actual parsing happens
109+
case tryParseArguments (Proxy @goesWith) (S.fromList $ filter (/= NoParameter) $ match:additionalArgs) of
110+
Nothing -> do
111+
let errMsg = "Argument mismatch because we got " <> show (S.fromList $ match:additionalArgs) <> " and we expected " <> show (goesWithA @goesWith Proxy)
112+
addAnnotation errMsg
113+
return $ Left errMsg
114+
Just v' -> do
115+
ts <- getGlobalTime
116+
actor <- getPlayer
117+
Right <$> tryAction actionOpts a (UnverifiedArgs $ Args { actionOptions = actionOpts, timestamp = ts, source = getTaggedObject actor, variables = (v', parsedArgs) })
118+
case nouns of
119+
Left ex -> do
120+
addAnnotation $ "noun parsing failed because " <> ex
121+
pure (Left ex)
122+
Right (PluralParameter xs, parsedArgs) -> do
123+
addAnnotation $ "Running a set of plural actions..." <> matched
124+
rs <- sequence <$> forM xs (\x -> do
125+
let acName = a ^. #name
126+
n <- failHorriblyIfMissing $ sayParameterName x
127+
failHorriblyIfMissing $ [saying|({acName} {n}) |]
128+
runOnParagraph
129+
actuallyRunIt parsedArgs x)
130+
pure $ second and rs
131+
Right (match, parsedArgs) -> do
132+
addAnnotation $ "matched " <> show match <> " and parsed " <> show parsedArgs
133+
actuallyRunIt parsedArgs match
134+
41135

42136
-- | Run an action. This assumes that all parsing has been completed.
43137
runAction ::
@@ -62,8 +156,8 @@ runAction opts uArgs act = withSpan "run action" (act ^. #name) $ \aSpan -> do
62156
(ActionProcessing ap) <- use @(WorldActions wm) #actionProcessing
63157
ap aSpan act args
64158

65-
filterFirstM :: (Monad m, Foldable t) => Text -> t (m (Either Text a)) -> m (Either Text a)
66-
filterFirstM def = foldlM fn (Left def)
159+
filterFirstStringM :: (Monad m, Foldable t, Semigroup b, Eq b, IsString b) => b -> t (m (Either b a)) -> m (Either b a)
160+
filterFirstStringM def = foldlM fn (Left def)
67161
where
68162
fn memo action = case memo of
69163
Right _ -> pure memo
@@ -73,95 +167,14 @@ filterFirstM def = foldlM fn (Left def)
73167
Left err2 -> pure $ Left $ err2 <> (if err == "." then "" else ", and ") <> err
74168
Right r -> pure (Right r)
75169

76-
runActionHandlerAsWorldActions ::
77-
forall es wm a.
78-
State (WorldActions wm) :> es
79-
=> IOE :> es
80-
=> (Ord (WMDirection wm), Enum (WMDirection wm), Bounded (WMDirection wm), HasDirectionalTerms wm)
81-
=> Breadcrumbs :> es
82-
=> ObjectLookup wm :> es
83-
=> ObjectTraverse wm :> es
84-
=> ObjectUpdate wm :> es
85-
=> Print :> es
86-
=> HasLookingProperties wm
87-
=> State (ActivityCollector wm) :> es
88-
=> State (AdaptiveNarrative wm) :> es
89-
=> State (ResponseCollector wm) :> es
90-
=> State Metadata :> es
91-
=> Input :> es
92-
=> Eff (ActionHandler wm : es) a
93-
-> Eff es a
94-
runActionHandlerAsWorldActions = interpret $ \_ -> \case
95-
ParseAction actionOpts additionalArgs t -> withSpan' "action" t $ failHorriblyIfMissing $ do
96-
addPostPromptSpacing
97-
--we assume that the verb is the first thing in the command
98-
possVerbs <- findVerb t
99-
actor <- getPlayer
100-
ts <- getGlobalTime
101-
let verbAc :: (Text, Text, ActionPhrase wm) -> Eff es (Either Text Bool)
102-
verbAc ac = failHorriblyIfMissing $ case ac of
103-
(matched, r, Interpret (InterpretAs x params)) -> do
104-
addAnnotation $ "Matched " <> matched <> " and interpreting this as " <> x
105-
runActionHandlerAsWorldActions $ parseAction (actionOpts { hidePrompt = True }) params (x <> r)
106-
(matched, r, RegularAction (WrappedAction (a :: Action wm resps goesWith v))) -> do
107-
addAnnotation $ "Action parse was successful; going with the verb " <> view actionName a <> " after matching " <> matched
108-
runActionHandlerAsWorldActions $ do
109-
-- attempt to work out our nouns
110-
-- TODO: handle more additional args
111-
nouns <- parseNouns (Proxy @goesWith) (matches a) (listToMaybe additionalArgs) (T.strip r)
112-
let actuallyRunIt parsedArgs match = failHorriblyIfMissing $ do
113-
addAnnotation $ show match <> show additionalArgs
114-
let v = tryParseArguments (Proxy @goesWith) (S.fromList $ filter (/= NoParameter) $ match:additionalArgs)
115-
case v of
116-
Nothing -> do
117-
addAnnotation $ (("Argument mismatch because we got " <> show (S.fromList $ match:additionalArgs) <> " and we expected " <> show (goesWithA @goesWith Proxy)) :: Text)
118-
return $ Left (("Argument mismatch because we got " <> show (S.fromList $ match:additionalArgs) <> " and we expected " <> show (goesWithA @goesWith Proxy)) :: Text)
119-
Just v' -> Right <$> tryAction actionOpts a (UnverifiedArgs $ Args { actionOptions = actionOpts, timestamp = ts, source = getTaggedObject actor, variables = (v', parsedArgs) })
120-
case nouns of
121-
Left ex -> do
122-
addAnnotation $ "noun parsing failed because " <> ex
123-
pure (Left ex)
124-
Right (PluralParameter xs, parsedArgs) -> do
125-
addAnnotation $ "Running a set of plural actions..." <> matched
126-
rs <- sequence <$> forM xs (\x -> do
127-
let acName = a ^. #name
128-
n <- failHorriblyIfMissing $ sayParameterName x
129-
failHorriblyIfMissing $ [saying|({acName} {n}) |]
130-
runOnParagraph
131-
actuallyRunIt parsedArgs x)
132-
pure $ second and rs
133-
Right (match, parsedArgs) -> do
134-
addAnnotation $ "matched " <> show match <> " and parsed " <> show parsedArgs
135-
actuallyRunIt parsedArgs match
136-
(matched, _, OtherAction (OutOfWorldAction name runIt)) -> do
137-
addAnnotation $ "Action parse was successful; going with the out of world action " <> name <> " after matching " <> matched
138-
runActionHandlerAsWorldActions $ failHorriblyIfMissing $ runIt
139-
pure $ Right True
140-
ac <- case possVerbs of
141-
[] -> return $ Left ("I have no idea what you meant by '" <> t <> "'.")
142-
_ -> do
143-
filterFirstM "." $ map (inject . verbAc) possVerbs
144-
whenLeft_ ac (\t' -> do
145-
noteError (const ()) $ "Failed to parse the command " <> t <> " because " <> t'
146-
runActionHandlerAsWorldActions $ failHorriblyIfMissing $ say t')
147-
return ac
148-
170+
-- | given an expected noun type (which is done at the type level with goeswith) and a list of
171+
-- individual matching words (TODO: also jam these onto the type level), attempt to break the string
172+
-- into nicer parts where we know exactly what each part should be parsed as.
149173
parseNouns ::
150174
forall wm es goesWith.
151175
ActionHandler wm :> es
152-
=> (Enum (WMDirection wm), Bounded (WMDirection wm), HasDirectionalTerms wm)
153176
=> GoesWith goesWith
154-
=> Breadcrumbs :> es
155-
=> ObjectLookup wm :> es
156-
=> ObjectTraverse wm :> es
157-
=> ObjectUpdate wm :> es
158-
=> Print :> es
159-
=> Input :> es
160-
=> HasLookingProperties wm
161-
=> State (ActivityCollector wm) :> es
162-
=> State (AdaptiveNarrative wm) :> es
163-
=> State (ResponseCollector wm) :> es
164-
=> State Metadata :> es
177+
=> ActionHandlerConstraints es wm
165178
=> Proxy (goesWith :: ActionParameterType)
166179
-> [(Text, ActionParameterType)]
167180
-> Maybe (NamedActionParameter wm)
@@ -208,6 +221,7 @@ printPrompt actionOpts = do
208221
modifyBuffer (\b -> b & #lastMessageContext % #runningOnLookingParagraph .~ False)
209222
unless (silently actionOpts || hidePrompt actionOpts) $ printText ">"
210223

224+
-- | Attempt to identify a verb/action from a command string.
211225
findVerb ::
212226
(State (WorldActions wm) :> es)
213227
=> Text
@@ -305,7 +319,6 @@ tryFindingObject t = failHorriblyIfMissing $ do
305319
allItems <- getAllObjectsInEnclosing IncludeScenery IncludeDoors Recurse (tagEntity domainEnc playerLocObj)
306320
findObjectsFrom t allItems True
307321

308-
309322
findObjectsFrom ::
310323
forall wm es.
311324
WithListWriting wm
@@ -315,7 +328,10 @@ findObjectsFrom ::
315328
-> Bool
316329
-> Eff es (Either Text (Either [AnyObject wm] (AnyObject wm)))
317330
findObjectsFrom t allItems considerAmbiguity = do
318-
let phraseSet = S.delete "the" . S.fromList . words $ t
331+
-- first we drop articles because we don't want to be overly lenient
332+
-- then for how inform likes to treat understanding as, we also need every substring of the above
333+
let phraseTails = filter (\x -> (not . null $ x) && x /= ["the"] ) . concat . map inits . tails . words $ t
334+
phraseSet = S.fromList . map (T.intercalate " ") $ phraseTails
319335
-- the scores here are likelihood that it's matching as a singular or part of a plural
320336
scores <- zip allItems <$> mapM (scoreParserMatch phraseSet) allItems
321337
threshold <- use @Metadata #parserMatchThreshold
@@ -364,16 +380,14 @@ scoreParserMatch ::
364380
-> Thing wm
365381
-> Eff es (Double, Double)
366382
scoreParserMatch phraseSet thing = do
367-
-- a total match between the phrase and either the thing's name or any of the thing's understand as gives 1
368-
-- otherwise, we see how many of the words of the phrase are represented in the above
369-
-- then the match is how many words of the phrase were successfully matched
370-
matchingAgainst <- (:(toList $ thing ^. #understandAs)) . S.fromList . words <$> sayText (thing ^. #name)
383+
-- we break the name of the thing into words, and then amend this to the set of understanding.
384+
matchingAgainst <- (<>(toList $ thing ^. #understandAs)) . words <$> sayText (thing ^. #name)
371385
-- and also get the matches of its *kind*
372-
kindSynonyms <- map (S.fromList . words) . mconcat . S.toList <$> mapKindsOf thing (view #understandAs)
373-
kindPluralSynonyms <- map (S.fromList . words) . mconcat . S.toList <$> mapKindsOf thing (view #pluralUnderstandAs)
386+
kindSynonyms <- mconcat . toList <$> mapKindsOf thing (view #understandAs)
387+
kindPluralSynonyms <- mconcat . toList <$> mapKindsOf thing (view #pluralUnderstandAs)
374388
-- for each set, keep only the words that match
375-
let filterSets = S.unions $ map (S.intersection phraseSet . S.map T.toLower) (matchingAgainst <> kindSynonyms)
376-
filterPluralSets = S.unions $ map (S.intersection phraseSet . S.map T.toLower) kindPluralSynonyms
389+
let filterSets = (S.intersection phraseSet . S.map T.toLower) (S.fromList $ matchingAgainst <> kindSynonyms)
390+
filterPluralSets = (S.intersection phraseSet . S.map T.toLower) (S.fromList kindPluralSynonyms)
377391
pure
378392
( fromIntegral (S.size filterSets) / fromIntegral (S.size phraseSet)
379393
, fromIntegral (S.size filterPluralSets) / fromIntegral (S.size phraseSet)

0 commit comments

Comments
 (0)