Yaifl - Yet Another Interactive Fiction Library

Yaifl is a library for writing interactive fiction ("text adventures") in Haskell. It is heavily based off Inform7 in terms of the semantic structure (things and rooms, rulebooks, the tests). I doubt anyone will ever choose this over Inform7 -- or Twine, TADS, etc. -- to actually produce a work of IF; so in this regard, this is more of a fiddle-toy than intended to be a platform for making games.

The internals of Inform are not the easiest to pick apart. Even with the wonderful literate programming style (which was the inspiration for me to write this 'book'), it's a tangled web of interlocking pieces that aren't easy to find something in. A large amount of the documentation is specifically about trying to strong-arm literate English into something a computer can understand. Plus, I want to avoid a handful of Inform's restrictions at a fundamental level (e.g. objects are considered entirely unique).

To this extent, Yaifl is less of a library for writing pieces of interactive fiction and more for fiddling about with text adventure world models. A lot of weird things are done due to the limitations of the language itself and its targets (i.e. the Z-Machine, or Glulx). For example, did you know that the action to look makes a table of every item in the entire game?

Why this book?

I found I was trying to be a good samaritan and document my code, but given that the library works more in vague ideas than function signatures, Haddock comments weren't ideal. Plus the structure of how the code needs to be to compile with all its module dependencies is different to how I want to read my own documentation, and also different to how I want to present my work if anyone finds it interesting.

As an aside, I also I wanted to try this whole "literate programming" thing. The main reason I hadn't looked into it more before was the large brick wall of getting a build system up as well as dealing with separating literate source from compilable/editable source. I doubt anyone will read this book except me, but I saw Entangled presented at a talk and it seemed a cool idea I wanted to try.

The Tech

This is a brief overview of some of the pieces that I've used to make this project.

The Model

Pretty much a clone of Inform7 semantically, but with less flexibility at runtime -- the world model structure is fully defined at compile time, so adding new objects is easy during play but adding new kinds is not -- in exchange for nicer handling of the world model as a collection of possibly uninteresting objects (rather than a small, but very explicit set of 'interesting' ones).

Haskell

Mostly it's optics (as my lens package of choice), cleff (as my effects/mtl replacement package of choice) and sandwich (as my test framework of choice).

Literate Programming

entangled

The Book

mdBook

Structure of the book

It's not quite one module per page, but it's close. The aim is to start with the foundations of the library (basic types and building blocks) and then develops the object model followed by the properties (things that make it interesting) and then actions and rulebooks (making the simulation do things). Finally, there is an overview of all the tests.

Cabal, Extensions, Dependencies

This is probably a pretty dull page, so if you only care about the interesting stuff you can skip it. But I wanted to do this literate programming thing properly, and also it ensures I know what's going on in my .cabal files.

Metadata

Everything here is fairly standard project information.

cabal-version:   3.0
name:            yaifl
version:         0.0.0.1
synopsis:        Yet another interactive fiction library.
description:     Yet another interactive fiction library.
homepage:        https://github.com/PPKFS/yaifl
bug-reports:     https://github.com/PPKFS/yaifl/issues
license:         MIT
author:          Avery
maintainer:      Avery <thecommunistduck@hotmail.co.uk>
copyright:       2022 Avery
category:        Game Development
build-type:      Simple
tested-with: GHC == 9.0.2

source-repository head
  type:     git
  location: https://github.com/PPKFS/yaifl.git

Dependencies

This is a pretty standard dependency list.

common common-options
  build-depends:
      base
    , containers
    , template-haskell
    , text
    , text-display
    , solitude
    , cleff
    , cleff-plugin
    , time

I still have no idea why the first 4 of these aren't in base. solitude is my personal prelude, which is mostly re-exports of the excellent relude alternative prelude and also some optics-lens things.

    , display
    , prettyprinter
    , prettyprinter-ansi-terminal

display is for being technically lawful with Show instances when it comes to logging and for making pretty error messages. I would also like to re-add chapelure but I've not quite found the use-case (maybe in the test suite). prettyprinter gives nicer string formatting options.

    , aeson
    , katip
    , enummapset
    , haskell-src-meta
    , haskell-src-exts

• enummapset is a nice set of wrappers for using Enum keys in IntMaps for better performance (i.e. Entity).

• haskell-src-* I use because writing well-formed TH is hard, and I wanted to just write Haskell strings with text substitutions in.

• katip is only currently used because it has excellent time formatting, but it's a bit heavy for that purpose.

GHC extensions

  ghc-options:
    -Wall -Wcompat -Widentities -Wredundant-constraints 
    -fhide-source-paths -Wno-unused-top-binds
    -Wmissing-deriving-strategies -O2 -flate-specialise
    -fspecialise-aggressively -fprint-potential-instances
    -fno-warn-unused-do-bind -haddock -fwrite-ide-info
    -fplugin=Cleff.Plugin
  default-language:   Haskell2010
  default-extensions:
    NoImplicitPrelude
    BlockArguments
    DataKinds
    DerivingStrategies
    FunctionalDependencies
    LambdaCase
    MultiWayIf
    OverloadedStrings
    TypeFamilies
    TypeApplications
    ConstraintKinds
    FlexibleInstances
    FlexibleContexts
    GeneralisedNewtypeDeriving
    DeriveGeneric
    DeriveTraversable
    StandaloneDeriving
    RankNTypes
    ScopedTypeVariables
    BangPatterns
    GADTs
    TypeOperators
    DerivingVia

We enable a whole bunch of options and extensions. Notably NoImplicitPrelude makes it easier than fiddling with mixins for using solitude over Prelude, BlockArguments for my love of using inline do blocks, and TypeFamilies because I like to try and be smarter than I am.

Library stanza

library
  import:          common-options
  hs-source-dirs:  src
  exposed-modules:
    Yaifl

    --Yaifl.Actions.Action
    --Yaifl.Actions.Going
    --Yaifl.Actions.Looking

    --Yaifl.Activities.Activity
    --Yaifl.Activities.ChoosingNotableLocaleObjects
    --Yaifl.Activities.DescribingLocale
    --Yaifl.Activities.PrintingADarkRoom
    --Yaifl.Activities.PrintingDescriptionOfADarkRoom
    --Yaifl.Activities.PrintingLocaleParagraphAbout
    --Yaifl.Activities.PrintingNameOfSomething

    --Yaifl.ActivityCollection
    Yaifl.Common
    Yaifl.Directions
    Yaifl.Logger

    Yaifl.Objects.Create
    Yaifl.Objects.Dynamic
    Yaifl.Objects.Move
    Yaifl.Objects.Object
    Yaifl.Objects.ObjectData
    Yaifl.Objects.Query
    Yaifl.Objects.Room
    Yaifl.Objects.Specifics

    Yaifl.Properties.Container
    Yaifl.Properties.Enclosing
    Yaifl.Properties.Openable
    Yaifl.Properties.Property
    Yaifl.Properties.Query
    --Yaifl.Properties.Supporter
    Yaifl.Properties.TH

    --Yaifl.Rulebooks.ActionProcessing
    --Yaifl.Rulebooks.Args
    --Yaifl.Rulebooks.Rulebook
    --Yaifl.Rulebooks.WhenPlayBegins

    Yaifl.Say
    Yaifl.World

Test stanza

• neat-interpolation makes wrapped raw string quasi-quotes better, which is important given how many room descriptions are very long lines of text.
• sandwich is a really sweet looking testing library so I wanted to try it.
• conduit I needed because of MonadThrow constraints for sandwich's shouldBe.

test-suite yaifl-test
  import:             common-options
  type:               exitcode-stdio-1.0
  hs-source-dirs:     test
  main-is:            Spec.hs
  build-depends:
    , sandwich
    , conduit
    , yaifl
  ghc-options:        -threaded -rtsopts -with-rtsopts=-N
  default-extensions:
    QuasiQuotes
    TemplateHaskell

  other-modules:
    Yaifl.Test.Chapter3.Bic
    Yaifl.Test.Chapter3.Common
    --Yaifl.Test.Chapter3.Verbosity
    Yaifl.Test.Common

Effects

Extensible (or algebraic) effects are cool, but I don't want to get into depth here and equally I cannot because I am too dumb. The jist of them is instead of a fixed ordering of monads which you can add MonadFoo constraints to ala mtl:

f :: (MonadIO m, MonadBar m) => m a

You instead write GADTs with some type wizardry to achieve the same thing as typeclasses. The major advantage is that you can interpret these in multiple different ways (consider a logging effect that can be chosen to be viewed as an IO computation, or a pure ignore effect) and you don't need to deal with the O(n^2) instance problem:

data Bar m a where
  Log :: String -> Bar m ()
  SomethingElse :: Bool -> Int -> Bar m a

runBarAsIO :: ...

runBarAsPure :: ...

Why effects and not mtl?

The main reason is because effect frameworks are cool.

Yaifl.Say

This is just a riff on every Teletype example that seems to be standard with effect frameworks. It's slightly more involved than the logging effect because we have conditional saying as well as formatting to keep track of.

