-
Notifications
You must be signed in to change notification settings - Fork 1
/
Model.hs
301 lines (266 loc) · 8.61 KB
/
Model.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
{-# LANGUAGE TemplateHaskell #-}
-- | Types for the state of the game.
module Game.Model where
import qualified Data.Text as T
import Game.Prelude
import Text.Read (readMaybe)
-- | The core game state.
data Model = Model
{ modelPlaces :: HashMap PlaceId Place
, modelShips :: HashMap ShipId Ship
, modelLog :: Log
-- ^ Records what combat occured this turn. Cleared at the start of each turn.
, modelTurn :: Natural
, modelNextId :: Natural
-- ^ The supply for place and ship ids, which must be unique.
, modelRandom :: Gen
} deriving stock (Generic)
deriving anyclass (ToJSON)
-- | The starting @Model@. Creates an empty @modelPlaces@ and @modelShips@.
-- These will be filled out by the a chosen scenario at the start of the game.
init :: Gen -> Model
init gen =
Model
{ modelPlaces = mempty
, modelShips = mempty
, modelLog = mempty
, modelTurn = 1
, modelNextId = 1
, modelRandom = gen
}
--------------------------------------------------------------------------------
-- * Places
--------------------------------------------------------------------------------
-- | Places are either bases or ruins.
-- These are the only locations ships can move to.
data Place = Place
{ placeName :: Text
, placePoint :: Point
, placeSize :: PlaceSize
, placeType :: PlaceType
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | Invariant: unique per game.
newtype PlaceId
= PlaceId Natural
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Hashable, ToJSON, ToJSONKey, FromJSON, FromJSONKey)
-- | Affects how large a base at this place can grow.
--
-- Fixed for the duration of the game.
data PlaceSize
= Small
| Medium
| Large
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | Each place is either a base or a ruin.
data PlaceType
= PBase Base
| Ruin
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | __Player guide starts here__.
--
-- Bases are either owned by you, neutral, or owned by your opponent.
--
-- Each player starts with at least one base and wins by destroying all the
-- opponent's bases.
--
-- Friendly bases can build population, installations, and ships.
-- The higher the population, the faster it builds things.
--
-- Ships are used for diplomacy, combat, and fighting disease.
--
-- __Next__: 'Update.update'
data Base = Base
{ baseOwner :: Owner
, basePopulation :: Population
, baseDisease :: Disease
, baseInstallations :: Set Installation
, baseShields :: Natural
, baseBuilding :: BuildOrder
, baseInProgress :: HashMap BuildOrder Double
-- ^ Tracks progress for each build order. Production only goes towards
-- the build order in @baseBuilding@, but since you can switch what that
-- is this also tracks partially completed build orders.
--
-- Note that switching build orders wastes a turn of production
-- while the economy re-tools.
--
-- See "Game.Update.Build" for details.
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | Bases are either owned by a player or neutral.
data Owner
= PlayerOwner Player
| Neutral (HashMap Player Natural)
-- ^ The HashMap is the friendliness of the neutral base towards the players.
-- It starts at 0 for each player.
--
-- When a player is the only one with ships at a neutral base, it ticks
-- up by one for them. When it reaches 5 the base switches allegiance to them.
--
-- See "Game.Update.Diplomacy" for details.
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | Population can only grow to a Megacity or Ecumenopolis when the host
-- Place has a large enough 'PlaceSize'. So we don't derive 'Enum' or
-- 'Bounded' for it because the behavior of 'maxBound' and 'nextBounded' will be
-- incorrect.
--
-- Instead we define @minPop@, @prevPop@ and @incrementPop@
-- in "Game.Update.Shared".
data Population
= Outpost
| Settlement
| City
| Megacity
| Ecumenopolis
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | See "Game.Update.Disease" for details.
data Disease
= Healthy
| Latent
| Plague
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
deriving anyclass (ToJSON)
-- | __Player guide previous__: 'ShipType'
--
-- Base installations give special abilities, see below for details.
--
-- __This concludes the player guide__.
data Installation
= Shield
-- ^ Bases with a shield have their 'baseShields' set to five instead of
-- zero.
--
-- If a base with @baseShields@ is bombarded, its @baseShields@
-- is reduced instead of its 'basePopulation'.
--
-- If a 'Shield' is present, 'baseShields' recharges by one every turn
-- the base isn't bombarded (to a max of five).
| Booster
-- ^ Friendly ships leaving a base with a booster travel at x2 speed
-- until they reach their destination.
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
data BuildOrder
= BuildPopulation
| BuildShip ShipType
| BuildShield
| BuildBooster
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Hashable, ToJSON, ToJSONKey, FromJSON)
--------------------------------------------------------------------------------
-- * Ships
--------------------------------------------------------------------------------
data Ship = Ship
{ shipPlayer :: Player
, shipLocation :: ShipLocation
, shipType :: ShipType
, shipShields :: Bool
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
-- | Invariant: unique per game.
newtype ShipId
= ShipId Natural
deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Hashable, ToJSON, ToJSONKey, FromJSON, FromJSONKey)
data ShipLocation
= AtPlace PlaceId
| InFlight Point PlaceId IsBoosted
-- ^ Currently at Point, flying to PlaceId
| Destroyed
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON, ToJSONKey)
data IsBoosted
= Boosted
| NotBoosted
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON, ToJSONKey)
-- | __Player guide previous__: 'Game.Update.Disease.diseaseSpread'
--
-- There are multiple kinds of ships, see below for details.
--
-- __Next__: 'Installation'
data ShipType
= Corvette
-- ^ Standard ship.
--
-- * __Move__: 3
-- * __Attack__: 1
-- * __Cost__: 5
| Station
-- ^ Defensive ship, so slow it's almost an installation.
--
-- * __Move__: 1
-- * __Attack__: 1
-- * __Cost__: 8
--
-- The first station on each side in a battle has +2 attack,
-- the second has +1.
--
-- The first two stations at a friendly base give +0.1 production.
| Monitor
-- ^ A bombardment focused ship.
--
-- * __Move__: 3
-- * __Attack__: 3
-- * __Cost__: 15
--
-- If bombarding and a 'Shield' installation is present, it's destroyed.
-- If bombarding and a 'Shield' isn't present, the base is destroyed.
deriving stock (Eq, Ord, Show, Generic)
-- Order matters for the derived Ord instance since we use it to
-- show more important ships in the UI first
deriving anyclass (Hashable, ToJSON, FromJSON)
--------------------------------------------------------------------------------
-- * Other
--------------------------------------------------------------------------------
data Player
= Player1
| Player2
deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)
deriving anyclass (Hashable, ToJSON, ToJSONKey, FromJSON)
data Log = Log
{ logCombat :: HashMap PlaceId (Set ShipId)
} deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (ToJSON)
instance Semigroup Log where
Log a1 <> Log a2 = Log (a1 <> a2)
instance Monoid Log where
mempty = Log mempty
newtype Gen
= Gen { unGen :: StdGen }
deriving (Show)
instance Eq Gen where
-- | Needed for testing invertability through JSON.
Gen a == Gen b = show a == show b
instance ToJSON Gen where
toJSON (Gen stdGen) =
String (T.pack (show stdGen))
instance FromJSON Gen where
parseJSON = withText "Gen" $ \t ->
case readMaybe (T.unpack t) of
Nothing -> fail ("Couldn't parse Gen: " <> T.unpack t)
Just stdGen -> pure (Gen stdGen)
data Orders = Orders
{ ordersBuild :: HashMap PlaceId BuildOrder
, ordersEmbark :: HashMap ShipId PlaceId
} deriving stock (Eq, Show, Ord, Generic)
deriving anyclass (ToJSON, FromJSON)
instance Semigroup Orders where
Orders a1 b1 <> Orders a2 b2 = Orders (a1 <> a2) (b1 <> b2)
instance Monoid Orders where
mempty = Orders mempty mempty
-- * Lenses
mkLenses ''Base
mkLenses ''Log
mkLenses ''Model
mkLenses ''Place
mkLenses ''Ship
mkLenses ''Orders
makePrisms ''Owner
makePrisms ''PlaceType