Skip to content

Commit

Permalink
maybe one day I'll finish all this entering logic
Browse files Browse the repository at this point in the history
  • Loading branch information
PPKFS committed Dec 13, 2024
1 parent df60393 commit 5e44d8b
Show file tree
Hide file tree
Showing 4 changed files with 95 additions and 4 deletions.
79 changes: 76 additions & 3 deletions yaifl/src/Yaifl/Game/Actions/Entering.hs
Original file line number Diff line number Diff line change
Expand Up @@ -12,9 +12,13 @@ import Yaifl.Model.Kinds.Enclosing
import Yaifl.Game.Move
import Yaifl.Model.Kinds.Container
import Yaifl.Model.Tag
import Yaifl.Model.Query (getEnclosingMaybe)
import Yaifl.Model.Query
import Yaifl.Model.Kinds.AnyObject
import Yaifl.Model.Metadata
import Yaifl.Model.Entity
import Yaifl.Model.Kinds.Supporter
import Yaifl.Model.Kinds.Animal
import Effectful.Error.Static

data EnteringResponses wm

Expand All @@ -41,7 +45,7 @@ enteringAction = (makeAction "entering")
, cantEnterClosedContainers
, cantExceedCapacity
, notImplementedRule "cant enter carried things"
, notImplementedRule "implicitly pass through other barriers"
, implicitlyPassThrough
]
, carryOutRules = makeActionRulebook "carry out entering rulebook" [ standardEntering ]
, reportRules = makeActionRulebook "report entering rulebook"
Expand All @@ -64,8 +68,77 @@ cantEnterWhenEntered = notImplementedRule "cant enter what's already entered"
cantEnterUnenterable :: EnteringRule wm
cantEnterUnenterable = notImplementedRule "can't enter what's not enterable rule"

implicitlyPassThrough :: WithPrintingNameOfSomething wm => EnteringRule wm
implicitlyPassThrough = makeRule "can't enter closed containers rule" [] $ \a@Args{source=s, variables=v} -> do
let actorHolder = thingContainedBy s
nounHolder = thingContainedBy $ getTaggedObject v
-- let the local ceiling be the common ancestor of the actor with the noun;
localCeiling <-
if actorHolder == nounHolder
then return actorHolder
else
do
acHier <- getContainingHierarchy s
nounHier <- getContainingHierarchy (getTaggedObject v)
-- we can cheat doing a proper lowest common ancestor. we can take one of the hierarchies
-- (which one is irrelevant), and find the earliest possible match in the other list
let commAncestor (l1h :| l1s) l2 = if l1h `elem` l2 then l1h else commAncestor
(case l1s of
[] -> error "no common ancestor"
x:xs -> x :| xs) l2
return $ commAncestor acHier nounHier
-- if the holder of the actor is the holder of the noun, continue the action;
when (actorHolder == nounHolder) $ throwError ContinueAction

-- while the holder of the actor is not the local ceiling:
whileM (error "") $ do
actor <- refreshThing s
--let the current home be the holder of the actor;
currentHome <- getObject $ thingContainedBy actor
-- if the player is the actor:
whenPlayer s $
-- if the current home is a supporter or the current home is an animal:
ifM (isSupporter currentHome ||^ isAnimal currentHome)
-- say "(getting off [the current home])[command clarification break]" (A);
[saying|(getting off {the currentHome}#{paragraphBreak})|]
-- otherwise:
-- say "(getting out of [the current home])[command clarification break]" (B);
[saying|(getting out of {the currentHome}#{paragraphBreak})|]
-- silently try the actor trying exiting;
void $ parseAction ((actionOptions a) { silently = True }) [] "exit"
actor' <- refreshThing s
let actorHolder' = thingContainedBy actor'
-- if the holder of the actor is the current home, stop the action;
when (actorHolder' `objectEquals` currentHome) $ throwError StopAction
-- if the holder of the actor is the noun, stop the action;
when (actorHolder' `objectEquals` v) $ throwError StopAction
-- if the holder of the actor is the holder of the noun, continue the action;
when (actorHolder' `objectEquals` nounHolder) $ throwError StopAction


{-
let the target be the holder of the noun;
if the noun is part of the target, let the target be the holder of the target;
while the target is a thing:
if the holder of the target is the local ceiling:
if the player is the actor:
if the target is a supporter:
say "(getting onto [the target])[command clarification break]" (C);
otherwise if the target is a container:
say "(getting into [the target])[command clarification break]" (D);
otherwise:
say "(entering [the target])[command clarification break]" (E);
silently try the actor trying entering the target;
if the holder of the actor is not the target, stop the action;
convert to the entering action on the noun;
continue the action;
let the target be the holder of the target;
-}
rulePass

cantEnterClosedContainers :: (WithPrintingNameOfSomething wm, WMWithProperty wm Container) => EnteringRule wm
cantEnterClosedContainers = makeRule "can't enter closed containers rule" [] $ \a@Args{source=s, variables=v} -> do
cantEnterClosedContainers = makeRule "can't enter closed containers rule" [] $ \Args{source=s, variables=v} -> do
let asC = getContainerMaybe (getTaggedObject v)
t <- getThing v
--if the noun is a closed container:
Expand Down
4 changes: 4 additions & 0 deletions yaifl/src/Yaifl/Model/Action.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,7 @@ module Yaifl.Model.Action
, WrappedAction(..)
, ParseArgumentEffects
, ParseArgumentResult(..)
, ActionInterrupt(..)
, addAction
, makeActionRulebook
, actionName
Expand Down Expand Up @@ -103,6 +104,9 @@ data OutOfWorldAction wm = OutOfWorldAction
-- their arguments to be pre-verified; this allows for the passing of state.
type ActionRulebook wm ac v = Rulebook wm ((:>) (Reader ac)) (Args wm v) Bool
type ActionRule wm ac v = Rule wm ((:>) (Reader ac)) (Args wm v) Bool

data ActionInterrupt = ContinueAction | StopAction

makeFieldLabelsNoPrefix ''Action

-- | Get the name of an action. This is mostly here to avoid overlapping instances with label optics and duplicate fields.
Expand Down
1 change: 1 addition & 0 deletions yaifl/src/Yaifl/Model/Rules/Rulebook.hs
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,7 @@ import Yaifl.Model.Query
import Yaifl.Model.WorldModel
import Yaifl.Model.Kinds.Object
import Yaifl.Model.Metadata
import Effectful.Error.Static (Error)

newtype RuleLimitedEffect wm es a = RuleLimitedEffect (SayableValue (WMText wm) wm => Display (WMText wm) => Eff (es : ConcreteRuleStack wm) a)

Expand Down
15 changes: 14 additions & 1 deletion yaifl/src/Yaifl/Prelude.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,8 @@ module Yaifl.Prelude
, module Effectful.Optics
, module Named
, module Data.Text.Display
, whileM
, And
) where

import Solitude
Expand All @@ -16,4 +18,15 @@ class Pointed s where
identityElement :: s

instance {-# OVERLAPPABLE #-} Monoid m => Pointed m where
identityElement = mempty
identityElement = mempty

whileM :: Monad m => (a -> Bool) -> m a -> m a
whileM pr f = do
a <- f
if pr a then whileM pr f else return a


type And :: ([k] -> Constraint) -> ([k] -> Constraint) -> [k] -> Constraint

class And c1 c2 l
instance (c1 l, c2 l) => And c1 c2 l

0 comments on commit 5e44d8b

Please sign in to comment.