{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Say
  ( -- * Types
    MessageBuffer (..)
  -- * Smart constructors
  , blankMessageBuffer
  -- * Buffer modification
  , setStyle
  , say
  , sayLn
  , sayIf

  , msgBufBuffer
  )
where

import Cleff.State ( State, get, modify )
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Terminal as PPTTY
import Solitude

type StyledDoc = PP.Doc PPTTY.AnsiStyle

data Saying :: Effect where
  SayDoc :: StyledDoc -> Saying m ()

data MessageBuffer = MessageBuffer
  { _msgBufBuffer :: [StyledDoc] -- ^ Current messages held before flushing.
  , _msgBufStyle :: Maybe PPTTY.AnsiStyle -- ^ Current formatting; 'Nothing' = plain.
  , _msgBufContext :: [StyledDoc] -- ^ Possibly nested prefixes before every message.
  }

<<say-helpers>>
<<interpret-say>>

<<say-functions>>

We define our Effect to take a pretty-printed document. This does mean we almost never use the effect directly, but still. We also hold onto some message context - a style and some additional "preface every entry with this" text. If we're using the IO interpretation, then we just leave the buffer blank.

blankMessageBuffer :: MessageBuffer
blankMessageBuffer = MessageBuffer [] Nothing []

makeEffect ''Saying
makeLenses ''MessageBuffer

Interpreting SayDoc

Both interpreters do very similar things, with the difference being where the output ends up. We need a MessageBuffer to be present in the effect stack regardless to pre-process the doc by setting the style and amending any context.

processDoc ::
  State MessageBuffer :> es
  => StyledDoc
  -> Eff es StyledDoc
processDoc msg = do
  (MessageBuffer _ style cxt) <- get
  -- if we have no context, we just monoid it.
  let joinOp = case cxt of
        [] -> (<>)
        _ -> (PP.<+>)
  return $ PP.hcat cxt `joinOp` maybe id PP.annotate style msg

<<interpret-say-pure>>
<<interpret-say-io>>

And we can then interpret a SayDoc by amending to the buffer:

class Has s t where
  buf :: Lens' s t

type PartialState s t es = (Has s t, State s :> es)

runSayPure ::
  forall s es. 
  PartialState s MessageBuffer es
  => Eff (Saying : es)
  ~> Eff es
runSayPure = zoom (buf @s @MessageBuffer) . reinterpret \case
  SayDoc doc -> do
    r <- processDoc doc
    modify (\s -> s & msgBufBuffer %~ (r:))

or by dumping straight to stdout:

runSayIO ::
  IOE :> es
  => PartialState s MessageBuffer es
  => Eff (Saying : es)
  ~> Eff es
runSayIO = zoom (buf @_ @MessageBuffer) . reinterpret \case
  SayDoc doc -> do
    r <- processDoc doc
    print r

Actually saying things

And now we can write our say functions independent of whether we're in a pure or IO context. There's a handful of variations just because it's easier to do it all here.

-- | Say a string (well, Text).
say :: 
  Saying :> es 
  => Text -- ^ Message.
  -> Eff es ()
say = sayDoc . PP.pretty

-- | Say @message@ with a newline.
sayLn :: 
  Saying :> es 
  => Text -- ^ Message.
  -> Eff es ()
sayLn a = say (a <> "\n")

-- | Conditionally say @message@.
sayIf :: 
  Saying :> es 
  => Bool -- ^ Condition to evaluate.
  -> Text -- ^ Message.
  -> Eff es ()
sayIf True = say
sayIf False = const pass

-- | Update the style of a message buffer. Setting to 'Just' overwrites the style,
-- | whereas 'Nothing' will remove it. This will not affect previous messages.
setStyle :: 
  forall s es. 
  PartialState s MessageBuffer es
  => Maybe PPTTY.AnsiStyle -- ^ The updated style.
  -> Eff es ()
setStyle s = buf @s @MessageBuffer % msgBufStyle .= s

{-
-- | Clear a message buffer and return the container (with a clean buffer)
-- with all formatting (e.g. ANSI colour codes) *included*.
flushBufferToStdOut :: 
  MonadIO m
  => HasBuffer w p 
  => Proxy p
  -> w
  -> m w
flushBufferToStdOut prox w = do
  let output' = (PPTTY.putDoc (comboBuffer w prox), w & bufferL prox % msgBufBuffer .~ [])
  liftIO $ fst output'
  return (snd output')
  where
    comboBuffer d' p' = PP.hcat $ reverse $ d' ^. bufferL p' % msgBufBuffer
-}

Logging

With the move from mtl to cleff, it was probably less effort to just write my own logging effect than to find how to get e.g. co-log working with an arbitrary effects system. Plus, I don't need that much of the fancy stuff it does? I just want a context and to write to many different places.

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Logger where

import Solitude hiding ( trace, local, asks, Reader, runReader )
import Language.Haskell.TH ( Loc(..) )
import qualified Data.Text.Lazy.Builder as TLB
import Cleff.Trace ( trace, Trace )
import Cleff.Reader ( Reader, asks, local )
import Data.Text.Display ( display, Display, ShowInstance(..) )
import GHC.Stack
import Data.Time ( getCurrentTime, UTCTime )
import qualified Data.Aeson as A
import qualified Data.Text as T
import Katip.Format.Time ( formatAsLogTime )

<<log-effect>>
<<log-interpreters>>
<<log-functions>>
<<callstack-log>>
<<log-item>>

Logging Effect

We only need two functions here, one to log a message of any severity (optionally with a callstack, stolen from katip) and another to make a contexted block (so we can have [Some][Context][Here] at the start of our lines in a hierarchal way).

data MsgSeverity = Debug | Info | Warning | Error
  deriving stock (Eq, Ord, Enum, Bounded, Show)
  deriving (Display) via (ShowInstance MsgSeverity)

data Log :: Effect where
  LogMsg :: Maybe Loc -> MsgSeverity -> Text -> Log m () 
  WithContext :: Text -> m a -> Log m ()

makeEffect ''Log

Interpreters

There already exist 3 different output-like effects in cleff; Output (for arbitrary o), Trace (which says it's for debugging logs), and Writer (which is even more general still). For the most flexibility, it's best to reinterpret our logging as a Trace effect (which has built-in interpreters to produce Writers or Outputs) with a Reader for the logging context. Of course, we may not want this Reader in the case we won't use it for anything (ignoring output) so we write our own ignore interpreter.

runAndIgnoreLogging :: 
  Eff (Log : es) 
  ~> Eff es
runAndIgnoreLogging = interpret \case
  LogMsg _ _ _ -> pass
  WithContext _ m -> toEff $ void m

runLoggingAsTrace :: 
  [Reader [Text], IOE] :>> es 
  => Eff (Log : es) 
  ~> Eff (Trace : es)
runLoggingAsTrace = reinterpret \case
  LogMsg mbLoc sev msg -> do
    now <- liftIO getCurrentTime
    cxt <- asks reverse
    trace $ makeJSONObject now cxt sev mbLoc msg
  WithContext cxt m -> void $ local (cxt:) (toEff m)

makeJSONObject :: UTCTime -> [Text] -> MsgSeverity -> Maybe Loc -> Text -> String
makeJSONObject now cxt sev mbLoc pl = (decodeUtf8 $ A.encode $
  YaiflItem
  { itemSeverity = display sev
  , itemLoc = mbLoc
  , itemMessage = pl
  , itemTime = now
  , itemContext = cxt
  })

Extracting callsite info

We try to extract the last callsite from some GHC CallStack and convert it to a Loc.

toLoc :: 
  CallStack
  -> Maybe Loc
toLoc stk = (listToMaybe . reverse $ getCallStack stk) <&> \(_, loc) -> 
  Loc
    { loc_filename = srcLocFile loc,
      loc_package = srcLocPackage loc,
      loc_module = srcLocModule loc,
      loc_start = (srcLocStartLine loc, srcLocStartCol loc),
      loc_end = (srcLocEndLine loc, srcLocEndCol loc)
    }

Logging Functions

Each of our logging functions is a more concise way to log with a set severity and a callstack. This is inherently a structured logging format (perhaps in the future it'd be better to have the option of plaintext logging rather than explicitly and only JSON formatting) but JSON is what works nicely with lnav.

logInternal ::
  HasCallStack
  => Log :> es
  => MsgSeverity
  -> TLB.Builder
  -> Eff es ()
logInternal sev msg = logMsg (toLoc callStack) sev (toText $ TLB.toLazyText msg)

debug :: 
  HasCallStack
  => Log :> es
  => TLB.Builder
  -> Eff es ()
debug = logInternal Debug

info :: 
  HasCallStack 
  => Log :> es
  => TLB.Builder
  -> Eff es ()
info = logInternal Info

warn :: 
  HasCallStack 
  => Log :> es
  => TLB.Builder
  -> Eff es ()
warn = logInternal Warning

err :: 
  HasCallStack 
  => Log :> es
  => TLB.Builder
  -> Eff es ()
err = logInternal Error

Structured logging, at last

So we have everything done except the middle piece of glue that turns a logging message (probably with a callstack) into a JSON object. We need to relativise the filename to just Foo.hs and build the JSON object.

We use katip just because it has really nice time formatting that is nontrivial to repeat.

reshapeFilename :: 
  Loc 
  -> String
reshapeFilename Loc{..} = drop 1 (dropWhile (/= '/') loc_filename) <> ":" <> show (fst loc_start) <> ":" <> show (snd loc_start)

data YaiflItem = YaiflItem
  { itemSeverity :: Text
  , itemMessage :: Text
  , itemTime :: UTCTime
  , itemContext :: [Text]
  , itemLoc :: Maybe Loc
  } deriving stock (Show, Eq)

instance A.ToJSON YaiflItem where
    toJSON (YaiflItem{..}) = A.object $
      [ "level" A..= itemSeverity
      , "message" A..= itemMessage
      , "timestamp" A..= formatAsLogTime itemTime
      , "ns" A..= let f = T.intercalate "➤" (filter (/= T.empty) $ itemContext) in if T.empty == f then "" else "❬"<>f<>"❭"
      , "loc" A..= fmap reshapeFilename itemLoc
      ]

The World Model

The WorldModel encompasses the spatial object model, as Inform's literate source puts it. This provides us with everything to specify the layout of the game world, the objects within it, and properties they have. For instance, Things and their name and description and Rooms having mapConnections.

Sections

• WorldModel and WMx Type Families - A neat trick to allow us to extensively parameterise our universes of types (Objects, Directions, Values, etc) without having to write out a dozen type parameters.
• The World State - The record type that holds the game state.
• Objects - Entity, Object, Store and how these three types form the backbone of the lookup model.
  • Entities and Stores - Spoilers: newtype wrappers around Ints and newtype wrappers around newtype wrappers around IntMap and making it slightly less painful to deal with object lookups.
  • Objects, Things and Rooms - Probably the most important part, actual game objects.
  • Reification - Dealing with dynamic objects, because doing things as text substitutions is kind of awkward.
  • ObjectLike - Some helpers for things which act a bit like Objects, but aren't actually Objects (necessarily).
  • Object Specifics and Object Data - The section that I could never remember the order of, the components that make Things things (ObjectData) and Supporters supporters (ObjectSpecifics).
• Properties - Smaller parts of ObjectSpecifics that can be shared by many types of Object.
  • Get, Set, Modify - TemplateHaskell to define our lookup functions.

WorldModel and WMx Type Families

The problem

One thing that has repeatedly annoyed me when trying to hack around on yaifl is the desire to be as general as possible, but whilst doing my best to avoid writing imperative code but in Haskell. One of these major headscratching problems was how to have something akin to extensible records but in a more Haskell-y way. For instance, take object types. We can provide a standard library of Thing, Room, Door, Person, Vehicle, etc. just fine; but what if we want to have a Gate? In an OO- language this is fine - just inherit from Door. In Haskell we can approximate this in the same way Parsec deals with its error types:

data ObjectType a = ThingType Thing | DoorType Door | RoomType Room ... | Other a

And we are then open (as long as the user supplied a satisfies constraints that we impose, such as Show or Eq) to extensionality but closed at compile time. This has the drawback that if you want this open-closed hierarchy on many types of data, you have a monolithic state that looks something like MonolithicState a b c d e f g:

• We want horizontally extendable object types, so we can start with MonolithicWorld objType. All cool.
• Now we want directions; whilst the compass points are probably fine for nearly every game, sometimes you might want to have turnwise or widdershins. Now you have MonolithicWorld objType directionType.
• What about arbitrary data variables you want to keep track of during the game? Now you've got MonolithicWorld objType directionType variableRecord.
• And so on.

Chances are that most of those are going to be () - you don't want extra directions, or you don't define a special kind of door - but it's a huge pain to write out multiple times for each function signature.

We could work in an mtl-style way of component instances and typeclasses:

data MonolithicWorld s = MonolithicWorld
  { ...
  , worldData :: s
  }

data WorldData a b c d e f g = WorldData
  { things :: Store (Object a)
  , directions :: Store (Direction b)
  ...
  -- and so on
  }

class HasThings s a where
  things :: Lens' (MonolithicWorld s) (Store (Object a))

class HasDirections s b where
  directions :: Lens' (MonolithicWorld s) (Store (Direction b))

But this quickly ran into the same problem; a function that dealt with both Directions and Objects still needs both a and b to be parametric, and these constraints bubbled up to the top...plus, I'd often get ambiguous type variable a1 issues.

What if there was a way to do this with some type-level nonsense?

The WorldModel type families

Behold, a whole bunch of random Types!

data WorldModel = WorldModel Type Type Type Type

By using DataKinds, we can promote this to the type level. We can now start making types that look like

data SomeExtraObjTypes = GateType Gate
type Score = Int
type AWorldModel = 'WorldModel SomeExtraObjTypes () () Score

which is great; we can parameterise everything by (wm :: WorldModel), and now we have only one type variable instead of 4 (or more)! But record field accessors don't work at the type-level (F in chat), so we need to write a little boilerplate:

type family WMObjSpecifics (wm :: WorldModel) :: Type where
  WMObjSpecifics ('WorldModel objSpec dir o v) = objSpec

type family WMDirections (wm :: WorldModel) :: Type where
  WMDirections ('WorldModel objSpec dir o v) = dir 

type family WMValues (wm :: WorldModel) :: Type where
  WMValues ('WorldModel objSpec dir o v) = o

How does this work? Without doing a terrible job of massacring an explanation of how type families work, we can view these as very basic dependent types; given some type instantiation of wm :: WorldModel, we have an associated type WMObjSpecifics that is defined by the first member of that type. Now, rather than ever referring to the objSpec we can refer to WMObjSpecifics wm. Everything is unified and there's no unnecessary typeclass baggage, rejoice!

Well, there is one slight issue - this breaks GHC's deriving machinery. Types that contain a WMFoo wm have to instead use quantified instance derivations; for instance we may need to define an Ord instance like

deriving stock instance (Ord (WMDirections wm), Ord (WMObjSpecifics wm)) => Ord (FooBar wm)

which gets minorly annoying. But thanks to ConstraintKinds we can write some tidy helper types.

type WMConstr (c :: Type -> Constraint) wm = (c (WMObjSpecifics wm), c (WMValues wm), c (WMDirections wm))
type WMShow wm = WMConstr Show wm
type WMRead wm = WMConstr Read wm
type WMOrd wm = WMConstr Ord wm
type WMEq wm = WMConstr Eq wm

Objects

This chapter contains 3 main parts:

• Entities - An ID that allows us to circumvent immutability by breaking apart references between objects.
• Stores - Maps of Entitys to various objects.
• Objects - Game objects, spanning from the physical (keys, doors, people) to the intangible (rooms, etc).

Between these 3, we can construct (with some difficulty) a world model that can represent some domain of IF, but not one that can be interacted with -- yet.

Brief comments on some other systems

There's certainly a couple of other ways to approach this idea (that aren't "just write in OOP"), which I figured were worth mentioning.

• Entity-component systems (ECS) - these are certainly doable in Haskell - ecstasy and apecs come to mind, and to some degree we are designing an ECS that cannot change at runtime - but it's not great because the semantic approach is that you want to iterate over sets of components and less so care about what they are attached to -- this is the exact opposite to a text adventure (where you rarely care about all doors or vehicles or whatever, rather just a specific one).
• Ad-hoc, extensible records - By which I mean some sort of system where there is no distinction between discrete classes of kinds, but rather everything is an anonymous record (plus/minus some type-wizardry) with named fields. This would probably be a good option, but I felt it un-idiomatic.

Aims of the Entity/Store/Model structure

• Everything should be Haskell-ish. Whilst the use of lens (or in this case, optics) is almost a given for a program that works so heavily on nested data structure modification, and it being a "game" implies the existence of some monolithic state, I would like to be able to work in pure functions where possible.
• Everything should be extensible with minimal effort. Any more direct way to include such semantics as "A thing can be sticky or not sticky. A thing is usually sticky" as modifying the very concept of a Thing is getting into dynamic typing territory. Rather, by utilising smart constructors, we can write simple wrappers of makeStickyThing that use ObjectSpecifics that look like (Stickiness, a) and voila, we have redefined every Thing in the program. NB: this does mean there needs to be some care taken when we automatically generate objects and rooms (the player, the void).
• Type safety. It makes no sense to call move on a Room and a Scenery, for instance.

Entities and Stores

By decentralising references between objects and instead storing some kind of ID and some kind of Map ID Object, we can avoid mutable state. Hooray!

Entities

newtype Entity = Entity
  { unID :: Int
  } deriving stock   (Show, Generic)
    deriving newtype (Eq, Num, Read, Bounded, Hashable, Enum, Ord, Real, Integral)

A newtype wrapper around Int. Yup, that's about it. One nice feature is that we can, under the assumption that nobody does something strange (like turning a Thing into a Room), determine whether a given Entity refers to a Thing or a Room by whether we generated the ID by counting up or down:

isThing ::
  (HasID a)
  => a
  -> Bool
isThing a = getID a >= 0

isRoom ::
  (HasID a)
  => a
  -> Bool
isRoom = not . isThing

It's also nice to have a way to always get an Entity from a construct:

class HasID n where
  getID :: n -> Entity

instance HasID Entity where
  getID = id

instance Display Entity where
  display (Entity i) = "ID: " <> show i

We also then reserve a few IDs for the 'default' objects which we never want to see at runtime, but need at construction time to avoid unnecessary Maybes.

defaultVoidID :: Entity
defaultVoidID = Entity (-1)

defaultNothingID :: Entity
defaultNothingID = Entity 0

defaultPlayerID :: Entity
defaultPlayerID = Entity 1

Stores

A Store is a map from Entitys to as. Usually this is some flavour of Object wm d, but we can also use Store (Entity, Payload) for relations and things like that. Of course, since I've refactored the direct link of a Map-based store to a specific interpretation of the world's effects, this seems slightly out of place. But it's fairly obvious as the go-to implementation so it may as well stay here.

-- import qualified Data.EnumMap.Strict as EM
newtype Store a = Store
  { unStore :: EM.EnumMap Entity a
  } deriving stock   (Show, Generic)
    deriving newtype (Eq, Ord, Read)

emptyStore :: Store a
emptyStore = Store EM.empty

EnumMap and Optics

EnumMap (and its sibling EnumSet) are nice convenient newtype wrappers around IntMap, but they're not quite cut out for a) further newtype wrappers around them, and b) the instances for nice Lens/Optics things.

First let's define our own alterF for EnumMap and then another for a newtype wrapper...

alterEMF :: 
  (Functor f, Enum k)
  => (Maybe a -> f (Maybe a))
  -> k
  -> EM.EnumMap k a 
  -> f (EM.EnumMap k a)
alterEMF upd k m = EM.intMapToEnumMap <$> IM.alterF upd (fromEnum k) (EM.enumMapToIntMap m)

alterNewtypeEMF :: 
  (Functor f, Enum k)
  => (Maybe a -> f (Maybe a))
  -> k
  -> (nt -> EM.EnumMap k a)
  -> (EM.EnumMap k a -> nt)
  -> nt
  -> f nt
alterNewtypeEMF upd k unwrap wrap' m = wrap' <$> alterEMF upd k (unwrap m)

Which we can now use for a nice and tidy At instance.

instance At (Store a) where
  at k = lensVL $ \f -> alterNewtypeEMF f k unStore Store

Finally, we choose the obvious instantiations for the associated index types.

type instance IxValue (Store a) = a
type instance Index (Store a) = Entity
instance Ixed (Store a)

Which means we can now write use our lenses as someStore ^? at someEntity rather than someStore ^? coercedTo @(EnumMap Entity a) % to unStore % at someEntity, or some other verbose beast.

Objects

And now we turn to the final of the foundational parts of the world model, the Object. Whilst we don't go quite as far as Inform does, where everything is an object of some kind (including directions, or if you wanted to extend the system with ideas such as people having knowledge of something), we still consider most things in a game to be an Object of some kind. These can be split into two categories; Things (physical, interactable, objects) and Rooms (spaces to be moved between).

Each of these can be further divided into more specific instances, but it is significantly simpler to deal with everything being either a realisable object or a space, and treat the very few intangible objects as their own specific thing (for example, directions). The obvious downside of this is that we have to treat directions specially -- but since when has anyone written a piece of IF where they need to invent new directions at runtime?

First we have the overview of the module.

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Yaifl.Objects.Object ( 
  -- * Types
  ObjType(..)
  , Object(..)
  , Thing
  , Room
  , AnyObject
  -- * Object Helpers
  , objectEquals
  -- * Lenses
  , objName, objDescription, objID, objType
  , objCreationTime, objSpecifics, objData
  -- * Prisms
  , _Room, _Thing ) where

import Solitude
import Yaifl.Common ( WMObjSpecifics, Timestamp, HasID(..), Entity )
import Yaifl.Objects.ObjectData ( RoomData, ThingData )
import Yaifl.Objects.Specifics ( ObjectSpecifics )

<<obj-type>>
<<thing-room-anyobject>>
<<obj-definition>>
<<obj-hasid>>
<<obj-eq>>
makeLenses ''Object
<<obj-functor>>

<<obj-prisms>>
<<can-be-any>>

And the object type itself:

data Object wm objData = Object
  { _objName :: !Text
  , _objDescription :: !Text
  , _objID :: !Entity
  , _objType :: !ObjType
  , _objCreationTime :: !Timestamp
  , _objSpecifics :: !(Either ObjectSpecifics (WMObjSpecifics wm))
  , _objData :: !objData
  } deriving stock (Generic)

deriving stock instance (Show (WMObjSpecifics wm), Show d) => Show (Object wm d)
deriving stock instance (Read (WMObjSpecifics wm), Read d) => Read (Object wm d)

So there's a handful of things here:

• Objects are parameterised by two type parameters; wm :: WorldModel, which we use to define the extensions of ObjectSpecifics (to be discussed below), and objData, which will always be one of 3 types:
  • ThingData wm, and we have a Thing;
  • RoomData wm, and we have a Room;
  • Either (ThingData wm) (RoomData wm), and we have no idea which so we call it AnyObject. ThingData and ObjectData are covered in the next section
• Yes, everything is prefixed with an underscore because we use a lot of lens TH generation.
• This is the first of many standalone deriving instances. Will we ever need Read (Object wm d)? Probably not, but still.

Some useful instances

Obviously we can get an ID out of an Object:

instance HasID (Object wm d) where
  getID = _objID

The other obvious missing one is Eq; if we automatically derive Eq, we can only compare objects with the same objData type -- so no comparison at all of Rooms and Things (even if that's always False) or even Things and AnyObjects (which may be true). So we write our own that is slightly more lenient on the types, and Ord too even though it makes no sense.

objectEquals :: 
  Object wm d
  -> Object wm d'
  -> Bool
objectEquals = (. _objID) . (==) . _objID

instance Eq (Object wm d) where
  (==) = objectEquals

-- | Maybe I'll need this instance for something or other? 
instance Ord (Object wm d) where
  compare = (. _objID) . compare . _objID

Another fairly useful set of instances that don't make a huge amount of sense for anything other than ease of use: Functor, Foldable, and Traversable. All 3 work over objData, so the primary use is to go back-and-forth from AnyObject.

instance Functor (Object wm) where
  fmap :: 
    (a -> b)
    -> Object wm a
    -> Object wm b
  fmap f = objData %~ f

instance Foldable (Object wm) where
  foldMap :: 
    (a -> m)
    -> Object wm a 
    -> m
  foldMap f = f . _objData

instance Traversable (Object wm) where
  traverse :: 
    Applicative f 
    => (a -> f b) 
    -> Object wm a 
    -> f (Object wm b)
  traverse f o = (\v -> o {_objData = v}) <$> f (_objData o)

Object Types

ObjType may look strange given how much we are trying to avoid remaking OO here, but this use of an object "type" is more of a tag system:

newtype ObjType = ObjType
  { unObjType :: Text
  } deriving stock (Eq, Show)
    deriving newtype (Read, Ord, IsList, IsString, Monoid, Semigroup)

ObjTypes make a DAG that approximates inheritance in name only. For instance, we may wish to check that an object is a supporter for printing locale descriptions (where we want to say "on the table" rather than "in the table"). We aren't being polymorphic and imitating v-tables, or deriving properties automatically - we just note that "supporter" is a valid object type and e.g. a "display cabinet" is also a kind of supporter, and a "glass fronted display cabinet" is a kind of display cabinet and we can infer the transitive property.

Things, Rooms, AnyObjects

And at last, we can talk about Thing, Room, and AnyObject:

type Thing wm = Object wm ThingData
type Room wm = Object wm (RoomData wm)
type AnyObject wm = Object wm (Either ThingData (RoomData wm))

Lenses and Prisms

For the most part I'm omitting fluff like makeLenses ''Object (if you're really interested, they will be in the full noweb file in the Reference section). However there are two very useful prisms we can define. Originally, these were their own typeclass called CanBeAny - because they looked like

toAny :: a -> b
fromAny :: b -> Maybe a

but then I realised these were just preview and review respectively. There is an equivalent for AbstractObject as well, though whether it's useful isn't yet decided.

_Room :: Prism' (AnyObject wm) (Room wm)
_Room = prism' (fmap Right) (traverse rightToMaybe)

_Thing :: Prism' (AnyObject wm) (Thing wm)
_Thing = prism' (fmap Left) (traverse leftToMaybe)

Though I keep the class around regardless, because toAny o makes more semantic sense than review _Thing.

class CanBeAny wm o where
  toAny :: o -> AnyObject wm
  fromAny :: AnyObject wm -> Maybe o

instance CanBeAny wm (Room wm) where
  toAny = review _Room
  fromAny = preview _Room

instance CanBeAny wm (Thing wm) where
  toAny = review _Thing
  fromAny = preview _Thing

instance CanBeAny wm (AnyObject wm) where
  toAny = id
  fromAny = Just

Object Querying Effects

This is an excellent example of how smaller effects mean less boilerplate over the equivalent mtl solution. I think. At least it certainly avoid the O(n^2) instances that come from having a ObjectRead, ObjectWrite, ObjectQuery, etc set of constraints.

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Objects.Query
  ( -- * Types
  ObjectLike(..)
  , MissingObject(..)
  , ObjectQuery(..)
  -- * Missing Objects
  , withoutMissingObjects 
  , failHorriblyIfMissing
  , handleMissingObject
  , NoMissingObjects
  -- * Get
  , lookupThing
  , lookupRoom
  , getObject
  , getThingMaybe
  , getRoomMaybe
  , asThingOrRoom
  -- * Modify
  , modifyObject
  , modifyThing
  , modifyRoom
  -- * Set
  , setThing
  , setRoom
  ) where

import Cleff.Error ( Error, fromEither, runError, throwError )
import Cleff.State ( State )
import qualified Data.Text.Lazy.Builder as TLB

import Solitude

import Yaifl.Common ( Metadata, WorldModel, HasID(..), Entity, isThing )
import Yaifl.Logger ( Log, err )
import Yaifl.Objects.Object ( _Room, _Thing, AnyObject, Object(_objID), Room, Thing )

<<missing-object>>
<<handle-missing-objects>>
<<object-query-effect>>
<<objectlike>>
<<objectlike-instances>>
<<get-objects>>
<<modify-objects>>

Missing Objects

It's much easier to use some kind of Error effect to avoid wrapping endless amounts of object querying in Maybe. We start with a simple payload that holds whatever object was looked for (and failed to find), and some contextual error message.

data MissingObject = MissingObject 
  { _moExpected :: Text
  , _moEntity :: Entity
  } deriving stock (Eq, Show, Read, Ord, Generic)

makeLenses ''MissingObject

withoutMissingObjects :: 
  (HasCallStack => Eff (Error MissingObject ': es) a) -- ^ the block
  -> (HasCallStack => MissingObject -> Eff es a)  -- ^ the handler
  -> Eff es a
withoutMissingObjects f def = do
  r <- runError f
  case r of
    Left err' -> def err'
    Right x -> return x

handleMissingObject :: 
  HasCallStack
  => Log :> es
  => TLB.Builder 
  -> Eff es a 
  -> MissingObject
  -> Eff es a
handleMissingObject msg def (MissingObject t o) = do
  err (msg <> bformat (stext %! "; Object ID: " %! stext) t (show o))
  def

failHorriblyIfMissing ::
  Log :> es
  => (HasCallStack => Eff (Error MissingObject ': es) a)
  -> Eff es a
failHorriblyIfMissing f = withoutMissingObjects f (\(MissingObject t o) -> do
  let msg = "Failing horribly and erroring out because we can't recover"
      emsg = msg <> bformat (stext %! "; Object ID: " %! stext) t (show o)
  err emsg
  error $ show emsg)

Object querying

And now we have the effects themselves. A write-only effect wouldn't be particularly useful, and similarly there's not a great use-case for thing-only or room-only. We return Either in the lookup functions because we have multiple possible fail cases (when we are reifying dynamic objects as well as the expected failed lookup). The Either is consumed by higher-level functions, so we probably never use lookup directly.

data ObjectQuery (wm :: WorldModel) :: Effect where
  LookupThing :: HasID o => o -> ObjectQuery wm m (Either Text (Thing wm))
  LookupRoom :: HasID o => o -> ObjectQuery wm m (Either Text (Room wm))
  SetRoom :: Room wm -> ObjectQuery wm m ()
  SetThing :: Thing wm -> ObjectQuery wm m ()

makeEffect ''ObjectQuery

type NoMissingObjects wm es = (Error MissingObject :> es, ObjectQuery wm :> es, State (Metadata wm) :> es) 

ObjectLike

A slight detour to things which are almost objects but require looking up extra information in the effect stack. This is slightly more restrictive than HasID.

class HasID o => ObjectLike wm o where
  getRoom :: NoMissingObjects wm es => o -> Eff es (Room wm)
  default getRoom :: NoMissingObjects wm es => o -> Eff es (Room wm)
  getRoom o = throwError $ MissingObject "Called getRoom on an object with no instance."  (getID o)

  getThing :: NoMissingObjects wm es => o -> Eff es (Thing wm)
  default getThing :: (NoMissingObjects wm es) => o -> Eff es (Thing wm)
  getThing o = throwError $ MissingObject "Called getThing on an object with no instance."  (getID o)

And we have the obvious instances for Objects themselves, to eliminate the Either out of an AnyObject, and the sneakily most important instance that wraps lookup with removing the fail case.

instance ObjectLike wm (Thing wm) where
  getThing = pure

instance ObjectLike wm (Room wm) where
  getRoom = pure

instance ObjectLike wm (AnyObject wm) where
  getThing t = fromEither
    (maybeToRight (MissingObject ("Tried to get a thing from " <> show (_objID t) <> " but it was a room.") (getID t))
      (preview _Thing t))
  getRoom t = fromEither
    (maybeToRight (MissingObject ("Tried to get a room from " <> show (_objID t) <> " but it was a thing.") (getID t))
      (preview _Room t))

instance ObjectLike wm Entity where
  getRoom e = lookupRoom e >>= either (throwError . flip MissingObject e) return
  getThing e = lookupThing e >>= either (throwError . flip MissingObject e) return

Most of the get functionality is in ObjectLike, but we have a couple of useful functions here:

• if we don't know the type of an object (and it's irrelevant enough to not bother querying the ID type at the call site), we can just get AnyObject.
• sometimes we don't want to throw an error or deal with NoMissingObjects blocks, so we can wrap it back into a Maybe.
• Finally we can do coproduct elimination by handling both cases of an Object.

getObject ::
  NoMissingObjects wm es
  => ObjectLike wm o
  => o
  -> Eff es (AnyObject wm)
getObject e = if isThing e
  then (review _Thing <$> getThing e)
  else (review _Room <$> getRoom e)

getThingMaybe :: 
  ObjectQuery wm :> es
  => State (Metadata wm) :> es
  => ObjectLike wm o
  => o
  -> Eff es (Maybe (Thing wm))
getThingMaybe o = withoutMissingObjects (getThing o <&> Just) (const (return Nothing))

getRoomMaybe ::
  ObjectQuery wm :> es
  => State (Metadata wm) :> es
  => ObjectLike wm o
  => o
  -> Eff es (Maybe (Room wm))
getRoomMaybe o = withoutMissingObjects (getRoom o <&> Just) (const (return Nothing))

asThingOrRoom :: 
  NoMissingObjects wm es
  => ObjectLike wm o
  => o
  -> (Thing wm -> a)
  -> (Room wm -> a)
  -> Eff es a
asThingOrRoom o tf rf =
  if isThing o
  then tf <$> getThing o
  else rf <$> getRoom o

Modifying Objects

For modifying, we have a helper function that is basically a verbose and law-breaking lens and then modifying specific objects is simply a curried version. The awkward case is modifying an AnyObject because technically the object could switch from Thing to Room in the middle but we trust that not to happen.

modifyObjectFrom :: 
  (o -> Eff es (Object wm any))
  -> (Object wm any -> Eff es ())
  -> o
  -> (Object wm any -> Object wm any)
  -> Eff es ()
modifyObjectFrom g s o u = do
  obj <- g o
  s (u obj)
  pass

modifyThing :: 
  NoMissingObjects wm es
  => ObjectLike wm o
  => o
  -> (Thing wm -> Thing wm)
  -> Eff es ()
modifyThing = modifyObjectFrom getThing setThing 

modifyRoom ::
  NoMissingObjects wm es
  => ObjectLike wm o
  => o
  -> (Room wm -> Room wm)
  -> Eff es ()
modifyRoom = modifyObjectFrom getRoom setRoom

modifyObject ::
  NoMissingObjects wm es
  => ObjectLike wm o
  => o
  -> (AnyObject wm -> AnyObject wm)
  -> Eff es ()
modifyObject e s = 
  if isThing e
  then modifyThing e (anyModifyToThing s)
  else modifyRoom e (anyModifyToRoom s)

anyModifyToThing :: 
  (AnyObject s -> AnyObject s)
  -> (Thing s -> Thing s)
anyModifyToThing f t = fromMaybe t (preview _Thing $ f (review _Thing t))

anyModifyToRoom :: 
  (AnyObject s -> AnyObject s)
  -> (Room s -> Room s)
anyModifyToRoom f t = fromMaybe t (preview _Room $ f (review _Room t))

ObjectData

This is where we differentiate between Things and Rooms. Object data is those properties which are common (and then objects are further specialised with object specifics). For instance, Rooms will always have mapConnections but never edibility.

We start with the module overview:

{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Yaifl.Objects.ObjectData
  ( -- * Things
    ThingLit(..)
  , ThingWearability(..)
  , ThingDescribed(..)
  , ThingData(..)
  , blankThingData

  -- * Rooms
  , MapConnections(..)
  , ContainingRegion(..)
  , Darkness(..)
  , RoomData(..)
  , ConnectionExplicitness(..)
  , Connection(..)
  , blankRoomData

  -- * Lenses
  , thingContainedBy, thingLit, thingWearable, thingDescribed, _Wearable
  , roomIsVisited, roomDarkness, roomMapConnections, roomContainingRegion, roomEnclosing

  , connectionExplicitness, connectionRoom
  ) where

import qualified Data.Map as Map
import Solitude 
import Yaifl.Common ( WMDirections, Entity, defaultVoidID )
import Yaifl.Properties.Enclosing ( Enclosing, blankEnclosing )

<<thing-data>>
<<connections>>
<<room-data>>

Things

We have a bunch of fancy boolean flags. The special case is ThingWearability, where we wish to track both its ability to be worn and if it is worn then additionally who (maybe) is wearing it.

-- | If a thing provides light outwards; A lamp is lit, but a closed box with a light inside is not.
data ThingLit = Lit | NotLit 
  deriving stock (Eq, Show, Read, Enum, Ord, Generic)

-- | If a thing is wearable, and if so who (or what) is currently wearing it.
data ThingWearability = NotWearable | Wearable (Maybe Entity) 
  deriving stock (Eq, Show, Read, Ord, Generic)

-- | If a thing appears in "You can also see..." paragraphs.
data ThingDescribed = Undescribed | Described 
  deriving stock (Eq, Show, Read, Enum, Ord, Generic)

data ThingData = ThingData
  { _thingContainedBy :: Entity
  , _thingLit :: ThingLit
  , _thingWearable :: ThingWearability
  , _thingDescribed :: ThingDescribed
  } deriving stock (Eq, Show, Read, Ord, Generic)

blankThingData :: ThingData
blankThingData = ThingData defaultVoidID NotLit NotWearable Described

makeLenses ''ThingData
makePrisms ''ThingWearability

Rooms

Connections

We formalise connections between rooms somewhat. Inform7 has an (implicit) notion of connections, in that it will make the reverse mapping relation if it doesn't disturb something you have explicitly made already. For instance:

The West Room is a room. The East Room is a room. The Problem Room is a room.
The East Room is east of The West Room. The Problem Room is west of The East Room.

This will put The East Room to the east of The West Room (explicitly) and The West Room to the west of The East Room (implicitly). Then we add The Problem Room to the west of The East Room, and as this is an explicit relation it overrides the implicit one. If we had instead tried to put The Problem Room to the east of The West Room, this would fail (can't override explicit connections). This will be covered more in some later section.

data ConnectionExplicitness = Explicit | Implicit 
  deriving stock (Eq, Show, Read, Enum, Ord, Generic)

data Connection = Connection 
  { _connectionExplicitness :: ConnectionExplicitness
  , _connectionRoom :: Entity
  } deriving stock (Eq, Show, Read, Ord, Generic)

-- | The connections from a one room to another, stored by direction ID.
newtype MapConnections wm = MapConnections
  { unMapConnections :: Map.Map (WMDirections wm) Connection 
  }

deriving newtype instance (Generic (Map (WMDirections wm) Connection)) => Generic (MapConnections wm)
deriving newtype instance (Ord (WMDirections wm)) => Ord (MapConnections wm)
deriving newtype instance (Read (WMDirections wm), Ord (WMDirections wm)) => Read (MapConnections wm)
deriving newtype instance (Show (WMDirections wm)) => Show (MapConnections wm)
deriving stock instance (Eq (WMDirections wm)) => Eq (MapConnections wm)

RoomData

And now we put together a couple of spatial properties (connections and regions) with some useful properties: Some rooms are inherently lit and therefore don't need a light source, and we also track whether the player has visited it to provide short descriptions on a return.

-- | Whether a room has an intrinsic light-ness. This isn't equivalent to whether a
-- room is currently dark - for instance, a cave may have light (if the player has a
-- lantern) but the cave will be Dark.
data Darkness = Lighted | Dark 
  deriving stock (Eq, Show, Read, Enum, Ord, Generic)

-- | Whether a room has been visited before or not.
data IsVisited = Visited | Unvisited 
  deriving stock (Eq, Show, Read, Enum, Ord, Generic)

newtype ContainingRegion = ContainingRegion
  { unRegion :: Maybe Entity
  } deriving stock (Eq, Show)
    deriving newtype (Read, Ord, Generic)

data RoomData wm = RoomData
  { _roomIsVisited :: IsVisited
  , _roomDarkness :: Darkness
  , _roomMapConnections :: MapConnections wm
  , _roomContainingRegion :: ContainingRegion
  , _roomEnclosing :: Enclosing
  } deriving stock (Generic)

deriving stock instance (Ord (WMDirections wm)) => Ord (RoomData wm)
deriving stock instance (Read (WMDirections wm), Ord (WMDirections wm)) => Read (RoomData wm)
deriving stock instance (Show (WMDirections wm)) => Show (RoomData wm)
deriving stock instance (Eq (WMDirections wm)) => Eq (RoomData wm)

blankRoomData :: RoomData wm
blankRoomData = RoomData Unvisited Lighted (MapConnections Map.empty) (ContainingRegion Nothing) blankEnclosing


makeLenses ''RoomData
makeLenses ''Connection

Object Specifics

Here we define the standard library of object specifics. It's not very exciting; mostly we just list all the properties we define and some lenses for our property querying code.

{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Objects.Specifics
  ( -- * Specifics
  ObjectSpecifics(..)
  ) where

import Solitude
import Yaifl.Properties.Container
import Yaifl.Properties.Enclosing
import Yaifl.Properties.Openable
import Yaifl.Properties.Property

data ObjectSpecifics =
  NoSpecifics
  | EnclosingSpecifics Enclosing
  | ContainerSpecifics Container 
  | OpenableSpecifics Openable
  deriving stock (Eq, Show, Read)

makePrisms ''ObjectSpecifics

instance HasProperty ObjectSpecifics Enclosing where
  propertyL = _EnclosingSpecifics `thenATraverse` (_ContainerSpecifics % containerEnclosing)

instance HasProperty ObjectSpecifics Container where
  propertyL = castOptic _ContainerSpecifics

instance HasProperty ObjectSpecifics Enterable where
  propertyL = _ContainerSpecifics % containerEnterable

instance HasProperty ObjectSpecifics Openable where
  propertyL = _OpenableSpecifics `thenATraverse` (_ContainerSpecifics % containerOpenable)

Dynamic Objects

One of the coolest features of Inform is to have attributes and properties of objects be dynamic; for instance, Slightly Wrong shows a room with a dynamic description. Originally I had this only for descriptions but it made more sense to be applied to entire objects.

The only times that we actually care about the underlying representation of an object is when creating them (because we need to supply an update function) and when reifying AbstractObjects from a State-based implementation. This is a big refactor I'm happy to have made because it cleanly breaks apart implementation (cached objects) and semantics (objects at a point in time). It does have the slight issue that we need to be cautious: if we reify a dynamic object at some point in time, then we change some part of the world that may affect its update function, we will need to re-reify the object.

{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Objects.Dynamic 
  ( -- * Types
    TimestampedObject(..)
  , ObjectUpdate(..)
  , AbstractObject(..)
  , AbstractThing
  , AbstractRoom
  , AnyAbstractObject
  -- * Lenses
  , tsCachedObject
  , tsCacheStamp
  , tsUpdateFunc
  ) where

import Solitude ( Generic, Either, makeLenses, Eff )
import Yaifl.Common ( WorldModel, Timestamp, HasID(..) )
import Yaifl.Objects.Object ( Object )
import Yaifl.Objects.ObjectData ( RoomData, ThingData )

<<timestamped-object>>
<<abstract-object>>

Timestamped Objects

data TimestampedObject wm d = TimestampedObject
  { _tsCachedObject :: !(Object wm d)
  , _tsCacheStamp :: !Timestamp
  , _tsUpdateFunc :: ObjectUpdate wm d
  } deriving stock (Generic)

instance HasID (TimestampedObject wm d) where
  getID (TimestampedObject o _ _) = getID o

-- | Function to update an object. It is read-only on the world; i.e. it can only modify itself
newtype ObjectUpdate (wm :: WorldModel) d = ObjectUpdate
  { runObjectUpdate :: forall es. Object wm d -> Eff es (Object wm d)
  } 

Abstract Objects

data AbstractObject wm d
  = DynamicObject (TimestampedObject wm d)
  | StaticObject (Object wm d)

instance HasID (AbstractObject wm d) where
  getID (StaticObject o) = getID o
  getID (DynamicObject ts) = getID ts

type AbstractThing wm = AbstractObject wm ThingData
type AbstractRoom wm = AbstractObject wm (RoomData wm)
type AnyAbstractObject wm = AbstractObject wm (Either ThingData (RoomData wm))

makeLenses ''TimestampedObject

Creating Objects

{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Objects.Create
  ( -- * Effect
  ObjectCreation(..)
  , generateEntity
  , addAbstractThing
  , addAbstractRoom
  , addThing
  , addRoom
  , addThing'
  , addRoom'
  , addBaseObjects
  ) where

import Cleff.State ( State, get, runState )
import Solitude
import Yaifl.Common
import Yaifl.Logger ( debug, Log )
import Yaifl.Objects.Dynamic
import Yaifl.Objects.Move ( move )
import Yaifl.Objects.Object ( ObjType(ObjType), Object(Object) )
import Yaifl.Objects.ObjectData
import Yaifl.Objects.Query ( ObjectQuery )
import Yaifl.Objects.Specifics ( ObjectSpecifics(NoSpecifics) )
import Yaifl.Properties.Enclosing ( Enclosing )
import Yaifl.Properties.Property ( WMHasProperty )

<<creation-effect>>
<<make-object>>
<<add-objects>>
<<base-objects>>

data ObjectCreation wm :: Effect where
  GenerateEntity :: Bool -> ObjectCreation wm m Entity 
  AddAbstractThing :: AbstractThing wm -> ObjectCreation wm m ()
  AddAbstractRoom :: AbstractRoom wm -> ObjectCreation wm m ()

makeEffect ''ObjectCreation

type AddObjects wm es = '[ObjectCreation wm, State (Metadata wm), Log, ObjectQuery wm] :>> es

makeObject :: 
  ObjectCreation wm :> es
  => State (Metadata wm) :> es
  => Text -- ^ Name.
  -> Text -- ^ Description.
  -> ObjType
  -> Bool
  -> Either ObjectSpecifics (WMObjSpecifics wm) -- ^ Object details.
  -> d
  -> Maybe (ObjectUpdate wm d) -- ^ 'Nothing' for a static object, 'Just f' for a dynamic object.
  -> Eff es (Entity, AbstractObject wm d)
makeObject n d ty isT specifics details upd = do
  e <- generateEntity isT
  t <- getGlobalTime
  let obj = Object n d e ty t specifics details
  return (e, maybe (StaticObject obj) (DynamicObject . TimestampedObject obj t) upd)

addObject :: 
  WMHasProperty wm Enclosing
  => AddObjects wm es
  => (AbstractObject wm d -> Eff es ())
  -> Text
  -> Text
  -> ObjType
  -> Bool
  -> Either ObjectSpecifics (WMObjSpecifics wm)
  -> d
  -> Maybe (ObjectUpdate wm d)
  -> Eff es Entity
addObject updWorld n d ty isT specifics details updateFunc = do
  (e, obj) <- makeObject n d ty isT specifics details updateFunc
  debug $ bformat ("Made a new " %! stext %! " called " %! stext %! " with ID " %! int)
    (if isThing obj then "thing" else "room") n e
  updWorld obj
  lastRoom <- use previousRoom
  if
     isThing e 
  then
    previousRoom .= e
  else
    move e lastRoom >> pass -- move it if we're still 
  return e

-- | A version of 'addRoom' that uses a state monad to provide imperative-like -- descriptions of the internals of the object. Compare -- @ -- addThing n d o (Just $ (ThingData default default default .. mod1)) ... -- @ with @ -- addThing' n d o (someLensField .= 5) -- @

addThing ::
  WMHasProperty wm Enclosing
  => AddObjects wm es
  => Text -- ^ Name.
  -> Text -- ^ Description.
  -> ObjType -- ^ Type.
  -> Maybe (Either ObjectSpecifics (WMObjSpecifics wm))
  -> Maybe ThingData -- ^ Optional details; if 'Nothing' then the default is used.
  -> Maybe (ObjectUpdate wm ThingData) -- ^ Static/Dynamic.
  -> Eff es Entity
addThing name desc objtype specifics details = addObject addAbstractThing name desc objtype
  True (fromMaybe (Left NoSpecifics) specifics) (fromMaybe blankThingData details)

addThing' :: 
  WMHasProperty wm Enclosing
  => AddObjects wm es
  => Text -- ^ Name.
  -> Text -- ^ Description.
  -> Eff '[State ThingData] r -- ^ Build your own thing monad!
  -> Eff es Entity
addThing' n d stateUpdate = addThing n d (ObjType "thing")
    Nothing (Just $ snd $ runPure $ runState blankThingData stateUpdate) Nothing

addRoom :: 
  WMHasProperty wm Enclosing
  => AddObjects wm es
  => Text -- ^ Name.
  -> Text -- ^ Description.
  -> ObjType -- ^ Type.
  -> Maybe (Either ObjectSpecifics (WMObjSpecifics wm))
  -> Maybe (RoomData wm) -- ^
  -> Maybe (ObjectUpdate wm (RoomData wm))  -- ^
  -> Eff es Entity
addRoom name desc objtype specifics details upd = do
  e <- addObject addAbstractRoom name desc objtype False
        (fromMaybe (Left NoSpecifics) specifics) (fromMaybe blankRoomData details) upd
  md <- get
  when (isVoid $ md ^. firstRoom) (firstRoom .= e)
  return e

isVoid :: Entity -> Bool
isVoid = (defaultVoidID ==)

addRoom' :: 
 WMHasProperty wm Enclosing
  => AddObjects wm es
  => Text
  -> Text
  -> Eff '[State (RoomData wm)] v
  -> Eff es Entity
addRoom' n d rd = addRoom n d (ObjType "room")
  Nothing (Just $ snd $ runPure $ runState blankRoomData rd) Nothing

addBaseObjects ::
  WMHasProperty wm Enclosing
  => AddObjects wm es
  => Eff es ()
addBaseObjects = do
  addRoom' "The Void" "If you're seeing this, you did something wrong." pass
  addThing' "player" "It's you, looking handsome as always" (thingDescribed .= Undescribed)
  firstRoom .= defaultVoidID

Moving Objects

This is the first piece of code where we interact with objects at a higher level than foundational, and therefore we aim to exhibit the three layer cake model. That is, we aim to make as much separation between the things in layer 2 (things that require our monadic context) and those in layer 3 (the pure functions that do the work). It results in slightly more verbose code for this case, but it does pave the way for better testing later on.

module Yaifl.Objects.Move 
  ( move
  ) where
import Cleff.State ( State )
import qualified Data.EnumSet as ES
import Display ( displayText )
import Solitude

import Yaifl.Common ( HasID(..), tickGlobalTime, Metadata (..) )
import Yaifl.Logger ( debug, Log )
import Yaifl.Objects.Object ( objData, objName )
import Yaifl.Objects.ObjectData ( thingContainedBy )
import Yaifl.Objects.Query
import Yaifl.Properties.Enclosing ( enclosingContains, Enclosing )
import Yaifl.Properties.Property ( WMHasProperty )
import Yaifl.Properties.Query ( getEnclosing, getPropertyOrThrow, setEnclosing )

<<move-func>>

move :: 
  State (Metadata wm) :> es
  => Log :> es
  => ObjectQuery wm :> es
  => WMHasProperty wm Enclosing
  => ObjectLike wm o1
  => ObjectLike wm o2
  => o1
  -> o2
  -> Eff es Bool
move oObj oLoc = withoutMissingObjects moveBlock moveHandler 
  where
    moveBlock = do
      <<lookup-move>>
      <<move-thing>>

      <<update-move>>
      --at this point we know it's a success
      return $ True
    moveHandler = handleMissingObject 
      (bformat ("Failed to move ObjectID " %! int %! " to ObjectID " %! int ) (getID oObj) (getID oLoc)) $ return False

o' <- getThing oObj
loc <- getPropertyOrThrow "enclosing part of new location" oLoc =<< getEnclosing oLoc
let c = o' ^. objData % thingContainedBy
oldLocEnc <- getPropertyOrThrow "enclosing part of old location" c =<< getEnclosing c
debug $ bformat ("Moving " %! stext %! " from " %! stext %! " to " %! stext) (o' ^. objName) (displayText c) (displayText (getID oLoc))

let moveObjects newId t oldLoc newLocEncl = let (newLoc', t') = nowContains newId newLocEncl t in (t', oldLoc `noLongerContains` t, newLoc')
    noLongerContains cont obj = cont & (enclosingContains %~ ES.delete (getID obj))
    nowContains contId cont obj = (cont & (enclosingContains %~ ES.insert (getID obj)), obj & (objData % thingContainedBy .~ contId))
    (movedObj, oldLocation, newLocation) = moveObjects (getID oLoc) o' oldLocEnc loc

setThing movedObj
mapM (uncurry setEnclosing) [(c, oldLocation), (getID oLoc, newLocation)] 
tickGlobalTime True

Rooms

Brief introduction goes here

Directions

module Yaifl.Directions
  ( WithStandardDirections(..)
  , HasOpposite(..)
  , Direction(..)
  , WithDirections
  , WMStdDirections
  ) where

import Solitude hiding ( Down )
import Yaifl.Common

<<direction-injection>>
<<stock-directions>>

class WithStandardDirections d where
  injectDirection :: Direction -> d

class HasOpposite d where
  opposite :: d -> d

type WithDirections (wm :: WorldModel) = (Ord (WMDirections wm), HasOpposite (WMDirections wm))
type WMStdDirections (wm :: WorldModel) = (WithStandardDirections (WMDirections wm), WithDirections wm)

data Direction = 
  North
  | South
  | East
  | West
  | NorthWest
  | NorthEast
  | SouthWest
  | SouthEast
  | In
  | Out
  | Up
  | Down
  deriving stock (Eq, Show, Read, Ord, Enum, Generic, Bounded)

instance WithStandardDirections Direction where
  injectDirection = id

instance HasOpposite Direction where
  opposite = \case
    North -> South
    South -> North
    West -> East
    East -> West
    NorthWest -> SouthEast
    NorthEast -> SouthWest
    SouthEast -> NorthWest
    SouthWest -> NorthEast
    In -> Out
    Out -> In
    Up -> Down
    Down -> Up

Making Connections

{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Objects.Room
  --( isWestOf
  --, getMapConnection
where
 -- ) where

import Cleff.State ( State )
import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as TLB
import Display ( displayText )
import Solitude

import Yaifl.Common ( Entity, HasID(getID), Metadata, WMDirections, whenConstructingM )
import Yaifl.Directions ( HasOpposite(opposite), WithDirections )
import Yaifl.Logger ( warn, Log )
import Yaifl.Objects.Object ( objData, Room )
import Yaifl.Objects.ObjectData ( MapConnections(MapConnections), Connection(..), ConnectionExplicitness(..), roomMapConnections )
import Yaifl.Objects.Query

hasSpecificConnectionTo ::
  ObjectQuery wm :> es
  => State (Metadata wm) :> es
  => ObjectLike wm o
  => WithDirections wm
  => Maybe ConnectionExplicitness 
  -> o
  -> WMDirections wm
  -> Eff es (Maybe Entity)
hasSpecificConnectionTo mbExpl o dir = do
  r <- getRoomMaybe o
  let v = getConnectionInDirection dir =<< r
  case v of
    Just (Connection ex' e) 
      | (maybe True (ex' ==) mbExpl) -> return $ Just e
    _ -> return Nothing

getMapConnection ::
  NoMissingObjects wm es
  => WithDirections wm
  => ObjectLike wm o
  => WMDirections wm
  -> o
  -> Eff es (Maybe Entity)
getMapConnection dir o = ((_connectionRoom <$>) . getConnectionInDirection dir) <$> getRoom o

getConnectionInDirection :: 
  WithDirections wm 
  => WMDirections wm 
  -> Room wm 
  -> Maybe Connection
getConnectionInDirection dir = preview (connectionLens dir % _Just)

connectionLens ::
  forall wm.
  WithDirections wm 
  => WMDirections wm 
  -> Lens' (Room wm) (Maybe Connection)
connectionLens dir = objData % roomMapConnections % coercedTo @(Map.Map (WMDirections wm) Connection ) % at dir

makeConnection :: 
  WithDirections wm
  => ConnectionExplicitness
  -> WMDirections wm 
  -> Room wm 
  -> (Room wm -> Room wm)
makeConnection expl dir r = connectionLens dir ?~ Connection expl (getID r)

addDirectionFrom ::
  (ObjectLike wm o1, ObjectLike wm o2)
  => ObjectQuery wm :> es
  => State (Metadata wm) :> es
  => Log :> es
  => WithDirections wm
  => WMDirections wm
  -> o1
  -> o2
  -> Eff es Entity
addDirectionFrom = isDirectionFromInternal True

addDirectionFromOneWay ::
  (ObjectLike wm o1, ObjectLike wm o2)
  => '[ObjectQuery wm, State (Metadata wm), Log] :>> es
  => WithDirections wm
  => WMDirections wm
  -> o1
  -> o2
  -> Eff es Entity
addDirectionFromOneWay = isDirectionFromInternal False 

isDirectionFromInternal ::
  (ObjectLike wm o1, ObjectLike wm o2)
  => '[ObjectQuery wm, State (Metadata wm), Log] :>> es
  => WithDirections wm
  => Bool
  -> WMDirections wm
  -> o1
  -> o2
  -> Eff es Entity
isDirectionFromInternal mkRev dir o1 o2 = withoutMissingObjects (do
    let opp = opposite dir
    -- ensure we have two rooms
    r2 <- getRoom o2
    r1 <- getRoom o1
    -- we log a warning if we're in construction and we are overriding an explicit connection
    -- apparently inform just doesn't let you do this, so...
    -- r1 is explicitly dir of r2; it is r2 we need to check
    -- r2 is implicitly (opposite dir) of r1.
    -- e.g. if r1 `isWestOf` r2, then r2 has an explicit west connection and r1 has an implicit east connection.
    whenConstructingM (isJust <$> hasSpecificConnectionTo (Just Explicit) r2 dir)
      -- TODO: this should be a nonblocking failure
      (warn $ TLB.fromText $ "Overriding an explicitly set map direction of room " <> displayText r1) 
    modifyRoom r2 (makeConnection Explicit dir r1)
    --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
      whenConstructingM (isJust <$> hasSpecificConnectionTo (Just Implicit) r2 opp)
        (warn $ TLB.fromText $ "Not using an implicit direction to overwrite an implicitly set map direction of room " <> displayText r1) 
      -- and don't bother if there's any connection at all
      unless (isJust $ r1 ^? connectionLens opp) $ modifyRoom r1 (makeConnection Implicit dir r2)
    return (getID o1)) (handleMissingObject "failed to make direction" (return $ getID o1))

-- makeDirections True ["West"]

Properties

properties

{-# LANGUAGE DefaultSignatures #-}

module Yaifl.Properties.Property 
  ( HasProperty(..)
  , WMHasProperty
  ) where

import Solitude ( Either(..), const, atraversal, eitherJoin, AffineTraversal' )
import Yaifl.Common ( WMObjSpecifics )

-- | A helper to define that a world model `wm` has a Property.
type WMHasProperty wm v = HasProperty (WMObjSpecifics wm) v

class HasProperty o v where
  default propertyL :: AffineTraversal' o v
  propertyL = atraversal Left const
  propertyL :: AffineTraversal' o v

instance (HasProperty a v, HasProperty b v) => HasProperty (Either a b) v where
  propertyL = propertyL `eitherJoin` propertyL

instance HasProperty () a

Get, Set, Modify

{-# LANGUAGE DataKinds #-}

module Yaifl.Properties.TH
(
    makeSpecificsWithout
  , makePropertyFunction
  , SpecificsFunctions(..)
  , makeDirections
) where

import Solitude
import Language.Haskell.Meta hiding (myDefaultParseMode)nice 
import Data.Text (replace)
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Extension
import Language.Haskell.TH (Name, Q, Dec, nameBase)

data SpecificsFunctions =
  GetX
  | SetX
  | ModifyX
  deriving stock (Show, Eq, Enum, Ord, Generic, Bounded)


myDefaultParseMode :: ParseMode
myDefaultParseMode = defaultParseMode
  { parseFilename = []
  , baseLanguage = Haskell2010
  , extensions = map EnableExtension [DataKinds, ExplicitForAll, ScopedTypeVariables ]
  }

makeSpecificsWithout :: [SpecificsFunctions] -> Name -> Q [Dec]
makeSpecificsWithout l prop = do
  v <- mapM (makePropertyFunction prop) (universeSans l)
  return $ join v

makePropertyFunction :: Name -> SpecificsFunctions -> Q [Dec]
makePropertyFunction n sf = do
  return $ (case sf of
    GetX -> replaceTH 
      "getXSUBHERE :: MonadReader (World wm) m => Logger m => NoMissingObjects m => WMHasProperty wm XSUBHERE => MonadState (World wm) m => ObjectLike wm o => o -> m (Maybe XSUBHERE)\ngetXSUBHERE = defaultPropertyGetter"
    SetX -> replaceTH 
      "setXSUBHERE :: MonadReader (World wm) m => Logger m => WMHasProperty wm XSUBHERE => MonadState (World wm) m => HasID o => o-> XSUBHERE-> m ()\nsetXSUBHERE = defaultPropertySetter"
    ModifyX -> replaceTH 
      "modifyXSUBHERE :: MonadReader (World wm) m => Logger m => NoMissingObjects m => WMHasProperty wm XSUBHERE => MonadState (World wm) m => ObjectLike wm o => o -> (XSUBHERE -> XSUBHERE) -> m ()\nmodifyXSUBHERE = modifyProperty getXSUBHERE setXSUBHERE"
    ) (toText $ nameBase n)

replaceTH :: Text -> Text -> [Dec]
replaceTH y x = either (\x' -> [error $ toText x']) id (parseDecsWithMode myDefaultParseMode $ toString $ replace "XSUBHERE" x y)

makeDirections :: Bool -> [Text] -> Q [Dec]
makeDirections std dirs = do
  v <- mapM (\n -> do
    let replaceTH' y x = if std then replaceTH (replace "XSUBHERE2" "(injectDirection XSUBHERE)" y) x else replaceTH (replace "XSUBHERE2" "XSUBHERE" y) x
        r1 = replaceTH' "isXSUBHEREOf :: MonadWorld wm m => WMStdDirections wm => m Entity -> Entity -> m Entity\nisXSUBHEREOf = isDirectionFrom XSUBHERE2" n
        r2 = replaceTH' "isXSUBHEREOfOneWay :: MonadWorld wm m => WMStdDirections wm => m Entity -> Entity -> m Entity\nisXSUBHEREOfOneWay = isDirectionFromOneWay XSUBHERE2" n
    return $ r1 <> r2
    ) dirs
  return $ join v

Standard Properties

Enclosing

{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Properties.Enclosing 
  ( -- * Types
    Enclosing(..)
  , blankEnclosing
  
    -- * Lenses
  , enclosingContains
  , enclosingCapacity
  ) where

import Solitude hiding (empty)
import Data.EnumSet (EnumSet, empty)
import Yaifl.Common (Entity)

-- | A component that contains other objects.
data Enclosing = Enclosing
  { _enclosingContains :: EnumSet Entity
  , _enclosingCapacity :: Maybe Int
  } deriving stock (Eq, Show, Read, Ord, Generic)

blankEnclosing :: Enclosing
blankEnclosing = Enclosing empty Nothing

makeLenses ''Enclosing

Openable

module Yaifl.Properties.Openable 
  ( -- * Types
    Openable(..)
  ) where

import Solitude ( Eq, Ord, Read, Show, Generic )

-- | Whether the thing is open or not.
data Openable = Open | Closed 
  deriving stock (Eq, Show, Read, Ord, Generic)

Container

{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Properties.Container 
  ( -- * Types
    Opacity(..)
  , Enterable(..)
  , Container(..)

  , isOpaqueClosedContainer
    -- * Lenses
  , containerOpacity
  , containerEnclosing
  , containerOpenable
  , containerEnterable
  ) where

import Solitude
import Yaifl.Properties.Enclosing ( Enclosing )
import Yaifl.Properties.Openable ( Openable(..) )

-- | If the container is see-through.
data Opacity = Opaque | Transparent 
  deriving stock (Eq, Show, Read, Ord, Generic)

-- | If the container is enterable (by a person or animal or other sentient being).
data Enterable = Enterable | NotEnterable
  deriving stock (Eq, Show, Read, Ord, Generic)

-- | A container.
data Container = Container
  { _containerOpacity :: Opacity
  , _containerEnclosing :: Enclosing
  , _containerOpenable :: Openable
  , _containerEnterable :: Enterable
  } deriving stock (Eq, Show, Read, Ord, Generic)

makeLenses ''Container

isOpaqueClosedContainer :: 
  Container
  -> Bool
isOpaqueClosedContainer c = (_containerOpacity c == Opaque) && (_containerOpenable c == Closed)

Rulebooks, Actions, and Activities

oh my

Running a Rulebook

go

Action Processing

a very special kind of running a rulebook

Activities

probably need to check inform for this

Construction and Execution

build it and run it

module Yaifl
  (
    --module Yaifl.Common
 -- , module Yaifl.Messages
--  , module Yaifl.Rulebooks
 -- , module Yaifl.Properties
  --, module Yaifl.Activities
    newWorld
  , blankWorld
  , HasStandardProperties
  , PlainWorldModel
  , Game
  , runGame
  ) where
import Solitude

import Yaifl.World
import qualified Data.Map as DM
import Yaifl.Common
import Yaifl.Say
--import Yaifl.Rulebooks.ActionProcessing
import Yaifl.Properties.Property
import Yaifl.Properties.Openable
import Yaifl.Properties.Container
import Yaifl.Properties.Enclosing
import Yaifl.Directions
import Yaifl.Logger
import Cleff.State hiding ( zoom )
import Yaifl.Objects.Create
import Yaifl.Objects.Query
import Display
--import Yaifl.Objects.Create
--import Yaifl.Rulebooks.WhenPlayBegins
--import Yaifl.ActivityCollection
--import Yaifl.Directions

type PlainWorldModel = 'WorldModel () Direction () ()

type HasStandardProperties s = (
  WMHasProperty s Enclosing
  , WMHasProperty s Container
  , WMHasProperty s Enterable
  , WMHasProperty s Openable)

blankWorld :: World (s :: WorldModel)
blankWorld = World
  { _worldMetadata = blankMetadata
  , _worldStores = blankStores
  , _worldActions = blankActions
  , _messageBuffer = blankMessageBuffer
  }

blankActions :: WorldActions s
blankActions = WorldActions
  { _actions = () --DM.empty
  , _activities = ()--_wb
  , _whenPlayBegins = () --_wc
  , _actionProcessing = () --_wd
  }

blankStores :: WorldStores s
blankStores = WorldStores
  { _entityCounter = (Entity 1, Entity (-1))
  , _things = emptyStore
  , _rooms = emptyStore
  , _values = DM.empty
  , _concepts = ()
  }

blankMetadata :: Metadata s
blankMetadata = Metadata 
  { _title = "Untitled"
  , _roomDescriptions = SometimesAbbreviatedRoomDescriptions
  , _dirtyTime = False
  , _globalTime = 0
  , _darknessWitnessed = False
  , _currentPlayer = Entity 1
  , _currentStage = Construction
  , _previousRoom = defaultVoidID
  , _firstRoom = defaultVoidID
  }

type EffStack wm = '[Log, ObjectQuery wm, State (Metadata wm), ObjectCreation wm, IOE]
type EffStackNoIO wm = '[Log, ObjectQuery wm, State (Metadata wm), ObjectCreation wm]
type Game wm = Eff (EffStack wm) 

type UnderlyingEffStack wm = '[State (World wm), IOE] 

newWorld :: 
  WMHasProperty wm Enclosing
  => Eff (EffStack wm) ()
newWorld = do
  addBaseObjects
  pass
  {- addBaseActions >> -} 

convertToUnderlyingStack :: 
  forall wm. Eff (EffStack wm)
  ~> Eff (UnderlyingEffStack wm) 
convertToUnderlyingStack = 
  runCreationAsLookup
  . (zoom worldMetadata) 
  . runQueryAsLookup
  . runAndIgnoreLogging
  . raiseUnderN @(State (World wm)) @(EffStackNoIO wm) @('[IOE])

runGame :: 
  Text 
  -> Eff (EffStack wm) a
  -> IO (World wm)
runGame t f = do
  (r, w) <- runIOE $ runState blankWorld $ convertToUnderlyingStack f
  return w

The World State

This is the monolithic core of the library. It can be chunked into a few main pieces, each of which is handled by a separate effect handler to keep our separation of concerns as modular as possible (for instance, an object should not be able to run an Action when printing out some text!).

We put the message buffer as part of the state even though we are in IO because it allows us to directly consume the output (e.g. for testing).

{-# LANGUAGE TemplateHaskell #-}
module Yaifl.World where
import Solitude
import Yaifl.Common

import Yaifl.Say
--import Yaifl.Rulebooks.Rulebook
--import Yaifl.Activities.Activity
--import Yaifl.Actions.Action
import Yaifl.Objects.Dynamic
import Yaifl.Objects.Query
import Cleff.State
import Yaifl.Objects.Object
import Yaifl.Objects.Create
import Display
--import Yaifl.Actions.Looking
--import Yaifl.Actions.Going

data World (wm :: WorldModel) = World
  { _worldMetadata :: Metadata wm
  , _worldStores :: WorldStores wm
  , _worldActions :: WorldActions wm
  , _messageBuffer :: MessageBuffer
  }

<<world-stores>>
<<world-actions>>

makeLenses ''World
makeLenses ''WorldModel
makeLenses ''WorldStores

<<world-other>>

Metadata

These fields are for information we need to keep around but don't have complex dependencies -- so we can define the metadata in Yaifl.Common and therefore break the import cycle of individual modules <-> Yaifl.World we have with a monolithic state record, but without having to write the boilerplate of an effect that exposes each of these fields individually.

data Metadata (wm :: WorldModel) = Metadata
  { _title :: Text
  , _roomDescriptions :: RoomDescriptions
  , _dirtyTime :: Bool
  , _globalTime :: Timestamp
  , _darknessWitnessed :: Bool
  , _currentPlayer :: Entity
  , _currentStage :: CurrentStage
  , _previousRoom :: Entity
  , _firstRoom :: Entity
  -- more to come I guess
  }

data CurrentStage = Construction | Verification | Runtime
  deriving stock (Eq, Show, Read, Ord, Enum, Generic)

makeLenses ''Metadata

getGlobalTime :: 
  State (Metadata wm) :> es 
  => Eff es Timestamp
getGlobalTime = use globalTime

tickGlobalTime ::
  State (Metadata wm) :> es 
  => Bool
  -> Eff es ()
tickGlobalTime _ = pass

setTitle :: 
  State (Metadata wm) :> es 
  => Text -- ^ New title.
  -> Eff es ()
setTitle = (title .=)

whenConstructingM :: 
  State (Metadata wm) :> es
  => Eff es Bool 
  -> Eff es () 
  -> Eff es ()
whenConstructingM cond = 
  whenM (andM [do
    cs <- use currentStage
    return $ cs == Construction, cond])

data CurrentStage = Construction | Verification | Runtime
  deriving stock (Eq, Show, Read, Ord, Enum, Generic)

Room Descriptions

Lifted directly from Inform; this sets whether to always print room descriptions (No..) even if the room is visited, to only print them on the first entry (Sometimes..), or never.

data RoomDescriptions = SometimesAbbreviatedRoomDescriptions
  | AbbreviatedRoomDescriptions
  | NoAbbreviatedRoomDescriptions 
  deriving stock (Eq, Show, Read, Ord, Enum, Generic)

World Stores

The lookup tables for various objects, values, etc in the game. This is probably the most important part of the World state.

data WorldStores (wm :: WorldModel) = WorldStores
  { _entityCounter :: (Entity, Entity)
  , _things :: Store (AbstractThing wm)
  , _rooms :: Store (AbstractRoom wm)
  , _values :: Map Text (WMValues wm)
  , _concepts :: ()-- !(Store (AbstractConcept t r c))
  }

World Actions

These are the dynamic parts that run things. This is the in-world actions, the standard activities (because user-defined activities can be done separately and don't need a lookup), and the two standalone rulebooks. Again, user-defined rulebooks act the same as activities and don't need to be stored around in the state.

data WorldActions (wm :: WorldModel) = WorldActions
  { _actions :: () -- !(Map Text (Action wm))
  , _activities :: () -- !(ActivityCollection wm)
  , _whenPlayBegins :: () -- !(Rulebook wm () () Bool)
  , _actionProcessing :: ()-- ActionProcessing wm
  }

Timestamp Caching

It is up to functions which might do some more complex processing (e.g. move) to update the time.

newtype Timestamp = Timestamp
  { unTimestamp :: Int
  } deriving stock   (Show, Read, Generic)
    deriving newtype (Eq, Num, Enum, Ord, Real, Integral)

Other

-- | Turn an `AbstractObject` into a regular `Object` and update the cache if needed.
reifyObject ::
  State (Metadata wm) :> es
  => (AbstractObject wm d -> Eff es ())
  -> AbstractObject wm d
  -> Eff es (Object wm d)
reifyObject _ (StaticObject v) = return v
reifyObject setFunc (DynamicObject ts) = do
  let co = _tsCachedObject ts
  now <- getGlobalTime
  if
    _tsCacheStamp ts == now
  then
    return co
  else
    do
      -- update the object
      updatedObj <- runObjectUpdate (_tsUpdateFunc ts) co
      t <- getGlobalTime
      setFunc (DynamicObject $ TimestampedObject updatedObj t (_tsUpdateFunc ts))
      return updatedObj

reifyRoom :: 
  State (Metadata wm) :> es
  => (ObjectCreation wm :> es)
  => AbstractRoom wm
  -> Eff es (Room wm)
reifyRoom = reifyObject addAbstractRoom

reifyThing :: 
  State (Metadata wm) :> es
  => (ObjectCreation wm :> es)
  => AbstractThing wm
  -> Eff es (Thing wm)
reifyThing = reifyObject addAbstractThing

runCreationAsLookup :: 
  State (World wm) :> es
  => Eff (ObjectCreation wm : es) 
  ~> Eff es
runCreationAsLookup = interpret \case
  GenerateEntity bThing -> if bThing then 
    ((worldStores % entityCounter % _1) <<%= (+1)) else ((worldStores % entityCounter % _2) <<%= (+1))
  AddAbstractRoom aRoom -> worldStores % rooms % at (getID aRoom) ?= aRoom
  AddAbstractThing aThing -> worldStores % things % at (getID aThing) ?= aThing

runQueryAsLookup :: 
  State (World wm) :> es
  => (ObjectCreation wm :> es)
  => (State (Metadata wm) :> es)
  => Eff (ObjectQuery wm : es) 
  ~> Eff es
runQueryAsLookup = interpret \case
  LookupThing e -> do
    mbObj <- use $ worldStores % things % at (getID e)
    case mbObj of
      Nothing -> return 
        if isThing e 
          then 
            Left $ "Tried to lookup a room as a thing " <> displayText (getID e) 
          else 
            Left $ "Could not find" <> displayText (getID e)
      Just ao -> withoutMissingObjects (Right <$> reifyThing ao) (\mo -> return $ Left $ "Failed to reify " <> displayText mo)
  LookupRoom e -> error ""
  SetRoom r -> error ""
  SetThing t -> error ""


{-


tickGlobalTime :: 
  MonadWorld wm m
  => Bool
  -> m ()
--I have no idea what my plans were for this flag.
tickGlobalTime False = dirtyTime .= True
tickGlobalTime True = do
  dirtyTime .= False
  _ <- globalTime <%= (+1)
  pass
  -- debug (bformat ("Dong. The time is now " %! int %! ".") r)

addBaseActions :: 
  HasLookingProperties wm
  => World wm
  -> World wm
addBaseActions = foldr (.) id [
    addAction lookingActionImpl
  , addAction goingActionImpl
  ]


-}

Testing Framework

Sandwich is cool

Test Coverage

yes

There's some other files I haven't got anywhere to put.

Other Miscellania

There's some additional baggage hanging around that, in the literate programming style, I needed to put somewhere. So here will do for now.

Common

As this just includes some basic types, it doesn't really have a section specifically for it and as such does not have its file outline described anywhere. So it's here.

{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE TemplateHaskell #-}

module Yaifl.Common
  (-- * Datatypes
  Entity(..)
  , Store(..)
  , HasID(..)
  , Timestamp(..)
  , WorldModel(..)
  , RoomDescriptions(..)

  -- * Metadata
  , Metadata(..)
  , CurrentStage(..)
  , getGlobalTime
  , tickGlobalTime
  , previousRoom
  , firstRoom
  , setTitle
  , whenConstructingM

  -- * Some defaults
  , defaultVoidID
  , defaultPlayerID
  , emptyStore

  -- * Object querying
  , isThing
  , isRoom

    -- * Type family nonsense
  , WMObjSpecifics
  , WMValues
  , WMDirections
  , WMShow
  , WMRead
  , WMOrd
  , WMEq
  )
where

import Cleff.State ( State )
import qualified Data.EnumMap.Strict as EM
import qualified Data.IntMap.Strict as IM
import Display ( Display(..) )

import Solitude

instance {-# OVERLAPPABLE #-} Display a where
  display = const "No display instance"

<<entity-def>>
<<thing-or-room>>
<<has-id>>
<<base-ids>>
<<store-def>>
<<alter-store>>
<<store-at>>
<<store-instances>>

<<room-descriptions>>
<<timestamp>>
<<world-model>>
<<world-model-families>>
<<world-model-constraints>>
<<world-metadata>>

There's some other files I haven't got anywhere to put.