@@ -1,4 +1,6 @@
11{-# LANGUAGE NoMonomorphismRestriction #-}
2+-- investigation using typed tagless interpretter of an AST representation of a story.
3+-- Use extensible effects instead?
24module RougeStory where
35
46import Text.Printf
@@ -6,11 +8,18 @@ import Text.Printf
68import Graphics.Vty
79import Graphics.Vty.Inline
810
11+import Control.Applicative
12+import Control.Concurrent (threadDelay)
13+import Control.Monad
14+import Control.Monad.Trans
915import Control.Monad.Trans.State.Strict
1016
17+import Data.Foldable
1118import Data.Map.Strict (Map)
1219import qualified Data.Map.Strict as Map
1320
21+import System.Random
22+
1423-- Characters are identified by Names
1524type Character = Name
1625type Name = String
@@ -112,43 +121,65 @@ instance Story TellStory where
112121 named (TellStory obj) name
113122 = TellStory $ obj ++ " with the name " ++ name
114123
115−newtype BuildPicture t = BuildPicture {build_picture :: Picture -> State PictureCtx Picture}
124+newtype BuildSprites m t = BuildSprites {build_sprites :: StateT SpriteDB m ()}
116125
117126type Sprite = (Int, Int, Image)
118−data PictureCtx = PictureCtx
119− { next_ID :: Int -- globally monotonic
120− , this_ID :: Int
121− , known_sprites :: Map Int Sprite
127+type Collider = (Int,Int,Int,Int)
128+data SpriteDB = SpriteDB
129+ { next_sprite_ID :: Int -- globally monotonic. H: Can fst . findMax + 1 be used?
130+ , this_sprite_ID :: Int
131+ , sprites :: Map Int Sprite
122132 }
133+ deriving (Show)
123134
124−get_ID :: State PictureCtx Int
125−get_ID = gets this_ID
135+get_sprite_ID :: MonadIO m => StateT SpriteDB m Int
136+get_sprite_ID = gets this_sprite_ID
126137
127−new_ID :: Picture -> State PictureCtx Picture
128−new_ID p = do
138+new_sprite_ID :: MonadIO m => StateT SpriteDB m Int
139+new_sprite_ID = do
129140 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
141+ let the_ID = next_sprite_ID ctx
142+ put $ ctx {next_sprite_ID = the_ID + 1, this_sprite_ID = the_ID}
143+ return the_ID
144+
145+empty_sprite_db = SpriteDB 0 1 Map.empty
146+
147+add_sprite x y img i
148+ = modify (\ctx -> ctx {sprites = Map.insert i (x,y,img) (sprites ctx)})
149+
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
154+
155+instance MonadIO m => Story (BuildSprites m) where
156+ story _c (BuildSprites q) = BuildSprites q
157+ quest (BuildSprites g) (BuildSprites as) = BuildSprites (g >> as)
158+ empty_aspects = BuildSprites $ return ()
159+ add_known_history h (BuildSprites as) = BuildSprites as
160+ add_known_obj obj (BuildSprites as) = BuildSprites as
161+ add_unknown_history h (BuildSprites as) = BuildSprites as
162+ add_unknown_obj obj (BuildSprites as) = BuildSprites as
163+ animate_obj _t = BuildSprites $ do
164+ add_random_sprite '@' =<< new_sprite_ID
165+ inanimate_obj _t = BuildSprites $ do
166+ add_random_sprite 'X' =<< new_sprite_ID
167+ history = BuildSprites $ return ()
168+ dispose_obj (BuildSprites obj) = BuildSprites obj
169+ acquire_obj (BuildSprites obj) = BuildSprites obj
170+ named (BuildSprites obj) n = BuildSprites obj
171+
172+render_sprites = foldMap render_sprite . sprites
173+render_sprite (x,y,img) = return $ translate x y img
150174
151175main = do
152176 putStrLn $ unTellStory story_0
153177 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
179+ print sprite_db
180+ let imgs = render_sprites sprite_db
181+ p = pic_for_layers imgs
182+ withVty $ flip update p
183+ threadDelay 5000000
184+ withVty $ shutdown
185+ return ()