@@ -0,0 +1,132 @@
1+{-# LANGUAGE NoMonomorphismRestriction #-}
2+module RougeStory where
3+
4+import Text.Printf
5+
6+import Graphics.Vty
7+import Graphics.Vty.Inline
8+
9+-- Characters are identified by Names
10+type Character = Name
11+type Name = String
12+type Type = String
13+
14+-- The game is the view of a story.
15+class Story repr where
16+ -- A story is the quest of a character which becomes a history
17+ story :: Character -> repr Quest -> repr History
18+ quest :: repr Goal -> repr Aspects -> repr Quest
19+
20+ -- A quest is for a goal where some aspects are known and others unknown.
21+ -- TODO: abstract to any Foldable?
22+ empty_aspects :: repr Aspects
23+ add_known_history :: repr History -> repr Aspects -> repr Aspects
24+ add_known_obj :: repr Object -> repr Aspects -> repr Aspects
25+ add_unknown_history :: repr History -> repr Aspects -> repr Aspects
26+ add_unknown_obj :: repr Object -> repr Aspects -> repr Aspects
27+
28+ -- Aspects are animate objects, inanimate objects or histories.
29+ animate_obj :: Type -> repr Object
30+ inanimate_obj :: Type -> repr Object
31+ history :: Type -> repr History
32+
33+ -- The goal is to acquire, or dispose of an object.
34+ dispose_obj :: repr Object -> repr Goal
35+ acquire_obj :: repr Object -> repr Goal
36+
37+ -- What is an object? Well, that's anything that fits in the story language.
38+ -- Which at least means it's something that can be named
39+ named :: repr Object -> Name -> repr Object
40+
41+data Quest
42+data History
43+data Goal
44+data Aspects
45+data Object
46+
47+story_0 =
48+ let bob = animate_obj "Human" `named` "Bob"
49+ the_quest = quest (dispose_obj (inanimate_obj "YoYo" `named` "The Kitten Slayer"))
50+ (add_known_obj bob empty_aspects)
51+ in story "Bob" the_quest
52+
53+{- TEMPLATE
54+instance Story X where
55+ story c q =
56+ quest g as =
57+ empty_aspects =
58+ add_known_history h as =
59+ add_known_obj obj as =
60+ add_unknown_history h as =
61+ add_unknown_obj obj as =
62+ animate_obj t =
63+ inanimate_obj t =
64+ history t =
65+ dispose_obj obj =
66+ acquire_obj obj =
67+ named obj n =
68+-}
69+
70+newtype ShowStory t = ShowStory { unShowStory :: String }
71+instance Story ShowStory where
72+ story c q = ShowStory $ printf "History(%s,%s)" c (unShowStory q)
73+ quest g as = ShowStory $ printf "Quest(%s,%s)" (unShowStory g) (unShowStory as)
74+ empty_aspects = ShowStory $ printf "EmptyAspects"
75+ add_known_history h as = ShowStory $ printf "Known(%s):%s" (unShowStory h) (unShowStory as)
76+ add_known_obj obj as = ShowStory $ printf "Known(%s):%s" (unShowStory obj) (unShowStory as)
77+ add_unknown_history h as = ShowStory $ printf "Unknown(%s):%s" (unShowStory h) (unShowStory as)
78+ add_unknown_obj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)
79+ animate_obj t = ShowStory $ printf "%s :: AnimateObj" t
80+ inanimate_obj t = ShowStory $ printf "%s :: InanimateObj" t
81+ history t = ShowStory $ printf "%s :: History" t
82+ dispose_obj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)
83+ acquire_obj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)
84+ named obj n = ShowStory $ printf "%s+Name(%s)" (unShowStory obj) (show n)
85+
86+newtype TellStory t = TellStory { unTellStory :: String }
87+
88+instance Story TellStory where
89+ story c (TellStory quest) = TellStory $ "The story of " ++ c ++ " on the quest " ++ quest
90+ quest (TellStory g) (TellStory as)
91+ | as == "" = TellStory $ g ++ "."
92+ | otherwise = TellStory $ g ++ ". In a world where... " ++ as
93+ empty_aspects = TellStory ""
94+ add_known_history (TellStory h) (TellStory as)
95+ = TellStory $ "Our hero knows the tale of\n\t" ++ h ++ ".\n" ++ as
96+ add_known_obj (TellStory obj) (TellStory as)
97+ = TellStory $ "Our hero knows of " ++ obj ++ ". " ++ as
98+ add_unknown_history _ as = as
99+ add_unknown_obj _ as = as
100+ animate_obj t = TellStory t
101+ inanimate_obj t = TellStory t
102+ history t = TellStory t
103+ dispose_obj (TellStory obj)
104+ = TellStory $ "to dispose of the accursed " ++ obj
105+ acquire_obj (TellStory obj)
106+ = TellStory $ "to acquire the great " ++ obj
107+ named (TellStory obj) name
108+ = TellStory $ obj ++ " with the name " ++ name
109+
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+-}
128+
129+main = do
130+ putStrLn $ unTellStory story_0
131+ putStrLn $ unShowStory story_0
132+ withVty $ flip update (compose_to_picture story_0)