1{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2
3module Types where
4
5import Control.Monad.ST
6import Control.Monad.State.Strict
7import Data.Vector.Mutable (MVector)
8import Data.Vector (Vector)
9import Data.Default
10import Data.Tuple
11import Data.Set (Set)
12import qualified Data.Set as S
13import qualified Data.Map as M
14import Data.CaseInsensitive (CI)
15import UI.NCurses (Event)
16import System.Random (StdGen)
17
18-- Most code that updates the world runs in this monad stack.
19type M = StateT S (ST RealWorld)
20
21-- User input.
22type Input = Char
23
24-- Game state.
25data S = S
26	{ world :: World
27	, flipSide :: World
28	, player :: Player
29	, bottomBuffer :: (World, World)
30	, topBuffer :: Int
31	, peruser :: Peruser
32	, randSource :: Rand
33	, helpShown :: Bool
34	, messages :: [String]
35	, spells :: Set Spell
36	, poisons :: M.Map (CI Char) PoisonEffect
37	, windows :: [Window]
38	}
39
40data Window = Window Pos [String]
41
42data Rand = Rand StdGen | DefRand StdGen | NoRand
43
44data Side = CurrentSide | FlipSide | InSide
45	deriving (Eq)
46
47type Vec2 a = MVector RealWorld (MVector RealWorld a)
48type World = Vec2 Char
49
50-- View of the game to display.
51data View = View
52	{ viewVisible :: Vector (Vector Char)
53	, viewPlayer :: Player
54	, viewWindows :: [Window]
55	, viewForceRedraw :: Bool
56	}
57
58type Pos = (Int, Int) -- x, y (from upper left corner)
59
60type Offset = (Int -> Int, Int -> Int)
61
62data Peruser = Peruser
63	{ peruseSpeed :: Int -- ^ lower is faster
64	, peruseCountDown :: Int -- ^ next scroll at 0
65	}
66
67instance Default Peruser where
68	def = Peruser 5 10 -- 10 gives extra time before first at start of game
69
70data Player = Player
71	{ playerHead :: Pos
72	, playerSwallowing :: Maybe Char
73	, playerBody :: [Segment] -- ^ first segment is next to head
74	, playerLen :: Int -- ^ including head
75	, spellCaster :: Bool
76	, playerSpells :: Set Spell
77	, playerEnergized :: Bool
78	, playerBerzerk :: Bool
79	, playerStaggering :: Bool
80	}
81
82instance Default Player where
83	def = Player
84		{ playerHead = (6,6)
85		, playerSwallowing = Nothing
86		, playerBody = []
87		, playerLen = 5
88		, spellCaster = False
89		, playerSpells = S.empty
90		, playerEnergized = False
91		, playerBerzerk = False
92		, playerStaggering = False
93		}
94
95data Segment = Segment
96	{ segmentPos :: Pos
97	, segmentDirection :: Direction
98	, segmentSide :: Side
99	, segmentSwallowed :: Maybe Char
100	, segmentInvoked :: Bool
101	}
102
103data Direction = DLeft | DRight | DUp | DDown | DDive
104	deriving (Eq, Ord, Show, Bounded, Enum)
105
106bodyChar :: Direction -> Char
107bodyChar DLeft = '<'
108bodyChar DRight = '>'
109bodyChar DUp = '^'
110bodyChar DDown = 'v'
111-- not visible, but this prevents accidentially genociding it
112bodyChar DDive = '|'
113
114directionOffset :: Direction -> Offset
115directionOffset DLeft = (pred, id)
116directionOffset DRight = (succ, id)
117directionOffset DUp = (id, pred)
118directionOffset DDown = (id, succ)
119directionOffset DDive = (id, id)
120
121type PoisonEffect = Char -> M NextStep -> M NextStep
122
123data Spell = Spell
124	{ spellName :: SpellName
125	, spellHint :: String
126	, spellIngredients :: Set (CI Char)
127	, spellWord :: String -- same as ingredients, but ordered
128	, spellAction :: (M NextStep -> M NextStep)
129	}
130
131type SpellName = String
132
133instance Eq Spell where
134	a == b = (spellName a, spellIngredients a) == (spellName b, spellIngredients b)
135
136instance Ord Spell where
137	compare a b = (spellName a, spellIngredients a) `compare` (spellName b, spellIngredients b)
138
139-- Calculates a new state of the world based on the provided Input.
140-- Returns new View, and a continuation to handle the next step.
141type Step = Event -> M NextStep
142data NextStep = NextStep View (Maybe Step)
143
144type Level = [String]
145
146-- Flips to the other side of the scroll.
147class Flippable a where
148	flipOver :: a -> a
149
150instance Flippable Side where
151	flipOver CurrentSide = FlipSide
152	flipOver FlipSide = CurrentSide
153	flipOver InSide = InSide
154
155instance Flippable S where
156	flipOver s = s
157		{ world = flipSide s
158		, flipSide = world s
159		, player = flipOver (player s)
160		, bottomBuffer = swap (bottomBuffer s)
161		}
162
163instance Flippable Player where
164	flipOver p = p { playerBody = map flipOver (playerBody p) }
165
166instance Flippable Segment where
167	flipOver s = s { segmentSide = flipOver (segmentSide s) }
168
169class Positioned a where
170	getPos :: a -> Pos
171	offsetPos :: Offset -> a -> a
172
173instance Positioned Pos where
174	getPos = id
175	offsetPos (fx, fy) (x, y) = (fx x, fy y)
176
177instance Positioned Player where
178	getPos = playerHead
179	offsetPos f p = p
180		{ playerHead = offsetPos f (playerHead p)
181		, playerBody = map (offsetPos f) (playerBody p)
182		}
183
184instance Positioned Segment where
185	getPos = segmentPos
186	offsetPos f s = s { segmentPos = offsetPos f (segmentPos s) }
187
188data Difficulty
189	= Easy
190	| Medium
191	| Hard
192