@@ -6,6 +6,11 @@ import Text.Printf
66import Graphics.Vty
77import Graphics.Vty.Inline
88
9+import Control.Monad.Trans.State.Strict
10+
11+import Data.Map.Strict (Map)
12+import qualified Data.Map.Strict as Map
13+
914-- Characters are identified by Names
1015type Character = Name
1116type Name = String
@@ -28,7 +33,7 @@ class Story repr where
2833 -- Aspects are animate objects, inanimate objects or histories.
2934 animate_obj :: Type -> repr Object
3035 inanimate_obj :: Type -> repr Object
31− history :: Type -> repr History
36+ history :: repr History
3237
3338 -- The goal is to acquire, or dispose of an object.
3439 dispose_obj :: repr Object -> repr Goal
@@ -61,7 +66,7 @@ instance Story X where
6166 add_unknown_obj obj as =
6267 animate_obj t =
6368 inanimate_obj t =
64− history t =
69+ history =
6570 dispose_obj obj =
6671 acquire_obj obj =
6772 named obj n =
@@ -78,7 +83,7 @@ instance Story ShowStory where
7883 add_unknown_obj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)
7984 animate_obj t = ShowStory $ printf "%s :: AnimateObj" t
8085 inanimate_obj t = ShowStory $ printf "%s :: InanimateObj" t
81− history t = ShowStory $ printf "%s :: History" t
86+ history = ShowStory $ printf "History"
8287 dispose_obj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)
8388 acquire_obj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)
8489 named obj n = ShowStory $ printf "%s+Name(%s)" (unShowStory obj) (show n)
@@ -99,7 +104,7 @@ instance Story TellStory where
99104 add_unknown_obj _ as = as
100105 animate_obj t = TellStory t
101106 inanimate_obj t = TellStory t
102− history t = TellStory t
107+ history = TellStory "History"
103108 dispose_obj (TellStory obj)
104109 = TellStory $ "to dispose of the accursed " ++ obj
105110 acquire_obj (TellStory obj)
@@ -107,26 +112,43 @@ instance Story TellStory where
107112 named (TellStory obj) name
108113 = TellStory $ obj ++ " with the name " ++ name
109114
110−newtype PictureStory t = PictureStory { compose_to_picture :: Picture }
111−
112−{-
113−instance Story X where
114− story c q =
115− quest g as =
116− empty_aspects =
117− add_known_history h as =
118− add_known_obj obj as =
119− add_unknown_history h as =
120− add_unknown_obj obj as =
121− animate_obj t =
122− inanimate_obj t =
123− history t =
124− dispose_obj obj =
125− acquire_obj obj =
126− named obj n =
127−-}
115+newtype BuildPicture t = BuildPicture {build_picture :: Picture -> State PictureCtx Picture}
116+
117+type Sprite = (Int, Int, Image)
118+data PictureCtx = PictureCtx
119+ { next_ID :: Int -- globally monotonic
120+ , this_ID :: Int
121+ , known_sprites :: Map Int Sprite
122+ }
123+
124+get_ID :: State PictureCtx Int
125+get_ID = gets this_ID
126+
127+new_ID :: Picture -> State PictureCtx Picture
128+new_ID p = do
129+ ctx <- get
130+ let the_ID = next_ID ctx
131+ put $ ctx {next_ID = the_ID + 1, this_ID = the_ID}
132+ return p
133+
134+empty_picture_ctx = PictureCtx 0 1 Map.empty
135+
136+instance Story BuildPicture where
137+ story _c (BuildPicture q) = BuildPicture q
138+ quest _g (BuildPicture as) = BuildPicture as
139+ empty_aspects = BuildPicture new_ID
140+ add_known_history h (BuildPicture as) = BuildPicture as
141+ add_known_obj obj (BuildPicture as) = BuildPicture as
142+ add_unknown_history h (BuildPicture as) = BuildPicture as
143+ add_unknown_obj obj (BuildPicture as) = BuildPicture as
144+ animate_obj t = BuildPicture new_ID
145+ inanimate_obj t = BuildPicture new_ID
146+ history = BuildPicture new_ID
147+ dispose_obj (BuildPicture obj) = BuildPicture obj
148+ acquire_obj (BuildPicture obj) = BuildPicture obj
149+ named (BuildPicture obj) n = BuildPicture obj
128150
129151main = do
130152 putStrLn $ unTellStory story_0
131153 putStrLn $ unShowStory story_0
132− withVty $ flip update (compose_to_picture story_0)
154+ withVty $ flip update $ evalState (build_picture story_0 empty_picture) empty_picture_ctx