Mostly sort out ambiguity

cabal.project

@@ -1,7 +1,7 @@
 source-repository-package
   type: git
   location: https://github.com/haskell-effectful/effectful.git
-  tag: a8bec7209884e8688e93c7a51e6e57d2a2c461af
+  tag: 2037be9a4f4e8f8fd280d9359b1bc7feff9b29b9
   subdir: effectful-core
   subdir: effectful-plugin
   subdir: effectful-th

run_no

@@ -1 +1 @@
-495
+501

src/Yaifl.hs

@@ -13,12 +13,14 @@ module Yaifl (
   , Game
   , runGame
   , addStandardActions
+  , runTurnsFromBuffer
+  , runTurn
   ) where
 
 import Solitude hiding ( Reader, runReader )
 
 
-import Effectful.Optics ( (?=) )
+import Effectful.Optics ( (?=), use )
 
 import Yaifl.Model.Action
 import Yaifl.Game.ActionProcessing
@@ -70,6 +72,7 @@ import Yaifl.Model.Kinds.Thing
 import Yaifl.Model.Kinds.Room
 import Yaifl.Model.ObjectKind
 import qualified Data.Map as M
+import Yaifl.Model.Input (waitForInput, Input)
 
 type PlainWorldModel = 'WorldModel ObjectSpecifics Direction () () ActivityCollection ResponseCollection DynamicText
 
@@ -163,6 +166,7 @@ blankMetadata = Metadata
   , traceAnalysisLevel = Maximal
   , oxfordCommaEnabled = True
   , parserMatchThreshold = 0.66
+  , bufferedInput = []
   }
 
 newWorld ::
@@ -261,4 +265,22 @@ addOutOfWorld ::
   -> OutOfWorldAction wm
   -> Eff es ()
 addOutOfWorld cs e = forM_ cs $ \c ->
-  #actionsMap % at c ?= OtherAction e
+  #actionsMap % at c ?= OtherAction e
+
+runTurnsFromBuffer ::
+  State Metadata :> es
+  => Input :> es
+  => ActionHandler wm :> es
+  => Eff es ()
+runTurnsFromBuffer = do
+  b <- use #bufferedInput
+  unless (null b) $ runTurn >> runTurnsFromBuffer
+
+runTurn ::
+  Input :> es
+  => ActionHandler wm :> es
+  => Eff es ()
+runTurn = do
+  i <- waitForInput
+  void $ parseAction (ActionOptions False False) [NoParameter] i
+  -- TODO: this is where every turn things happen

src/Yaifl/Game/Actions/Looking.hs

@@ -37,6 +37,7 @@ import Yaifl.Text.SayQQ
 import qualified Prettyprinter.Render.Terminal as PPTTY
 import Yaifl.Model.Kinds.AnyObject
 import Yaifl.Model.Kinds.Thing
+import Yaifl.Model.Input
 
 data LookingResponses wm =
   RoomDescriptionHeadingA
@@ -131,6 +132,7 @@ foreachVisibilityHolder ::
   => ActionHandler wm :> es
   => ObjectTraverse wm :> es
   => Print :> es
+  => Input :> es
   => Reader (LookingAction wm) :> es
   => State (ActivityCollector wm) :> es
   => State (AdaptiveNarrative wm) :> es

src/Yaifl/Game/EffectHandlers.hs

@@ -22,13 +22,17 @@ import Yaifl.Game.Actions.Collection
 import Effectful.Error.Static (Error, runError)
 import Yaifl.Model.Store
 import Yaifl.Model.Kinds.Region
+import Yaifl.Model.Input
+import Yaifl.Text.ListWriter
 
 
 type EffStack (wm :: WorldModel) = '[
   ActionHandler wm
+
   , State (AdaptiveNarrative wm)
   , State (ResponseCollector wm)
   , State (ActivityCollector wm)
+  , Input
   , State (ActionCollection wm)
   , ObjectTraverse wm
   , ObjectUpdate wm
@@ -38,6 +42,7 @@ type EffStack (wm :: WorldModel) = '[
   , State (WorldActions wm)
   , Print
   , State (World wm)
