@@ -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
5−
6−import Text.Printf
7−
8−import Graphics.Vty
9−import Graphics.Vty.Inline
10−
11−import Control.Applicative
12−import Control.Concurrent (threadDelay)
13−import Control.Monad
14−import Control.Monad.Trans
15−import Control.Monad.Trans.State.Strict
16−
17−import Data.Foldable
18−import Data.Map.Strict (Map)
19−import qualified Data.Map.Strict as Map
20−
21−import System.Random
22−
23−-- Characters are identified by Names
24−type Character = Name
25−type Name = String
26−type Type = String
27−
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
33−
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
41−
42− -- Aspects are animate objects, inanimate objects or histories.
43− animateObj :: Type -> repr Object
44− inanimateObj :: Type -> repr Object
45− history :: repr History
46−
47− -- The goal is to acquire, or dispose of an object.
48− disposeObj :: repr Object -> repr Goal
49− acquireObj :: repr Object -> repr Goal
50−
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
54−
55−data Quest
56−data History
57−data Goal
58−data Aspects
59−data Object
60−
61−story0 =
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
66−
67−{- TEMPLATE
68−instance Story X where
69− story c q =
70− quest g as =
71− emptyAspects =
72− addKnownHistory h as =
73− addKnownObj obj as =
74− addUnknownHistory h as =
75− addUnknownObj obj as =
76− animateObj t =
77− inanimateObj t =
78− history =
79− disposeObj obj =
80− acquireObj obj =
81− named obj n =
82−-}
83−
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)
99−
100−newtype TellStory t = TellStory { unTellStory :: String }
101−
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
123−
124−newtype BuildSprites m t = BuildSprites {buildSprites :: StateT SpriteDB m ()}
125−
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
132− }
133− deriving (Show)
134−
135−getSpriteID :: MonadIO m => StateT SpriteDB m Int
136−getSpriteID = gets thisSpriteID
137−
138−newSpriteID :: MonadIO m => StateT SpriteDB m Int
139−newSpriteID = do
140− ctx <- get
141− let theID = nextSpriteID ctx
142− put $ ctx {nextSpriteID = theID + 1, thisSpriteID = theID}
143− return theID
144−
145−emptySpriteDb = SpriteDB 0 1 Map.empty
146−
147−addSprite x y img i
148− = modify (\ctx -> ctx {sprites = Map.insert i (x,y,img) (sprites ctx)})
149−
150−addRandomSprite c i = do
151− let img = char def_attr c
152− [x,y] <- liftIO $ replicateM 2 $ randomRIO (-100,100)
153− addSprite 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− 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
171−
172−renderSprites = foldMap renderSprite . sprites
173−renderSprite (x,y,img) = return $ translate x y img
174−
175−main = do
176− putStrLn $ unTellStory story0
177− putStrLn $ unShowStory story0
178− spriteDb <- execStateT (buildSprites story0) emptySpriteDb
179− print spriteDb
180− let imgs = renderSprites spriteDb
181− p = picForLayers imgs
182− withVty $ flip update p
183− threadDelay 5000000
184− withVty $ shutdown
185− return ()