@@ -1,185 +0,0 @@
1−{-# LANGUAGE NoMonomorphismRestriction #-}
2−-- investigation using typed tagless interpretter of an AST representation of a story.
3−-- Use extensible effects instead?
4−module RougeStory where
9−import Graphics.Vty.Inline
11−import Control.Applicative
12−import Control.Concurrent (threadDelay)
14−import Control.Monad.Trans
15−import Control.Monad.Trans.State.Strict
18−import Data.Map.Strict (Map)
19−import qualified Data.Map.Strict as Map
23−-- Characters are identified by Names
28−-- The game is the view of a story.
29−class Story repr where
30− -- A story is the quest of a character which becomes a history
31− story :: Character -> repr Quest -> repr History
32− quest :: repr Goal -> repr Aspects -> repr Quest
34− -- A quest is for a goal where some aspects are known and others unknown.
35− -- TODO: abstract to any Foldable?
36− emptyAspects :: repr Aspects
37− addKnownHistory :: repr History -> repr Aspects -> repr Aspects
38− addKnownObj :: repr Object -> repr Aspects -> repr Aspects
39− addUnknownHistory :: repr History -> repr Aspects -> repr Aspects
40− addUnknownObj :: repr Object -> repr Aspects -> repr Aspects
42− -- Aspects are animate objects, inanimate objects or histories.
43− animateObj :: Type -> repr Object
44− inanimateObj :: Type -> repr Object
45− history :: repr History
47− -- The goal is to acquire, or dispose of an object.
48− disposeObj :: repr Object -> repr Goal
49− acquireObj :: repr Object -> repr Goal
51− -- What is an object? Well, that's anything that fits in the story language.
52− -- Which at least means it's something that can be named
53− named :: repr Object -> Name -> repr Object
62− let bob = animateObj "Human" `named` "Bob"
63− theQuest = quest (disposeObj (inanimateObj "YoYo" `named` "The Kitten Slayer"))
64− (addKnownObj bob emptyAspects)
65− in story "Bob" theQuest
68−instance Story X where
72− addKnownHistory h as =
74− addUnknownHistory h as =
75− addUnknownObj obj as =
84−newtype ShowStory t = ShowStory { unShowStory :: String }
85−instance Story ShowStory where
86− story c q = ShowStory $ printf "History(%s,%s)" c (unShowStory q)
87− quest g as = ShowStory $ printf "Quest(%s,%s)" (unShowStory g) (unShowStory as)
88− emptyAspects = ShowStory $ printf "EmptyAspects"
89− addKnownHistory h as = ShowStory $ printf "Known(%s):%s" (unShowStory h) (unShowStory as)
90− addKnownObj obj as = ShowStory $ printf "Known(%s):%s" (unShowStory obj) (unShowStory as)
91− addUnknownHistory h as = ShowStory $ printf "Unknown(%s):%s" (unShowStory h) (unShowStory as)
92− addUnknownObj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)
93− animateObj t = ShowStory $ printf "%s :: AnimateObj" t
94− inanimateObj t = ShowStory $ printf "%s :: InanimateObj" t
95− history = ShowStory $ printf "History"
96− disposeObj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)
97− acquireObj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)
98− named obj n = ShowStory $ printf "%s+Name(%s)" (unShowStory obj) (show n)
100−newtype TellStory t = TellStory { unTellStory :: String }
102−instance Story TellStory where
103− story c (TellStory quest) = TellStory $ "The story of " ++ c ++ " on the quest " ++ quest
104− quest (TellStory g) (TellStory as)
105− | as == "" = TellStory $ g ++ "."
106− | otherwise = TellStory $ g ++ ". In a world where... " ++ as
107− emptyAspects = TellStory ""
108− addKnownHistory (TellStory h) (TellStory as)
109− = TellStory $ "Our hero knows the tale of\n\t" ++ h ++ ".\n" ++ as
110− addKnownObj (TellStory obj) (TellStory as)
111− = TellStory $ "Our hero knows of " ++ obj ++ ". " ++ as
112− addUnknownHistory _ as = as
113− addUnknownObj _ as = as
114− animateObj t = TellStory t
115− inanimateObj t = TellStory t
116− history = TellStory "History"
117− disposeObj (TellStory obj)
118− = TellStory $ "to dispose of the accursed " ++ obj
119− acquireObj (TellStory obj)
120− = TellStory $ "to acquire the great " ++ obj
121− named (TellStory obj) name
122− = TellStory $ obj ++ " with the name " ++ name
124−newtype BuildSprites m t = BuildSprites {buildSprites :: StateT SpriteDB m ()}
126−type Sprite = (Int, Int, Image)
127−type Collider = (Int,Int,Int,Int)
128−data SpriteDB = SpriteDB
129− { nextSpriteID :: Int -- globally monotonic. H: Can fst . findMax + 1 be used?
130− , thisSpriteID :: Int
131− , sprites :: Map Int Sprite
135−getSpriteID :: MonadIO m => StateT SpriteDB m Int
136−getSpriteID = gets thisSpriteID
138−newSpriteID :: MonadIO m => StateT SpriteDB m Int
141− let theID = nextSpriteID ctx
142− put $ ctx {nextSpriteID = theID + 1, thisSpriteID = theID}
145−emptySpriteDb = SpriteDB 0 1 Map.empty
148− = modify (\ctx -> ctx {sprites = Map.insert i (x,y,img) (sprites ctx)})
150−addRandomSprite c i = do
151− let img = char def_attr c
152− [x,y] <- liftIO $ replicateM 2 $ randomRIO (-100,100)
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− emptyAspects = BuildSprites $ return ()
159− addKnownHistory h (BuildSprites as) = BuildSprites as
160− addKnownObj obj (BuildSprites as) = BuildSprites as
161− addUnknownHistory h (BuildSprites as) = BuildSprites as
162− addUnknownObj obj (BuildSprites as) = BuildSprites as
163− animateObj _t = BuildSprites $ do
164− addRandomSprite '@' =<< newSpriteID
165− inanimateObj _t = BuildSprites $ do
166− addRandomSprite 'X' =<< newSpriteID
167− history = BuildSprites $ return ()
168− disposeObj (BuildSprites obj) = BuildSprites obj
169− acquireObj (BuildSprites obj) = BuildSprites obj
170− named (BuildSprites obj) n = BuildSprites obj
172−renderSprites = foldMap renderSprite . sprites
173−renderSprite (x,y,img) = return $ translate x y img
176− putStrLn $ unTellStory story0
177− putStrLn $ unShowStory story0
178− spriteDb <- execStateT (buildSprites story0) emptySpriteDb
180− let imgs = renderSprites spriteDb
181− p = picForLayers imgs
182− withVty $ flip update p