@@ -1,4 +1,6 @@
1{-# LANGUAGE NoMonomorphismRestriction #-}
1{-# LANGUAGE NoMonomorphismRestriction #-}
2+-- investigation using typed tagless interpretter of an AST representation of a story.
3+-- Use extensible effects instead?
2module RougeStory where
4module RougeStory where
4import Text.Printf
6import Text.Printf
@@ -6,11 +8,18 @@ import Text.Printf
6import Graphics.Vty
8import Graphics.Vty
7import Graphics.Vty.Inline
9import Graphics.Vty.Inline
11+import Control.Applicative
12+import Control.Concurrent (threadDelay)
14+import Control.Monad.Trans
9import Control.Monad.Trans.State.Strict
15import Control.Monad.Trans.State.Strict
11import Data.Map.Strict (Map)
18import Data.Map.Strict (Map)
12import qualified Data.Map.Strict as Map
19import qualified Data.Map.Strict as Map
14-- Characters are identified by Names
23-- Characters are identified by Names
15type Character = Name
24type Character = Name
16type Name = String
25type Name = String
@@ -112,43 +121,65 @@ instance Story TellStory where
112 named (TellStory obj) name
121 named (TellStory obj) name
113 = TellStory $ obj ++ " with the name " ++ name
122 = TellStory $ obj ++ " with the name " ++ name
115−newtype BuildPicture t = BuildPicture {build_picture :: Picture -> State PictureCtx Picture}
124+newtype BuildSprites m t = BuildSprites {build_sprites :: StateT SpriteDB m ()}
117type Sprite = (Int, Int, Image)
126type Sprite = (Int, Int, Image)
118−data PictureCtx = PictureCtx
127+type Collider = (Int,Int,Int,Int)
128+data SpriteDB = SpriteDB
119− { next_ID :: Int -- globally monotonic
129+ { next_sprite_ID :: Int -- globally monotonic. H: Can fst . findMax + 1 be used?
120− , this_ID :: Int
130+ , this_sprite_ID :: Int
121− , known_sprites :: Map Int Sprite
131+ , sprites :: Map Int Sprite
124−get_ID :: State PictureCtx Int
135+get_sprite_ID :: MonadIO m => StateT SpriteDB m Int
125−get_ID = gets this_ID
136+get_sprite_ID = gets this_sprite_ID
127−new_ID :: Picture -> State PictureCtx Picture
138+new_sprite_ID :: MonadIO m => StateT SpriteDB m Int
128−new_ID p = do
139+new_sprite_ID = do
129 ctx <- get
140 ctx <- get
130− let the_ID = next_ID ctx
141+ let the_ID = next_sprite_ID ctx
131− put $ ctx {next_ID = the_ID + 1, this_ID = the_ID}
142+ put $ ctx {next_sprite_ID = the_ID + 1, this_sprite_ID = the_ID}
132− return p
143+ return the_ID
134−empty_picture_ctx = PictureCtx 0 1 Map.empty
145+empty_sprite_db = SpriteDB 0 1 Map.empty
148+ = modify (\ctx -> ctx {sprites = Map.insert i (x,y,img) (sprites ctx)})
150+add_random_sprite c i = do
151+ let img = char def_attr c
152+ [x,y] <- liftIO $ replicateM 2 $ randomRIO (-100,100)
153+ add_sprite x y img i
136−instance Story BuildPicture where
155+instance MonadIO m => Story (BuildSprites m) where
137− story _c (BuildPicture q) = BuildPicture q
156+ story _c (BuildSprites q) = BuildSprites q
138− quest _g (BuildPicture as) = BuildPicture as
157+ quest (BuildSprites g) (BuildSprites as) = BuildSprites (g >> as)
139− empty_aspects = BuildPicture new_ID
158+ empty_aspects = BuildSprites $ return ()
140− add_known_history h (BuildPicture as) = BuildPicture as
159+ add_known_history h (BuildSprites as) = BuildSprites as
141− add_known_obj obj (BuildPicture as) = BuildPicture as
160+ add_known_obj obj (BuildSprites as) = BuildSprites as
142− add_unknown_history h (BuildPicture as) = BuildPicture as
161+ add_unknown_history h (BuildSprites as) = BuildSprites as
143− add_unknown_obj obj (BuildPicture as) = BuildPicture as
162+ add_unknown_obj obj (BuildSprites as) = BuildSprites as
144− animate_obj t = BuildPicture new_ID
163+ animate_obj _t = BuildSprites $ do
164+ add_random_sprite '@' =<< new_sprite_ID
145− inanimate_obj t = BuildPicture new_ID
165+ inanimate_obj _t = BuildSprites $ do
146− history = BuildPicture new_ID
166+ add_random_sprite 'X' =<< new_sprite_ID
167+ history = BuildSprites $ return ()
147− dispose_obj (BuildPicture obj) = BuildPicture obj
168+ dispose_obj (BuildSprites obj) = BuildSprites obj
148− acquire_obj (BuildPicture obj) = BuildPicture obj
169+ acquire_obj (BuildSprites obj) = BuildSprites obj
149− named (BuildPicture obj) n = BuildPicture obj
170+ named (BuildSprites obj) n = BuildSprites obj
172+render_sprites = foldMap render_sprite . sprites
173+render_sprite (x,y,img) = return $ translate x y img
152 putStrLn $ unTellStory story_0
176 putStrLn $ unTellStory story_0
153 putStrLn $ unShowStory story_0
177 putStrLn $ unShowStory story_0
154− withVty $ flip update $ evalState (build_picture story_0 empty_picture) empty_picture_ctx
178+ sprite_db <- execStateT (build_sprites story_0) empty_sprite_db
180+ let imgs = render_sprites sprite_db
181+ p = pic_for_layers imgs
182+ withVty $ flip update p