+
   , Breadcrumbs
   , Error MissingObject
   , IOE
@@ -65,11 +70,14 @@ zoomState l = interpret $ \env -> \case
 convertToUnderlyingStack ::
   forall wm a.
   (Ord (WMDirection wm), Enum (WMDirection wm), Bounded (WMDirection wm), HasDirectionalTerms wm, Display (WMSayable wm), SayableValue (WMSayable wm) wm)
-  => World wm
+  -- => WithResponseSet wm An_Iso "listWriterResponses" (ListWriterResponses -> Response wm ())
+  => WithListWriting wm
+  => (forall es b. State Metadata :> es => Eff (Input : es) b -> Eff es b)
+  -> World wm
   -> ActionCollection wm
   -> Eff (EffStack wm) a
   -> IO (a, World wm)
-convertToUnderlyingStack w ac =
+convertToUnderlyingStack i w ac =
   fmap (either (error . show) id)
   . runEff
   . runError
@@ -82,6 +90,7 @@ convertToUnderlyingStack w ac =
   . runQueryAsLookup
   . runTraverseAsLookup
   . evalStateShared ac
+  . i
   . zoomState @(World wm) #activities
   . zoomState @(World wm) #responses
   . zoomState @(World wm) #adaptiveNarrative
@@ -169,7 +178,9 @@ updateIt newObj mbExisting = case mbExisting of
 
 runGame ::
   (Ord (WMDirection wm), Enum (WMDirection wm), Bounded (WMDirection wm), HasDirectionalTerms wm, Display (WMSayable wm), SayableValue (WMSayable wm) wm)
-  => World wm
+  => WithListWriting wm
+  => (forall es b. State Metadata :> es => Eff (Input : es) b -> Eff es b)
+  -> World wm
   -> ActionCollection wm
   -> Eff (EffStack wm) a
   -> IO (a, World wm)

src/Yaifl/Game/Parser.hs

@@ -28,7 +28,10 @@ import qualified Data.Set as S
 import Yaifl.Model.Kinds.Object
 import Yaifl.Text.Say
 import Yaifl.Model.Kinds.Thing
+import Yaifl.Text.ListWriter
 import Yaifl.Model.Kinds.AnyObject
+import Effectful.Writer.Static.Local (execWriter)
+import Yaifl.Model.Input (waitForInput, Input)
 
 -- | Run an action. This assumes that all parsing has been completed.
 runAction ::
@@ -60,11 +63,13 @@ runActionHandlerAsWorldActions ::
   => ObjectTraverse wm :> es
   => ObjectUpdate wm :> es
   => Print :> es
+  => WithListWriting wm
   => SayableValue (WMSayable wm) wm
   => State (ActivityCollector wm) :> es
   => State (AdaptiveNarrative wm) :> es
   => State (ResponseCollector wm) :> es
   => State Metadata :> es
+  => Input :> es
   => Eff (ActionHandler wm : es) a
   -> Eff es a
 runActionHandlerAsWorldActions = interpret $ \_ -> \case
@@ -137,6 +142,8 @@ findSubjects ::
   => ObjectTraverse wm :> es
   => ObjectUpdate wm :> es
   => Print :> es
+  => Input :> es
+  => WithListWriting wm
   => SayableValue (WMSayable wm) wm
   => State (ActivityCollector wm) :> es
   => State (AdaptiveNarrative wm) :> es
@@ -179,6 +186,7 @@ findSubjects cmd actionArgs (WrappedAction (a :: Action wm resps goesWith v)) =
 parseArgumentType ::
   forall wm es.
   (Enum (WMDirection wm), Bounded (WMDirection wm), HasDirectionalTerms wm)
+  => WithListWriting wm
   => RuleEffects wm es
   => ActionParameterType
   -> Text
@@ -208,15 +216,17 @@ parseArgumentType TakesThingParameter t = do
 parseArgumentType a t = pure $ Left $ "not implemented yet" <> show a <> " " <> t
 
 tryFindingAnyObject ::
-  RuleEffects wm es
+  WithListWriting wm
+  => RuleEffects wm es
   => Text
   -> Eff es (Either Text (NamedActionParameter wm))
 tryFindingAnyObject t = do
   o <- tryFindingObject t
   pure $ ObjectParameter <$> o
 
 tryFindingObject ::
-  RuleEffects wm es
+  WithListWriting wm
+  => RuleEffects wm es
   => Text
   -> Eff es (Either Text (AnyObject wm))
 tryFindingObject t = failHorriblyIfMissing $ do
@@ -230,7 +240,23 @@ tryFindingObject t = failHorriblyIfMissing $ do
   case match of
     [] -> pure $ Left $ "I can't see anything called \"" <> t <> "\"."
     [x] -> pure $ Right (toAny $ snd x)
-    (_x:_xs) -> pure $ Left "I saw too many things that could be that."
+    xs -> handleAmbiguity (map (toAny . snd) xs)
+
+handleAmbiguity ::
+  WithListWriting wm
+  => RuleEffects wm es
+  => [AnyObject wm]
+  -> Eff es (Either Text (AnyObject wm))
+handleAmbiguity ls = do
+  names <- mapM (sayText . view #name) ls
+  let phrase = case names of
+        [] -> error "no objects to be ambiguous between"
+        [x] -> x
+        [x, y] -> x <> " or " <> y
+        l -> maybe (error "impossible") (\(i, ls') -> T.intercalate ", " i <> ", or " <> ls') (unsnoc l)
+  say $ "Which did you mean: " <> phrase <> "?"
+  i <- waitForInput
+  pure $ Left "I saw too many things that could be that."
 
 scoreParserMatch ::
   RuleEffects wm es
@@ -263,10 +289,11 @@ parseDirection p cmd =
 -- Note that this does require the arguments to be parsed out.
 tryAction ::
   NoMissingObjects wm es
+  => WithListWriting wm
+  => Input :> es
   => Refreshable wm v
   => ActionHandler wm :> es
   => ObjectTraverse wm :> es
-  => SayableValue (WMSayable wm) wm
   => State (WorldActions wm) :> es
   => State (ActivityCollector wm) :> es
   => State (ResponseCollector wm) :> es

src/Yaifl/Model/Action.hs

@@ -138,14 +138,10 @@ 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/Input.hs

@@ -0,0 +1,41 @@
+module Yaifl.Model.Input
+  ( Input(..)
+  , waitForInput
+  , runInputAsBuffer
+  , setInputBuffer
+  ) where
+
+import Solitude
+import Yaifl.Model.Metadata
+import Effectful.Optics
+import Effectful.Dispatch.Dynamic (interpret)
+import Effectful.TH ( makeEffect )
+
+data Input :: Effect where
+  WaitForInput :: Input m Text
+
+makeEffect ''Input
+
+runInputAsStdin ::
+  Eff (Input : es) a
+  -> Eff es a
+runInputAsStdin = error "not implemented"
+
+runInputAsBuffer ::
+  State Metadata :> es
+  => Eff (Input : es) a
+  -> Eff es a
+runInputAsBuffer = interpret $ \_ -> \case
+  WaitForInput -> do
+    buf <- use #bufferedInput
+    case buf of
+      [] -> error "ran out of buffered input"
+      (x:xs) -> do
+        #bufferedInput .= xs
+        pure x
+
+setInputBuffer ::
+  State Metadata :> es
+  => [Text]
+  -> Eff es ()
+setInputBuffer b = #bufferedInput .= b

src/Yaifl/Model/Metadata.hs

@@ -87,6 +87,7 @@ data Metadata = Metadata
   , traceAnalysisLevel :: AnalysisLevel -- ^ See `AnalysisLevel`.
   , oxfordCommaEnabled :: Bool -- ^ should we use the oxford comma in lists?
   , parserMatchThreshold :: Double -- ^ at what cutoff should we consider something a parser match?
+  , bufferedInput :: [Text]
   -- more to come I guess
   } deriving stock (Generic)
 makeFieldLabelsNoPrefix ''Metadata

src/Yaifl/Model/Rules/RuleEffects.hs

@@ -20,6 +20,7 @@ import Yaifl.Text.Print ( Print, printText )
 import Yaifl.Model.WorldModel ( WMActivities, WMResponses, WMSayable )
 import Yaifl.Model.Effects
 import Yaifl.Model.Actions.Args
+import Yaifl.Model.Input
 
 data ActionHandler wm :: Effect where
   ParseAction :: ActionOptions wm -> [NamedActionParameter wm] -> Text -> ActionHandler wm m (Either Text Bool)
@@ -33,6 +34,7 @@ makeEffect ''ActionHandler
 
 type RuleEffects wm es = (
   State Metadata :> es
+  , Input :> es
   , State (ActivityCollector wm) :> es
   , State (ResponseCollector wm) :> es
   , State (AdaptiveNarrative wm) :> es
@@ -60,6 +62,7 @@ instance SayableValue String wm where
 
 type ConcreteRuleStack wm = '[
   ActionHandler wm
+  , Input
   , State (AdaptiveNarrative wm)
   , State (ResponseCollector wm)
   , State (ActivityCollector wm)

src/Yaifl/Text/Say.hs

@@ -35,6 +35,7 @@ import Yaifl.Model.Kinds.AnyObject
 import Yaifl.Model.Kinds.Room
 import Yaifl.Model.Kinds.Thing
 import Yaifl.Text.SayQQ
+import Yaifl.Model.Input
 
 sayText ::
   SayableValue s wm
@@ -231,6 +232,7 @@ printName ::
   => Print :> es
   => State (ActivityCollector wm) :> es
   => State (AdaptiveNarrative wm) :> es
+  => Input :> es
   => State (ResponseCollector wm) :> es
   => WithPrintingNameOfSomething wm
   => ObjectLike wm o

test/Yaifl/Test/Chapter3/FirstNameBasis.hs

@@ -34,11 +34,11 @@ firstNameBasisWorld = do
       ! done
 
   thp `isUnderstoodAs` ["holo", "holograph", "Misthon", "9000"]
-  addPerson "lewis"
+  addPerson "Lewis"
     ! #gender Male
     ! #description "A wiry, excitable engineer who just signed aboard last week."
     ! done
-  addPerson "Harper"
+  addPerson "harper"
     ! #gender Male
     ! #description "Harper's a good guy: taciturn when sober, affectionate when drunk, but rarely annoying in either state."
     ! done

test/Yaifl/Test/Common.hs

@@ -18,7 +18,8 @@ import qualified Data.Text as T
 import Yaifl.Text.AdaptiveNarrative
 import Yaifl.Text.Print
 import Yaifl.Text.Verb
-import Yaifl.Model.Actions.Args
+import Effectful.Optics
+import Yaifl.Model.Input
 
 expQQ :: (String -> Q Exp) -> QuasiQuoter
 expQQ quoteExp = QuasiQuoter quoteExp notSupported notSupported notSupported where
@@ -76,7 +77,7 @@ testHarness ::
   -> Game wm a
   -> IO Text
 testHarness allTenses fullTitle actionsToDo conOptions initWorld = do
-  fst <$$> runGame (blankWorld (activityCollectionBuilder conOptions) (responseCollectionBuilder conOptions)) blankActionCollection $ do
+  fst <$$> runGame runInputAsBuffer (blankWorld (activityCollectionBuilder conOptions) (responseCollectionBuilder conOptions)) blankActionCollection $ do
       output <- withSpan' "test run" fullTitle $ do
         withSpan' "worldbuilding" fullTitle $ do
           newWorld
@@ -92,7 +93,8 @@ testHarness allTenses fullTitle actionsToDo conOptions initWorld = do
                 unless (suffix == "") $ printLn suffix
                 --when I write a proper game loop, this is where it needs to go
                 failHorriblyIfMissing (runRulebook Nothing False (wa ^. #whenPlayBegins) ())
-                mapM_ (parseAction (ActionOptions False False) [NoParameter]) actionsToDo
+                setInputBuffer actionsToDo
+                runTurnsFromBuffer
                 (w2 :: World wm) <- get
                 let (x, _) = runPureEff $ runStateShared w2 $ do
                       -- take it down and flip it around