├── json-relay ├── stack.yaml ├── test │ ├── Spec.hs │ └── JsonRelay │ │ └── ServerSpec.hs ├── README.md ├── stack.yaml.lock ├── Main.hs ├── package.yaml ├── src │ └── JsonRelay │ │ ├── Shared.hs │ │ ├── Client.hs │ │ └── Server.hs └── json-relay.cabal ├── .gitignore ├── explore ├── stack.yaml ├── serve ├── unpack ├── index └── README.md ├── test ├── Spec.hs ├── Lib │ └── MathSpec.hs ├── Game │ └── ModelSpec.hs └── LayoutSpec.hs ├── misc ├── screenshot.png ├── Main.hs ├── run-dot ├── run-stylish-haskell ├── core-modules.dot ├── run-cloc └── generated │ ├── sloc-game.svg │ ├── sloc-ui.svg │ ├── sloc-json-relay.svg │ └── core-modules.svg ├── stack.yaml ├── stack.yaml.lock ├── src ├── Game.hs ├── Game │ ├── Update.hs │ ├── Outcome.hs │ ├── Update │ │ ├── Diplomacy.hs │ │ ├── Bombard.hs │ │ ├── Combat.hs │ │ ├── Travel.hs │ │ ├── Disease.hs │ │ ├── Build.hs │ │ └── Shared.hs │ ├── Prelude.hs │ └── Model.hs ├── Scenario │ ├── Crisis.hs │ └── Tannen.hs ├── Lib │ └── Gloss.hs ├── View │ ├── Ship.hs │ ├── Hud.hs │ └── Board.hs ├── Cli.hs ├── Model.hs ├── View.hs ├── App.hs ├── Update.hs └── Layout.hs ├── .stylish-haskell.yaml ├── docs └── install.md ├── package.yaml ├── README.md └── hermetic.cabal /json-relay/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.0 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .haskell-code-explorer 2 | explore/deps 3 | -------------------------------------------------------------------------------- /explore/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.0 2 | allow-newer: true 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /json-relay/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /misc/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/seagreen/hermetic/HEAD/misc/screenshot.png -------------------------------------------------------------------------------- /explore/serve: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | haskell-code-server --package .. --package ../json-relay --packages deps 4 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.0 2 | packages: 3 | - . 4 | # - json-relay 5 | extra-deps: 6 | - ./json-relay 7 | -------------------------------------------------------------------------------- /misc/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Cli 4 | import Prelude 5 | 6 | main :: IO () 7 | main = 8 | Cli.main 9 | -------------------------------------------------------------------------------- /explore/unpack: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # this also creates the "deps" directory" 4 | 5 | cd .. 6 | stack ls dependencies | tr " " - | xargs -i stack unpack {} --to explore/deps 7 | -------------------------------------------------------------------------------- /misc/run-dot: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | # Dependencies: 4 | # 5 | # sudo apt install graphviz 6 | 7 | dot -Tsvg ./misc/core-modules.dot -o ./misc/generated/core-modules.svg 8 | -------------------------------------------------------------------------------- /json-relay/README.md: -------------------------------------------------------------------------------- 1 | # Summary 2 | 3 | The executable is a server with rooms. It bounces JSON messages between clients in the same room. 4 | 5 | There's also a one-module Haskell library for making clients: [./src/JsonRelay/Client.hs](./src/JsonRelay/Client.hs). 6 | 7 | Status: VERY quick and dirty. Don't use this for anything serious. 8 | -------------------------------------------------------------------------------- /misc/run-stylish-haskell: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # if you replace this with `find` make sure to exclude .stack-work: 4 | shopt -s globstar 5 | 6 | stylish-haskell --inplace ./src/**/*.hs 7 | stylish-haskell --inplace ./misc/**/*.hs 8 | stylish-haskell --inplace ./test/**/*.hs 9 | stylish-haskell --inplace ./json-relay/**/*.hs 10 | -------------------------------------------------------------------------------- /explore/index: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | startdir=$(pwd) 4 | 5 | cd .. 6 | stack build --fast 7 | haskell-code-indexer-8.6.3 --package . 8 | cd "$startdir" 9 | 10 | cd ../json-relay 11 | stack build --fast 12 | haskell-code-indexer-8.6.3 --package . 13 | cd "$startdir" 14 | 15 | for p in deps/* 16 | do ( 17 | cd "$p" 18 | cp ../../stack.yaml . 19 | stack build --fast 20 | haskell-code-indexer-8.6.3 --package . 21 | ) done 22 | -------------------------------------------------------------------------------- /test/Lib/MathSpec.hs: -------------------------------------------------------------------------------- 1 | module Lib.MathSpec where 2 | 3 | import Game.Prelude 4 | import Test.Hspec 5 | 6 | spec :: Spec 7 | spec = do 8 | describe "rectangleCoordinates" $ do 9 | it "knows when a point is outside the rectangle" $ do 10 | rectangleCoordinates (0,0) (Rectangle (2,2) 1 1) `shouldBe` Nothing 11 | 12 | it "reports a point in the rectangle correctly" $ do 13 | rectangleCoordinates (3,3) (Rectangle (2,2) 5 5) `shouldBe` Just (1,1) 14 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 491155 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/0.yaml 11 | sha256: 8d3c33e0feab8e04b9ed31452e0219a2b827ed1338c809f79d986c71a177e6ba 12 | original: lts-13.0 13 | -------------------------------------------------------------------------------- /json-relay/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 491155 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/0.yaml 11 | sha256: 8d3c33e0feab8e04b9ed31452e0219a2b827ed1338c809f79d986c71a177e6ba 12 | original: lts-13.0 13 | -------------------------------------------------------------------------------- /test/Game/ModelSpec.hs: -------------------------------------------------------------------------------- 1 | module Game.ModelSpec where 2 | 3 | import Control.Monad.Random 4 | import Game.Model 5 | import Game.Prelude 6 | import Test.Hspec 7 | import Test.Hspec.QuickCheck (modifyMaxSuccess) 8 | import qualified Test.QuickCheck as QuickCheck 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "Gen" $ do 13 | modifyMaxSuccess (+ 900) $ it "is invertible through JSON" $ 14 | QuickCheck.property $ \(n :: Int) -> 15 | let gen = Gen (mkStdGen n) 16 | in Just gen `shouldBe` decode (encode gen) 17 | -------------------------------------------------------------------------------- /explore/README.md: -------------------------------------------------------------------------------- 1 | # About 2 | 3 | Instructions for using [haskell-code-explorer](https://github.com/alexwl/haskell-code-explorer) to browse this project. 4 | 5 | # Use 6 | 7 | ```sh 8 | $ ./unpack 9 | 10 | 11 | $ ./index 12 | 13 | 14 | $ ./serve 15 | ``` 16 | 17 | Then go to `localhost:8080` 18 | 19 | # Notes 20 | 21 | Packages are stored in `./deps` (`./explore/deps` from the top level of the project). 22 | 23 | The `stack.yaml` in this directory is copied into each package in `./deps` by `index`. 24 | -------------------------------------------------------------------------------- /src/Game.hs: -------------------------------------------------------------------------------- 1 | -- | Just re-exports. 2 | module Game 3 | ( -- * Good starting points for reading the code 4 | module Game.Model 5 | , module Game.Update 6 | 7 | -- * Other re-exports 8 | , module X 9 | ) where 10 | 11 | import Game.Model 12 | import Game.Update 13 | 14 | import Game.Outcome as X 15 | import Game.Update.Build as X hiding (build) 16 | import Game.Update.Combat as X 17 | import Game.Update.Diplomacy as X 18 | import Game.Update.Disease as X 19 | import Game.Update.Shared as X 20 | import Game.Update.Travel as X 21 | -------------------------------------------------------------------------------- /misc/core-modules.dot: -------------------------------------------------------------------------------- 1 | digraph { 2 | 3 | subgraph cluster_1 { 4 | label="Game rules" 5 | color=red 6 | "Game.Model" -> "Game.Update" 7 | } 8 | 9 | subgraph cluster_2 { 10 | label="Gloss UI" 11 | color=blue 12 | 13 | { rank=n; View } // Show View to the left of Update 14 | 15 | "Game.Model" -> Model 16 | "Game.Update" -> Layout 17 | Model -> Layout 18 | Layout -> Update 19 | Layout -> View 20 | Update -> App 21 | View -> App 22 | App -> Cli 23 | } 24 | 25 | subgraph cluster_3 { 26 | label="Server" 27 | color=green3 28 | "JsonRelay.Client" -> "App" 29 | } 30 | } 31 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: false 4 | top_level_patterns: false 5 | records: false 6 | - imports: 7 | align: none 8 | list_align: after_alias 9 | pad_module_names: false 10 | long_list_align: new_line 11 | empty_list_align: inherit 12 | list_padding: 2 13 | separate_lists: false 14 | space_surround: false 15 | - language_pragmas: 16 | style: vertical 17 | align: false 18 | remove_redundant: false 19 | - tabs: 20 | spaces: 2 21 | - trailing_whitespace: {} 22 | columns: 80 23 | newline: lf 24 | language_extensions: 25 | - DeriveAnyClass 26 | - DerivingStrategies 27 | - GeneralizedNewtypeDeriving 28 | - LambdaCase 29 | - NamedFieldPuns 30 | - OverloadedStrings 31 | - PackageImports 32 | - RecordWildCards 33 | - ScopedTypeVariables 34 | -------------------------------------------------------------------------------- /src/Game/Update.hs: -------------------------------------------------------------------------------- 1 | module Game.Update 2 | ( update 3 | , updateM 4 | ) where 5 | 6 | import Control.Monad.Trans.State 7 | import Game.Model 8 | import Game.Prelude 9 | import qualified Game.Update.Bombard as Bombard 10 | import qualified Game.Update.Build as Build 11 | import qualified Game.Update.Combat as Combat 12 | import qualified Game.Update.Diplomacy as Diplomacy 13 | import qualified Game.Update.Disease as Disease 14 | import qualified Game.Update.Travel as Travel 15 | 16 | update :: HashMap Player Orders -> Model -> Model 17 | update orders = 18 | execState (updateM orders) 19 | 20 | updateM :: HashMap Player Orders -> State Model () 21 | updateM orders = do 22 | 23 | clearLog 24 | 25 | Travel.shipsEmbark (map ordersEmbark orders) 26 | 27 | Diplomacy.diplomacy 28 | Bombard.bombard 29 | Bombard.regenerateBaseShields 30 | 31 | Disease.diseaseSpread 32 | Disease.shipsHeal 33 | 34 | Travel.shipsTravel 35 | 36 | Combat.combat 37 | 38 | Build.build (map ordersBuild orders) 39 | 40 | modelTurnL += 1 41 | 42 | clearLog :: State Model () 43 | clearLog = 44 | modelLogL .= mempty 45 | -------------------------------------------------------------------------------- /json-relay/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Main where 4 | 5 | import Data.Version (showVersion) 6 | import Development.GitRev (gitHash) 7 | import JsonRelay.Server (Config(..), run) 8 | import Options.Applicative 9 | import Paths_json_relay (version) 10 | import Prelude 11 | 12 | main :: IO () 13 | main = 14 | run =<< runParser 15 | 16 | runParser :: IO Config 17 | runParser = 18 | customExecParser (prefs showHelpOnError) parserInfo 19 | 20 | parserInfo :: ParserInfo Config 21 | parserInfo = 22 | info 23 | (helper <*> versionOption <*> parser) 24 | fullDesc 25 | where 26 | versionOption :: Parser (a -> a) 27 | versionOption = 28 | infoOption 29 | (showVersion version <> " " <> $(gitHash)) 30 | ( long "version" 31 | <> help "Show version" 32 | ) 33 | 34 | parser :: Parser Config 35 | parser = 36 | Config 37 | <$> option auto 38 | ( long "port" 39 | <> short 'p' 40 | <> metavar "PORT" 41 | <> help "Self-explanatory" 42 | <> value 3000 43 | <> showDefault 44 | ) 45 | -------------------------------------------------------------------------------- /test/LayoutSpec.hs: -------------------------------------------------------------------------------- 1 | module LayoutSpec where 2 | 3 | import Game.Prelude 4 | import qualified Layout 5 | import Model 6 | import Test.Hspec 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "screenToBoardPoint works" $ do 11 | it "when the center is clicked" $ 12 | Layout.screenToBoardPoint NoZoom (BoardPoint 0 0) (ScreenPoint 0 0) 13 | `shouldBe` BoardPoint 0 0 14 | 15 | it "when a non-center point is clicked" $ do 16 | Layout.screenToBoardPoint NoZoom (BoardPoint 0 0) (ScreenPoint 2 2) 17 | `shouldBe` BoardPoint 2 2 18 | 19 | it "when zoomed out" $ do 20 | let zoom = ZoomOut 21 | zf = Layout.zoomFactor zoom 22 | 23 | Layout.screenToBoardPoint zoom (BoardPoint 0 0) (ScreenPoint 2 2) 24 | `shouldBe` BoardPoint (2 / zf) (2 / zf) 25 | 26 | it "when panned" $ do 27 | Layout.screenToBoardPoint NoZoom (BoardPoint 3 3) (ScreenPoint 2 2) 28 | `shouldBe` BoardPoint 5 5 29 | 30 | it "when panned and zoomed" $ do 31 | let zoom = ZoomOut 32 | zf = Layout.zoomFactor zoom 33 | 34 | Layout.screenToBoardPoint zoom (BoardPoint 3 3) (ScreenPoint 2 2) 35 | `shouldBe` BoardPoint (2 / zf + 3) (2 / zf + 3) 36 | -------------------------------------------------------------------------------- /misc/run-cloc: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | # Generate badges showing how many lines of code are in different 4 | # parts of the project. 5 | 6 | # Dependencies: 7 | # 8 | # sudo npm install -g gh-badges 9 | # sudo apt install jq 10 | 11 | ############################################################ 12 | # Game rules: ./src/Game/* 13 | ############################################################ 14 | 15 | SLOC1=$(cloc --json ./src/Game/* | jq '.Haskell.code') 16 | badge sloc "$SLOC1" :blue .svg > ./misc/generated/sloc-game.svg 17 | # | | 18 | # | The value (second part) of the badge. 19 | # | 20 | # The title (first part) of the badge. 21 | 22 | ############################################################ 23 | # Gloss UI: ./src *minus* game rules 24 | ############################################################ 25 | 26 | SLOC2=$(( $(cloc --json ./src | jq '.Haskell.code') - $SLOC1 )) 27 | badge sloc "$SLOC2" :blue .svg > ./misc/generated/sloc-ui.svg 28 | 29 | ############################################################ 30 | # json-relay 31 | ############################################################ 32 | 33 | SLOC3=$(cloc --json ./json-relay/src ./json-relay/Main.hs | jq '.Haskell.code') 34 | badge sloc "$SLOC3" :blue .svg > ./misc/generated/sloc-json-relay.svg 35 | -------------------------------------------------------------------------------- /misc/generated/sloc-game.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | sloc 21 | sloc 22 | 23 | 1079 24 | 1079 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /misc/generated/sloc-ui.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | sloc 21 | sloc 22 | 23 | 1940 24 | 1940 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /misc/generated/sloc-json-relay.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | sloc 21 | sloc 22 | 23 | 322 24 | 322 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /src/Game/Outcome.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Game.Outcome where 4 | 5 | import qualified Data.HashMap.Strict as HM 6 | import qualified Data.Set as Set 7 | import Game.Model 8 | import Game.Prelude 9 | 10 | data Outcome 11 | = Victor Player 12 | | AllDefeated 13 | | Ongoing 14 | deriving stock (Eq, Ord, Show, Generic) 15 | deriving anyclass (ToJSON) 16 | 17 | outcome :: Model -> Outcome 18 | outcome Model{..} = 19 | case mapMaybe hasBase (Set.toList enumerateAll :: [Player]) of 20 | [] -> 21 | AllDefeated 22 | 23 | [player] -> 24 | Victor player 25 | 26 | _ -> 27 | Ongoing 28 | where 29 | hasBase :: Player -> Maybe Player 30 | hasBase player = 31 | case mapMaybe (friendly player) (HM.elems modelPlaces) of 32 | [] -> Nothing 33 | _ -> Just player 34 | 35 | friendly :: Player -> Place -> Maybe Base 36 | friendly player place = do 37 | base <- case placeType place of 38 | Ruin -> 39 | Nothing 40 | 41 | PBase base -> 42 | Just base 43 | 44 | case baseOwner base of 45 | Neutral _ -> 46 | Nothing 47 | 48 | PlayerOwner basePlayer -> 49 | if basePlayer == player 50 | then Just base 51 | else Nothing 52 | 53 | -- * Lenses 54 | makePrisms ''Outcome 55 | -------------------------------------------------------------------------------- /src/Game/Update/Diplomacy.hs: -------------------------------------------------------------------------------- 1 | module Game.Update.Diplomacy 2 | ( diplomacy 3 | ) where 4 | 5 | import Control.Monad.Trans.State 6 | import qualified Data.HashMap.Strict as HM 7 | import Game.Model 8 | import Game.Prelude 9 | import Game.Update.Shared 10 | 11 | -- | __Player guide previous__: 'Base' 12 | -- 13 | -- Neutral bases keep track of friendliness towards each player, 14 | -- starting at zero. 15 | -- 16 | -- Each turn a player's ships are unopposed at a neutral base, that base's 17 | -- friendliness towards them goes up by one. At five the base switches 18 | -- to that player's control. 19 | -- 20 | -- __Next__: 'Game.Update.Combat.combat' 21 | diplomacy :: State Model () 22 | diplomacy = 23 | forOccupiedBases diplomacyAtPlace 24 | 25 | diplomacyAtPlace :: PlaceId -> Base -> Player -> HashMap ShipId Ship -> State Model () 26 | diplomacyAtPlace placeId base occupyingPlayer _ = 27 | case baseOwner base of 28 | PlayerOwner _ -> 29 | pure () 30 | 31 | Neutral oldFriendliness -> do 32 | let friendliness = 1 + fromMaybe 0 (HM.lookup occupyingPlayer oldFriendliness) 33 | if friendliness >= 5 34 | then 35 | adjustBase 36 | placeId 37 | (baseOwnerL .~ PlayerOwner occupyingPlayer) 38 | 39 | else 40 | adjustBase 41 | placeId 42 | (baseOwnerL . _Neutral %~ HM.insert occupyingPlayer friendliness) 43 | -------------------------------------------------------------------------------- /json-relay/package.yaml: -------------------------------------------------------------------------------- 1 | name: json-relay 2 | license: BSD3 3 | version: 0.0 4 | default-extensions: 5 | 6 | # Notable 7 | 8 | - NoImplicitPrelude 9 | 10 | # Other 11 | 12 | - DataKinds 13 | - DeriveAnyClass 14 | - DeriveFunctor 15 | - DeriveGeneric 16 | - DerivingStrategies 17 | - ExistentialQuantification 18 | - FlexibleContexts 19 | - FlexibleInstances 20 | - FunctionalDependencies 21 | - GADTs 22 | - GeneralizedNewtypeDeriving 23 | - InstanceSigs 24 | - LambdaCase 25 | - MultiParamTypeClasses 26 | - NamedFieldPuns 27 | - OverloadedStrings 28 | - RankNTypes 29 | - ScopedTypeVariables 30 | - TypeFamilies 31 | - TypeOperators 32 | 33 | ghc-options: -Wall 34 | dependencies: 35 | 36 | # Notable 37 | 38 | - network 39 | - streaming 40 | 41 | # Other 42 | 43 | - aeson 44 | - async 45 | - base 46 | - bytestring 47 | - containers 48 | - directory 49 | - filepath 50 | - hashable 51 | - lens 52 | - monad-loops 53 | - mtl 54 | - random 55 | - safe-exceptions 56 | - stm 57 | - text 58 | - time 59 | - transformers 60 | - unordered-containers 61 | 62 | library: 63 | source-dirs: src 64 | executables: 65 | json-relay: 66 | source-dirs: ./ 67 | main: Main.hs 68 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 69 | dependencies: 70 | - gitrev 71 | - json-relay 72 | - optparse-applicative 73 | tests: 74 | spec: 75 | source-dirs: test 76 | main: Spec.hs 77 | dependencies: 78 | - hspec 79 | - json-relay 80 | -------------------------------------------------------------------------------- /docs/install.md: -------------------------------------------------------------------------------- 1 | # Requirements 2 | 3 | Linux, unfortunately. 4 | 5 | The game worked on previous versions of macOS, but has stopped working on the latest versions. This may have to do with macOS deprecating OpenGL. 6 | 7 | # Setup 8 | 9 | 1. Install [Stack](https://haskellstack.org/). 10 | 11 | 2. Install the system dependencies (`libGL`, `libGLU`, `freeglut`, maybe others?). 12 | 13 | 3. `stack install` 14 | 15 | # Single player sandbox 16 | 17 | Play against a computer opponent that doesn't do anything besides end turn: 18 | 19 | `hermetic --sandbox` 20 | 21 | # Multiplayer (using the game server) 22 | 23 | If my server is up you can use it (replace `ROOM_NAME` with your own random string): 24 | ``` 25 | $ hermetic --room ROOM_NAME 26 | AddrInfo {addrFlags = [], addrFamily = AF_INET, addrSocketType = Stream, addrProtocol = 6, addrAddress = 178.128.66.50:3000, addrCanonName = Nothing} 27 | Sending message 28 | ``` 29 | 30 | (If the server is down you'll either get an error or `Sending message` won't show up) 31 | 32 | Then your opponent runs the same command and a game window will open on each computer. 33 | 34 | Make sure you settle on an unlikely `ROOM_NAME` with your opponent. If a third party tries to join the same room while the game is in progress it will crash. 35 | 36 | # Multiplayer (using your own server) 37 | 38 | ```sh 39 | cd json-relay 40 | stack install 41 | json-relay # Start the server 42 | ``` 43 | 44 | Then proceed as in the previous section, but adding `--host ADDRESS` and `--port PORT` to the `hermetic` commands. 45 | -------------------------------------------------------------------------------- /src/Scenario/Crisis.hs: -------------------------------------------------------------------------------- 1 | module Scenario.Crisis where 2 | 3 | import Control.Monad.Trans.State 4 | import qualified Data.Set as Set 5 | import Game 6 | import Game.Prelude 7 | import Scenario.Tannen (defPlace, defShip, newPlace) 8 | 9 | fillBoard :: State Model () 10 | fillBoard = do 11 | p1 <- newPlace $ def (-388,-388) "Ajos" & placeTypeL . _PBase . baseOwnerL .~ PlayerOwner Player1 12 | & placeTypeL . _PBase . baseInstallationsL %~ Set.insert Shield 13 | & placeTypeL . _PBase . baseShieldsL .~ startingShields 14 | 15 | _ <- newPlace $ def (-200,-200) "Nyby" 16 | _ <- newPlace $ def (0,0) "Tervola" & placeSizeL .~ Small 17 | & placeTypeL . _PBase . baseDiseaseL .~ Latent 18 | _ <- newPlace $ def (200,200) "Hosio" 19 | p2 <- newPlace $ def (388,388) "Sangis" & placeTypeL . _PBase . baseOwnerL .~ PlayerOwner Player2 20 | & placeTypeL . _PBase . baseInstallationsL %~ Set.insert Shield 21 | & placeTypeL . _PBase . baseShieldsL .~ startingShields 22 | 23 | _ <- newPlace $ def (0,-400) "Muurola" 24 | _ <- newPlace $ def (-400,0) "Pursu" 25 | _ <- newPlace $ def (400,0) "Ekfors" 26 | _ <- newPlace $ def (0,400) "Vaski" 27 | _ <- newPlace $ def (-282,282) "Greus" & placeSizeL .~ Large 28 | _ <- newPlace $ def (282,-282) "Narkaus" & placeSizeL .~ Large 29 | 30 | _ <- newShip $ defShip Player1 (AtPlace p1) 31 | _ <- newShip $ defShip Player1 (AtPlace p1) 32 | _ <- newShip $ defShip Player2 (AtPlace p2) 33 | _ <- newShip $ defShip Player2 (AtPlace p2) 34 | 35 | 36 | pure () 37 | where 38 | def = defPlace 39 | -------------------------------------------------------------------------------- /src/Lib/Gloss.hs: -------------------------------------------------------------------------------- 1 | module Lib.Gloss 2 | ( module Lib.Gloss 3 | , module Graphics.Gloss.Data.Color 4 | -- * Re-exports from "Graphics.Gloss.Data.Picture" 5 | -- 6 | -- | /(With redunant aliases for Picture constructors hidden)/ 7 | , module Graphics.Gloss.Data.Picture 8 | ) where 9 | 10 | import qualified Data.Text as T 11 | import Game.Prelude 12 | import Graphics.Gloss.Data.Color 13 | import Graphics.Gloss.Data.Picture hiding 14 | (arc, bitmap, bitmapSection, blank, circle, color, line, pictures, polygon, 15 | rotate, scale, text, thickArc, thickCircle, translate) 16 | 17 | whiteOnBlackBox :: Box -> Picture 18 | whiteOnBlackBox = 19 | coloredBox white 20 | 21 | coloredBox :: Color -> Box -> Picture 22 | coloredBox color (Box w h) = 23 | fold 24 | [ Color black $ rectangleSolid w h 25 | , Color color $ rectangleWire w h 26 | ] 27 | 28 | -- | Horizontal centering is just an approximation since the text isn't fixed width. 29 | centeredText :: Color -> Text -> Picture 30 | centeredText color t = 31 | Translate x 0 $ verticallyCenteredText color t 32 | where 33 | x :: Float 34 | x = 35 | (realToFrac (T.length t) / 2) * (-8) 36 | 37 | verticallyCenteredText :: Color -> Text -> Picture 38 | verticallyCenteredText color = 39 | Translate 0 y . viewText color 40 | where 41 | y :: Float 42 | y = 43 | -5 44 | 45 | viewText :: Color -> Text -> Picture 46 | viewText color = 47 | Scale (1/8) (1/8) . Color color . Text . T.unpack 48 | 49 | verticalConcatText :: [Picture] -> Picture 50 | verticalConcatText = 51 | snd . foldl' f (0,mempty) 52 | where 53 | f :: (Float, Picture) -> Picture -> (Float, Picture) 54 | f (translateBy, currentPicture) textToAdd = 55 | case textToAdd of 56 | Blank -> 57 | (translateBy, currentPicture) 58 | 59 | _ -> 60 | ( translateBy - 20 61 | , currentPicture <> Translate 0 translateBy textToAdd 62 | ) 63 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: hermetic 2 | license: BSD3 3 | version: 0.0 4 | description: 5 | A two player, simultaneous turn desktop strategy game. 6 | Homepage [on GitHub](https://github.com/seagreen/hermetic). 7 | 8 | 9 | If you're looking for a place to start reading I recommend "Game.Model". 10 | Data > code. 11 | 12 | default-extensions: 13 | 14 | # Notable 15 | 16 | - NoImplicitPrelude # Using our own Game.Prelude module instead 17 | # (which is based on Prelude). 18 | - RecordWildCards # Despite my dislike of this extension, using it to reduce 19 | # the noise of picking out Model and Base fields. 20 | - StrictData 21 | 22 | # Other 23 | 24 | - DataKinds 25 | - DeriveAnyClass 26 | - DeriveFunctor 27 | - DeriveGeneric 28 | - DerivingStrategies 29 | - ExistentialQuantification 30 | - FlexibleContexts 31 | - FlexibleInstances 32 | - FunctionalDependencies 33 | - GADTs 34 | - GeneralizedNewtypeDeriving 35 | - InstanceSigs 36 | - LambdaCase 37 | - MultiParamTypeClasses 38 | - NamedFieldPuns 39 | - OverloadedStrings 40 | - PackageImports 41 | - RankNTypes 42 | - ScopedTypeVariables 43 | - TypeFamilies 44 | - TypeOperators 45 | 46 | ghc-options: -Wall 47 | dependencies: 48 | 49 | # Notable 50 | 51 | - gloss 52 | - json-relay # Located at ./json-relay 53 | 54 | # Other 55 | 56 | - aeson 57 | - aeson-pretty 58 | - base 59 | - bytestring 60 | - containers 61 | - directory 62 | - filepath 63 | - gitrev 64 | - hashable 65 | - lens 66 | - MonadRandom 67 | - mtl 68 | - optparse-applicative 69 | - safe 70 | - safe-exceptions 71 | - split 72 | - stm 73 | - template-haskell 74 | - text 75 | - time 76 | - transformers 77 | - unordered-containers 78 | 79 | library: 80 | source-dirs: src 81 | executables: 82 | hermetic: 83 | source-dirs: ./misc 84 | main: Main.hs 85 | ghc-options: -threaded -rtsopts 86 | dependencies: 87 | - hermetic 88 | tests: 89 | spec: 90 | source-dirs: test 91 | main: Spec.hs 92 | dependencies: 93 | - hermetic 94 | - hspec 95 | - QuickCheck 96 | -------------------------------------------------------------------------------- /src/Game/Update/Bombard.hs: -------------------------------------------------------------------------------- 1 | module Game.Update.Bombard 2 | ( bombard 3 | , regenerateBaseShields 4 | ) where 5 | 6 | import Control.Monad.Trans.State 7 | import qualified Data.HashMap.Strict as HM 8 | import qualified Data.Set as Set 9 | import Game.Model 10 | import Game.Prelude 11 | import Game.Update.Shared 12 | 13 | -- | __Player guide previous__: 'Game.Update.Combat.combat' 14 | -- 15 | -- When ships are present unopposed at an opponent's base, they reduce 16 | -- its 'basePopulation' by one. If it can't go any lower (it's already 17 | -- an 'Outpost') the base is destroyed. 18 | -- 19 | -- __Next__: 'Game.Update.Travel.shipsEmbark' 20 | bombard :: State Model () 21 | bombard = 22 | forOccupiedBases bombardPlace 23 | 24 | bombardPlace :: PlaceId -> Base -> Player -> HashMap ShipId Ship -> State Model () 25 | bombardPlace placeId base _ ships = 26 | case baseOwner base of 27 | Neutral _ -> 28 | pure () 29 | 30 | PlayerOwner _ -> 31 | if baseShields base > 0 32 | then damageShields 33 | else damageBase 34 | where 35 | damageShields :: State Model () 36 | damageShields = 37 | if monitorIsPresent 38 | then do 39 | adjustBase placeId (baseInstallationsL %~ Set.delete Shield) 40 | adjustBase placeId (baseShieldsL .~ 0) 41 | 42 | else 43 | adjustBase placeId (baseShieldsL -~ 1) 44 | 45 | damageBase :: State Model () 46 | damageBase = 47 | if monitorIsPresent || basePopulation base == minPop 48 | then 49 | modelPlacesL %= HM.adjust (placeTypeL .~ Ruin) placeId 50 | 51 | else 52 | adjustBase placeId (basePopulationL %~ prevPop) 53 | 54 | monitorIsPresent :: Bool 55 | monitorIsPresent = 56 | any (\ship -> shipType ship == Monitor) (HM.elems ships) 57 | 58 | -- | Bases with a 'Shield' that aren't controlled by the opponent's 59 | -- ships regenerate shields. 60 | regenerateBaseShields :: State Model () 61 | regenerateBaseShields = 62 | forUnoccupiedBases regenerateShields 63 | 64 | regenerateShields :: PlaceId -> Base -> State Model () 65 | regenerateShields placeId Base{..} = 66 | if Set.member Shield baseInstallations && baseShields < startingShields 67 | then adjustBase placeId (baseShieldsL +~ 1) 68 | else pure () 69 | -------------------------------------------------------------------------------- /json-relay/test/JsonRelay/ServerSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | module JsonRelay.ServerSpec where 4 | 5 | import Control.Concurrent 6 | import Control.Concurrent.Async 7 | import Data.Aeson 8 | import Data.Foldable 9 | import Data.Text (Text) 10 | import qualified Data.Text.IO as T 11 | import JsonRelay.Client (Client(..)) 12 | import qualified JsonRelay.Client as Client 13 | import qualified JsonRelay.Server as Server 14 | import qualified JsonRelay.Shared as Shared 15 | import Numeric.Natural 16 | import Prelude hiding (log) 17 | import qualified System.IO 18 | import Test.Hspec 19 | 20 | testPort :: Natural 21 | testPort = 22 | 41979 -- arbitrary 23 | 24 | spec :: Spec 25 | spec = do 26 | describe "The client and server" $ do 27 | it "perform basic tasks correctly" $ do 28 | race_ 29 | (Server.run (Server.Config testPort)) 30 | (threadDelay 500_000 *> runClients) 31 | where 32 | runClients :: IO () 33 | runClients = 34 | concurrently_ 35 | (testClient f) 36 | (threadDelay 500_000 *> testClient g) 37 | 38 | testClient :: (Client -> IO ()) -> IO () 39 | testClient = 40 | Client.run log "localhost" testPort (Shared.RoomName "test") 41 | 42 | f :: Client -> IO () 43 | f Client{clientSend, clientReceive} = do 44 | clientSend (String "hello") 45 | 46 | -- Test small messages. recvFrom can return multiple of these 47 | -- in one call. 48 | 49 | receive "foo" 50 | receive "bar" 51 | receive "baz" 52 | 53 | -- Test large messages, which are split up over multiple 54 | -- recvFrom calls. 55 | 56 | receive largeStr1 57 | receive largeStr2 58 | receive largeStr3 59 | 60 | receive "quux" 61 | where 62 | receive :: Text -> IO () 63 | receive expected = do 64 | res <- clientReceive 65 | case eitherDecodeStrict res of 66 | Left e -> 67 | error ("Couldn't decode payload: " <> e) 68 | 69 | Right t -> 70 | t `shouldBe` expected 71 | 72 | g :: Client -> IO () 73 | g Client{clientSend} = do 74 | clientSend (String "foo") 75 | clientSend (String "bar") 76 | clientSend (String "baz") 77 | 78 | clientSend (String largeStr1) 79 | clientSend (String largeStr2) 80 | clientSend (String largeStr3) 81 | 82 | clientSend (String "quux") 83 | 84 | -- An unexpected extra message that should be ignored. 85 | clientSend (String largeStr1) 86 | 87 | largeStr1 :: Text 88 | largeStr1 = 89 | fold ("a" : "b" : replicate 20_000 "c") 90 | 91 | largeStr2 :: Text 92 | largeStr2 = 93 | largeStr1 <> "d" 94 | 95 | largeStr3 :: Text 96 | largeStr3 = 97 | largeStr2 <> "e" 98 | 99 | log :: Text -> IO () 100 | log = 101 | T.hPutStrLn System.IO.stderr 102 | -------------------------------------------------------------------------------- /json-relay/src/JsonRelay/Shared.hs: -------------------------------------------------------------------------------- 1 | -- | Internal. 2 | module JsonRelay.Shared where 3 | 4 | import Data.Aeson 5 | import Data.ByteString (ByteString) 6 | import Data.Text (Text) 7 | import Data.Word 8 | import Network.Socket (AddrInfo(..), SockAddr(..), getAddrInfo) 9 | import Prelude 10 | import Streaming 11 | 12 | import qualified Data.ByteString as BS 13 | import qualified Streaming.Prelude as S 14 | 15 | -- | An invalid UTF-8 byte, used to signal the end of a 'Message'. 16 | -- 17 | -- Since multiple 'Message's can be read on each call to 'NetworkBts.recvFrom', 18 | -- each 'Message' must be followed by an @endOfMessage@ to distinguish them. 19 | endOfMessage :: Word8 20 | endOfMessage = 21 | 0xFF 22 | 23 | -- | Comment from @Network.Socket.ByteString@: 24 | -- 25 | -- @ 26 | -- Considering hardware and network realities, the maximum number of bytes to receive should be a small power of 2, e.g., 4096. 27 | -- 28 | -- For TCP sockets, a zero length return value means the peer has closed its half side of the connection. 29 | -- @ 30 | maxBytes :: Int 31 | maxBytes = 32 | 4096 33 | 34 | data Message = Message 35 | { messageRoom :: RoomName 36 | , messageBody :: Value 37 | } deriving (Eq, Show) 38 | 39 | newtype RoomName 40 | = RoomName { unRoomName :: Text } 41 | deriving stock (Eq, Ord, Show) 42 | deriving newtype (ToJSON, FromJSON) 43 | 44 | instance ToJSON Message where 45 | toJSON m = 46 | object 47 | [ "room" .= messageRoom m 48 | , "body" .= messageBody m 49 | ] 50 | 51 | instance FromJSON Message where 52 | parseJSON = 53 | withObject "Message" $ \o -> 54 | Message <$> o .: "room" <*> o .: "body" 55 | 56 | data MessagePart 57 | = Complete ByteString SockAddr 58 | | Partial ByteString SockAddr 59 | 60 | splitMessages :: (ByteString, SockAddr) -> Stream (Of MessagePart) IO () 61 | splitMessages (bts, addr) = do 62 | case reverse (BS.split endOfMessage bts) of 63 | [] -> pure () 64 | x:xs -> S.each (reverse (Partial x addr : fmap (\y -> Complete y addr) xs)) 65 | 66 | getOneAddrInfo :: Maybe AddrInfo -> Maybe String -> Maybe String -> IO AddrInfo 67 | getOneAddrInfo hints hostName serviceName = do 68 | addrs <- getAddrInfo hints hostName serviceName 69 | case addrs of 70 | [] -> 71 | error "getAddrInfo didn't throw an exception on empty list" 72 | 73 | addr:_ -> do 74 | pure addr 75 | 76 | -- | Copied from `network` because it wasn't exported. 77 | -- 78 | -- Shows the fields of 'defaultHints', without inspecting the by-default undefined fields 'addrAddress' and 'addrCanonName'. 79 | showDefaultHints :: AddrInfo -> String 80 | showDefaultHints a = 81 | concat 82 | [ "AddrInfo {" 83 | , "addrFlags = " 84 | , show (addrFlags a) 85 | , ", addrFamily = " 86 | , show (addrFamily a) 87 | , ", addrSocketType = " 88 | , show (addrSocketType a) 89 | , ", addrProtocol = " 90 | , show (addrProtocol a) 91 | , ", addrAddress = " 92 | , "" 93 | , ", addrCanonName = " 94 | , "" 95 | , "}" 96 | ] 97 | -------------------------------------------------------------------------------- /src/View/Ship.hs: -------------------------------------------------------------------------------- 1 | module View.Ship 2 | ( playerColor 3 | , shieldColor 4 | , viewShip 5 | , viewShipWithShieldIndicator 6 | , viewThrust 7 | ) where 8 | 9 | import Game hiding (Model) 10 | import Game.Prelude 11 | import Lib.Gloss 12 | 13 | playerColor :: Player -> Color 14 | playerColor = \case 15 | Player1 -> aquamarine 16 | Player2 -> rose 17 | 18 | shieldColor :: Color 19 | shieldColor = 20 | azure 21 | 22 | viewShip :: Ship -> Picture 23 | viewShip ship = 24 | case shipType ship of 25 | Corvette -> 26 | fold 27 | [ Color black $ Polygon corvetteOutline 28 | , Color (playerColor (shipPlayer ship)) $ lineLoop corvetteOutline 29 | ] 30 | 31 | Station -> 32 | fold 33 | [ Color black $ ThickCircle stationRadius stationRadius 34 | , Color (playerColor (shipPlayer ship)) $ Circle stationRadius 35 | ] 36 | 37 | Monitor -> 38 | fold 39 | [ Color black $ Polygon monitorOutline 40 | , Color (playerColor (shipPlayer ship)) $ lineLoop monitorOutline 41 | ] 42 | 43 | stationRadius :: Float 44 | stationRadius = 45 | 8 46 | 47 | -- | Ship pointed to the right. 48 | corvetteOutline :: [Point] 49 | corvetteOutline = 50 | [ (- halfLength, halfWidth) -- Port back 51 | , ( halfLength, 0 ) -- Point 52 | , (- halfLength, - halfWidth) -- Starboard back 53 | ] 54 | where 55 | halfLength :: Float 56 | halfLength = 57 | 15 58 | 59 | halfWidth :: Float 60 | halfWidth = 61 | 5 62 | 63 | -- | Ship pointed to the right. 64 | monitorOutline :: [Point] 65 | monitorOutline = 66 | [ (- halfLength, width / 2) -- Port back 67 | , ( halfLength, width * 1.5/5) -- Port front 68 | , ( halfLength, - width * 1.5/5) -- Starboard back 69 | , (- halfLength, - width / 2) -- Starboard front 70 | ] 71 | where 72 | halfLength :: Float 73 | halfLength = 74 | 15 75 | 76 | width :: Float 77 | width = 78 | 15 79 | 80 | viewShipWithShieldIndicator :: Ship -> Picture 81 | viewShipWithShieldIndicator ship = 82 | fold 83 | [ viewShip ship 84 | , if shipShields ship 85 | then 86 | Color shieldColor $ 87 | case shipType ship of 88 | Corvette -> 89 | Scale 1.5 1.5 $ adjustForward $ lineLoop corvetteOutline 90 | 91 | Station -> 92 | Scale 1.5 1.5 $ Circle stationRadius 93 | 94 | Monitor -> 95 | Scale 1.5 1.5 $ lineLoop monitorOutline 96 | else 97 | mempty 98 | ] 99 | where 100 | -- Looks awkward otherwise 101 | adjustForward :: Picture -> Picture 102 | adjustForward = 103 | Translate 4 0 104 | 105 | -- | A diamond. Long end pointed to the left. 106 | viewThrust :: Player -> Picture 107 | viewThrust player = 108 | Color (playerColor player) $ Polygon 109 | [ (-15, 0 ) -- Starting at the left 110 | , ( 10, halfWidth) -- moving up and right 111 | , ( 15, 0 ) -- Far right, the point of the blunt end 112 | , ( 10, - halfWidth) -- moving down and left 113 | ] 114 | where 115 | halfWidth :: Float 116 | halfWidth = 117 | 5 118 | -------------------------------------------------------------------------------- /json-relay/json-relay.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: ae7012740dd6468cab5a67a9e034b2ede8217cd5b91c0ab05685c147dae13442 8 | 9 | name: json-relay 10 | version: 0.0 11 | license: BSD3 12 | build-type: Simple 13 | 14 | library 15 | exposed-modules: 16 | JsonRelay.Client 17 | JsonRelay.Server 18 | JsonRelay.Shared 19 | other-modules: 20 | Paths_json_relay 21 | hs-source-dirs: 22 | src 23 | default-extensions: NoImplicitPrelude DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 24 | ghc-options: -Wall 25 | build-depends: 26 | aeson 27 | , async 28 | , base 29 | , bytestring 30 | , containers 31 | , directory 32 | , filepath 33 | , hashable 34 | , lens 35 | , monad-loops 36 | , mtl 37 | , network 38 | , random 39 | , safe-exceptions 40 | , stm 41 | , streaming 42 | , text 43 | , time 44 | , transformers 45 | , unordered-containers 46 | default-language: Haskell2010 47 | 48 | executable json-relay 49 | main-is: Main.hs 50 | other-modules: 51 | Paths_json_relay 52 | hs-source-dirs: 53 | ./ 54 | default-extensions: NoImplicitPrelude DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 55 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 56 | build-depends: 57 | aeson 58 | , async 59 | , base 60 | , bytestring 61 | , containers 62 | , directory 63 | , filepath 64 | , gitrev 65 | , hashable 66 | , json-relay 67 | , lens 68 | , monad-loops 69 | , mtl 70 | , network 71 | , optparse-applicative 72 | , random 73 | , safe-exceptions 74 | , stm 75 | , streaming 76 | , text 77 | , time 78 | , transformers 79 | , unordered-containers 80 | default-language: Haskell2010 81 | 82 | test-suite spec 83 | type: exitcode-stdio-1.0 84 | main-is: Spec.hs 85 | other-modules: 86 | JsonRelay.ServerSpec 87 | Paths_json_relay 88 | hs-source-dirs: 89 | test 90 | default-extensions: NoImplicitPrelude DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 91 | ghc-options: -Wall 92 | build-depends: 93 | aeson 94 | , async 95 | , base 96 | , bytestring 97 | , containers 98 | , directory 99 | , filepath 100 | , hashable 101 | , hspec 102 | , json-relay 103 | , lens 104 | , monad-loops 105 | , mtl 106 | , network 107 | , random 108 | , safe-exceptions 109 | , stm 110 | , streaming 111 | , text 112 | , time 113 | , transformers 114 | , unordered-containers 115 | default-language: Haskell2010 116 | -------------------------------------------------------------------------------- /src/Cli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Parse command line options into a runnable program. 4 | -- 5 | -- We do this in the @library@ part of the package so readers of the 6 | -- Haddocks can see the whole program with nothing hidden. 7 | -- 8 | -- == Why this module isn't named Main 9 | -- 10 | -- We can't build executables from library functions, so we need an executable 11 | -- stanza with its own @Main@ module. This is @.\/misc\/Main.hs@. 12 | -- 13 | -- The @main-is@ entry in the cabal file is only for picking main's filename, 14 | -- [not its module name](https://github.com/haskell/cabal/pull/5122/files#diff-1470073e9713a98f17cf8ba16ccb6798R1302). 15 | -- 16 | -- If we name both modules @Main@ and run @stack ghci@, we get this error: 17 | -- 18 | -- > : error: 19 | -- > module ‘main:Main’ is defined in multiple files 20 | -- 21 | -- Thus we call this module @Cli@ instead of @Main@. 22 | module Cli 23 | ( main 24 | , configParser 25 | ) where 26 | 27 | import App (Config(..), app) 28 | import qualified Data.Map.Strict as Map 29 | import qualified Data.Text as T 30 | import Data.Version (showVersion) 31 | import Development.GitRev (gitHash) 32 | import Game.Prelude 33 | import JsonRelay.Client (RoomName(..)) 34 | import Model (Scenario(..)) 35 | import Options.Applicative 36 | import Paths_hermetic (version) 37 | 38 | main :: IO () 39 | main = 40 | app =<< args 41 | 42 | args :: IO Config 43 | args = 44 | customExecParser (prefs showHelpOnError) configParser 45 | 46 | configParser :: ParserInfo Config 47 | configParser = 48 | info 49 | (helper <*> versionOption <*> parser) 50 | fullDesc 51 | where 52 | versionOption :: Parser (a -> a) 53 | versionOption = 54 | infoOption 55 | (showVersion version <> " " <> $(gitHash)) 56 | ( long "version" 57 | <> help "Show version" 58 | ) 59 | 60 | parser :: Parser Config 61 | parser = 62 | Config 63 | <$> option str 64 | ( long "host" 65 | <> metavar "HOST" 66 | <> help "Server address to connect to" 67 | <> value "relay.ianjeffries.net" 68 | -- showDefaultWith instead of showDefault so we don't get quotes 69 | -- around the value: 70 | <> showDefaultWith T.unpack 71 | ) 72 | <*> option auto 73 | ( long "port" 74 | <> metavar "PORT" 75 | <> help "Server port to connect to" 76 | <> value 3000 77 | <> showDefault 78 | ) 79 | <*> option (maybeReader (Just . RoomName . T.pack)) 80 | ( long "room" 81 | <> metavar "ROOM" 82 | <> help "Room name to join" 83 | <> value (RoomName "room1") 84 | -- showDefaultWith instead of showDefault so we don't get: 85 | -- 86 | -- default: RoomName {unRoomName = "room1"} 87 | -- 88 | <> showDefaultWith (T.unpack . unRoomName) 89 | ) 90 | <*> option (maybeReader scenarioParser) 91 | ( long "map" 92 | <> metavar "MAP" 93 | <> help "Scenario to play" 94 | <> value Tannen 95 | <> showDefaultWith scenarioSerializer 96 | ) 97 | <*> switch 98 | ( long "sandbox" 99 | <> help "Play locally against a computer that doesn't move" 100 | ) 101 | 102 | scenarioSerializer :: Scenario -> [Char] 103 | scenarioSerializer = \case 104 | Tannen -> "tannen" 105 | Crisis -> "crisis" 106 | 107 | scenarioParser :: [Char] -> Maybe Scenario 108 | scenarioParser t = 109 | Map.lookup t stringToScenario 110 | where 111 | stringToScenario :: Map [Char] Scenario 112 | stringToScenario = 113 | let f scenario = (scenarioSerializer scenario, scenario) 114 | in Map.fromList (f <$> [minBound .. maxBound]) 115 | -------------------------------------------------------------------------------- /src/Game/Update/Combat.hs: -------------------------------------------------------------------------------- 1 | module Game.Update.Combat 2 | ( combat 3 | ) where 4 | 5 | import Control.Monad.Trans.State 6 | import qualified Data.HashMap.Strict as HM 7 | import qualified Data.Set as Set 8 | import Game.Model 9 | import Game.Prelude 10 | import Game.Update.Shared 11 | 12 | -- | __Player guide previous__: 'Game.Update.Diplomacy.diplomacy' 13 | -- 14 | -- When both players have ships at the same base they fight. 15 | -- 16 | -- First the number of hits landed this turn is calculated for both sides. 17 | -- Then they're distributed over the opponent's ships. 18 | -- 19 | -- The first hit on a ship destroys its shields, the second destroys 20 | -- the ship itself. 21 | -- 22 | -- __Next__: 'Game.Update.Bombard.bombard' 23 | combat :: State Model () 24 | combat = do 25 | bases <- use modelPlacesL 26 | ships <- use modelShipsL 27 | traverse_ (checkForCombat ships) (HM.keys bases) 28 | where 29 | checkForCombat :: HashMap ShipId Ship -> PlaceId -> State Model () 30 | checkForCombat allShips placeId = do 31 | let ships :: HashMap ShipId Ship 32 | ships = 33 | shipsAtPlace placeId allShips 34 | let players = Set.map shipPlayer (Set.fromList (HM.elems ships)) 35 | case Set.toList players of 36 | [] -> 37 | pure () 38 | 39 | [_] -> 40 | pure () 41 | 42 | _ -> 43 | baseCombat placeId ships 44 | 45 | baseCombat 46 | :: PlaceId 47 | -> HashMap ShipId Ship 48 | -- ^ Ships at this base 49 | -> State Model () 50 | baseCombat placeId ships = do 51 | modelLogL . logCombatL %= HM.insert placeId mempty 52 | let (p1, p2) = playerShips ships 53 | 54 | p1Hits <- numberOfHits p1 55 | p2Hits <- numberOfHits p2 56 | 57 | (p1Destroyed, p1Remaining) <- runRandom $ distributeHits resultOfHit p1 p2Hits 58 | (p2Destroyed, p2Remaining) <- runRandom $ distributeHits resultOfHit p2 p1Hits 59 | 60 | updateDamaged (p1Remaining <> p2Remaining) 61 | 62 | removeDestroyed (p1Destroyed <> p2Destroyed) 63 | where 64 | resultOfHit :: Ship -> Maybe Ship 65 | resultOfHit ship = 66 | if shipShields ship 67 | then Just (ship { shipShields = False }) 68 | else Nothing 69 | 70 | updateDamaged :: HashMap ShipId Ship -> State Model () 71 | updateDamaged damaged = 72 | modelShipsL %= HM.union damaged 73 | 74 | removeDestroyed :: HashMap ShipId Ship -> State Model () 75 | removeDestroyed xs = 76 | for_ (HM.keys xs) $ \id -> do 77 | modelShipsL %= HM.adjust (shipLocationL .~ Destroyed) id 78 | modelLogL . logCombatL %= HM.adjust (Set.insert id) placeId 79 | 80 | playerShips :: HashMap ShipId Ship -> (HashMap ShipId Ship, HashMap ShipId Ship) 81 | playerShips ships = 82 | let p1 = filter (\(_,s) -> shipPlayer s == Player1) $ HM.toList ships 83 | p2 = filter (\(_,s) -> shipPlayer s == Player2) $ HM.toList ships 84 | in (HM.fromList p1, HM.fromList p2) 85 | 86 | numberOfHits :: forall id. HashMap id Ship -> State Model Natural 87 | numberOfHits firingShips = 88 | sum <$> traverse f (stationBonus <> HM.elems firingShips) 89 | where 90 | f :: Ship -> State Model Natural 91 | f ship = do 92 | case shipType ship of 93 | Corvette -> fire 94 | Station -> fire 95 | Monitor -> do 96 | a <- fire 97 | b <- fire 98 | c <- fire 99 | pure (a + b + c) 100 | 101 | fire :: State Model Natural 102 | fire = do 103 | isHit <- runRandom (probability 0.5) 104 | pure $ if isHit 105 | then 1 106 | else 0 107 | 108 | -- A player's first station in a battle fires two extra times, 109 | -- their second one extra time. 110 | stationBonus :: [Ship] 111 | stationBonus = 112 | let stations = HM.filter (\ship -> shipType ship == Station) firingShips 113 | in case HM.elems stations of 114 | station1:station2:_ -> [station1, station1, station2] 115 | station:[] -> [station, station] 116 | [] -> [] 117 | -------------------------------------------------------------------------------- /src/Scenario/Tannen.hs: -------------------------------------------------------------------------------- 1 | module Scenario.Tannen where 2 | 3 | import Control.Monad.Trans.State 4 | import qualified Data.HashMap.Strict as HM 5 | import qualified Data.Set as Set 6 | import Game 7 | import Game.Prelude 8 | 9 | fillBoard :: State Model () 10 | fillBoard = do 11 | tannen <- newPlace $ def (0,300) "Tannen" & placeSizeL .~ Large 12 | & placeTypeL . _PBase . baseOwnerL .~ PlayerOwner Player1 13 | & placeTypeL . _PBase . baseInstallationsL %~ Set.insert Shield 14 | & placeTypeL . _PBase . baseShieldsL .~ startingShields 15 | _ <- newPlace $ def (-300,400) "Varad" 16 | _ <- newPlace $ def (300,400) "Cartago" 17 | 18 | renga <- newPlace $ def (0,-300) "Renga" & placeSizeL .~ Large 19 | & placeTypeL . _PBase . baseOwnerL .~ PlayerOwner Player2 20 | & placeTypeL . _PBase . baseInstallationsL %~ Set.insert Shield 21 | & placeTypeL . _PBase . baseShieldsL .~ startingShields 22 | _ <- newPlace $ def (-300,-400) "Mugat" 23 | _ <- newPlace $ def (300,-400) "Nakana" 24 | 25 | _ <- newPlace $ def (500,0) "K Station" & placeSizeL .~ Small 26 | _ <- newPlace $ def (800,0) "Atalanta" & placeSizeL .~ Large 27 | & placeTypeL . _PBase . basePopulationL .~ Settlement 28 | _ <- newPlace $ def (1000,300) "Firbeck" 29 | _ <- newPlace $ def (1000,-300) "Banting" 30 | 31 | _ <- newPlace $ def (-1500,0) "Terminal" & placeSizeL .~ Small 32 | 33 | -- Each player gets a ship at their base: 34 | 35 | _ <- newShip $ defShip Player1 (AtPlace tannen) 36 | _ <- newShip $ defShip Player2 (AtPlace renga) 37 | 38 | -- And one in flight towards their base: 39 | 40 | _ <- newShip $ defShip Player1 (InFlight (0,0) tannen NotBoosted) 41 | _ <- newShip $ defShip Player2 (InFlight (0,0) renga NotBoosted) 42 | 43 | -- For testing ship types: 44 | 45 | -- _ <- newShip $ defShip Player1 (InFlight (0,0) tannen NotBoosted) & shipTypeL .~ Station 46 | -- _ <- newShip $ defShip Player1 (InFlight (0,0) t NotBoosted) & shipTypeL .~ Monitor 47 | 48 | -- For testing pagination: 49 | 50 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 51 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 52 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 53 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) & shipShieldsL .~ False 54 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 55 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 56 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) & shipTypeL .~ Monitor 57 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) & shipTypeL .~ Station 58 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 59 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 60 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) & shipShieldsL .~ False 61 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 62 | -- _ <- newShip $ defShip Player1 (AtPlace tannen) 63 | -- _ <- newShip $ defShip Player2 (AtPlace tannen) & shipTypeL .~ Monitor 64 | -- _ <- newShip $ defShip Player2 (AtPlace tannen) & shipTypeL .~ Station 65 | -- _ <- newShip $ defShip Player2 (AtPlace tannen) 66 | 67 | pure () 68 | where 69 | def = defPlace 70 | 71 | defPlace :: Point -> Text -> Place 72 | defPlace point name = 73 | Place 74 | { placeName = name 75 | , placePoint = point 76 | , placeSize = Medium 77 | , placeType = 78 | PBase Base 79 | { baseOwner = Neutral mempty 80 | , basePopulation = Outpost 81 | , baseDisease = Healthy 82 | , baseInstallations = mempty 83 | , baseShields = 0 84 | , baseBuilding = BuildPopulation 85 | , baseInProgress = mempty 86 | } 87 | } 88 | 89 | defShip :: Player -> ShipLocation -> Ship 90 | defShip p l = 91 | Ship p l Corvette True 92 | 93 | newPlace :: Place -> State Model PlaceId 94 | newPlace place = do 95 | id <- PlaceId <$> newId 96 | modelPlacesL %= HM.insert id place 97 | pure id 98 | -------------------------------------------------------------------------------- /json-relay/src/JsonRelay/Client.hs: -------------------------------------------------------------------------------- 1 | -- | A library for connecting to the server. 2 | -- 3 | -- Used by @hermetic@ but not the @json-relay@ executable. 4 | module JsonRelay.Client 5 | ( RoomName(..) 6 | , Client(..) 7 | , run 8 | ) where 9 | 10 | import Control.Concurrent 11 | import Control.Concurrent.STM 12 | import Control.Exception.Safe (bracket) 13 | import Data.Aeson 14 | import Data.ByteString (ByteString) 15 | import Data.Text (Text) 16 | import JsonRelay.Shared 17 | (Message(..), MessagePart(..), RoomName(..), endOfMessage, getOneAddrInfo, 18 | maxBytes, splitMessages) 19 | import Network.Socket (AddrInfo(..), SockAddr(..), Socket(..), SocketType(..)) 20 | import Numeric.Natural 21 | import Prelude hiding (log) 22 | 23 | import qualified Data.ByteString as BS 24 | import qualified Data.ByteString.Lazy as LBS 25 | import qualified Data.Text as T 26 | import qualified Network.Socket as Socket 27 | import qualified Network.Socket.ByteString as NetworkBts 28 | import qualified Streaming.Prelude as S 29 | 30 | data Client = Client 31 | { clientSend :: Value -> IO () 32 | , clientReceive :: IO ByteString 33 | -- ^ The @ByteString@ will always be JSON. 34 | } 35 | 36 | run 37 | :: (Text -> IO ()) 38 | -- ^ Logger. 39 | -- 40 | -- Present since module is meant to be used as a library 41 | -- (unlike "JsonRelay.Server"). 42 | -> Text 43 | -- ^ Host. 44 | -> Natural 45 | -- ^ Port. 46 | -> RoomName 47 | -> (Client -> IO ()) 48 | -> IO () 49 | run log host port room client = do 50 | addr <- resolve host (show port) 51 | log (T.pack (show addr)) 52 | bracket (open addr) Socket.close (withSocket log room client) 53 | 54 | resolve :: Text -> String -> IO AddrInfo 55 | resolve hostName serviceName = do 56 | getOneAddrInfo (Just hints) (Just (T.unpack hostName)) (Just serviceName) 57 | where 58 | -- @showDefaultHints@ on this gives: 59 | -- 60 | -- @ 61 | -- AddrInfo {addrFlags = [], addrFamily = AF_UNSPEC, addrSocketType = Stream, addrProtocol = 0, 62 | -- addrAddress = , addrCanonName = } 63 | -- @ 64 | hints :: AddrInfo 65 | hints = 66 | Socket.defaultHints { addrSocketType = Stream } 67 | 68 | -- Internal. 69 | -- 70 | -- @socket@ and @connect@. 71 | open :: AddrInfo -> IO Socket 72 | open addr = do 73 | sock <- Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 74 | Socket.connect sock (addrAddress addr) 75 | pure sock 76 | 77 | -- Internal. 78 | -- 79 | -- @recvFrom@ and @sendAll@. 80 | withSocket :: (Text -> IO ()) -> RoomName -> (Client -> IO ()) -> Socket -> IO () 81 | withSocket log room withClient sock = do 82 | chan <- newTChanIO 83 | _ <- forkIO (fill chan) 84 | withClient (Client clientSend (clientReceive chan)) 85 | where 86 | clientSend :: Value -> IO () 87 | clientSend v = do 88 | log "Sending message" 89 | NetworkBts.sendAll 90 | sock 91 | ( LBS.toStrict (encode (Message room v)) 92 | <> BS.singleton endOfMessage 93 | ) 94 | 95 | clientReceive :: TChan ByteString -> IO ByteString 96 | clientReceive = 97 | atomically . readTChan 98 | 99 | fill :: TChan ByteString -> IO () 100 | fill chan = 101 | S.foldM_ (next chan) (pure []) (\_ -> pure ()) $ 102 | S.for (S.untilRight receive) splitMessages 103 | 104 | next :: TChan ByteString -> [ByteString] -> MessagePart -> IO [ByteString] 105 | next chan remainder part = 106 | case part of 107 | Complete bts _ -> do 108 | atomically $ writeTChan chan (BS.concat (reverse (bts : remainder))) 109 | pure [] 110 | 111 | Partial bts _ -> do 112 | pure (bts : remainder) 113 | 114 | receive :: IO (Either (ByteString, SockAddr) ()) 115 | receive = do 116 | (bts, addr :: SockAddr) <- NetworkBts.recvFrom sock maxBytes 117 | if BS.null bts 118 | then do 119 | log $ "Empty message from " <> T.pack (show addr) 120 | pure $ Right () 121 | 122 | else do 123 | log $ "Message from " <> T.pack (show addr) 124 | pure $ Left (bts, addr) 125 | -------------------------------------------------------------------------------- /src/Game/Update/Travel.hs: -------------------------------------------------------------------------------- 1 | module Game.Update.Travel 2 | ( shipSpeed 3 | , shipsEmbark 4 | , shipsTravel 5 | ) where 6 | 7 | import Control.Monad.Trans.State 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.Set as Set 10 | import Game.Model 11 | import Game.Prelude 12 | import Game.Update.Shared 13 | 14 | -- | Determined by ship type and whether the base it last 15 | -- left had a 'Booster' (if friendly). 16 | shipSpeed :: Ship -> IsBoosted -> Float 17 | shipSpeed ship isBoosted = 18 | case isBoosted of 19 | NotBoosted -> baseSpeed 20 | Boosted -> baseSpeed * 2 21 | where 22 | baseSpeed :: Float 23 | baseSpeed = 24 | case shipType ship of 25 | Corvette -> 26 | 100 27 | 28 | Station -> 29 | 100 / 3 30 | 31 | Monitor -> 32 | 100 33 | 34 | -- | __Player guide previous__: 'Game.Update.Bombard.bombard' 35 | -- 36 | -- You can only move ships that are at a base. Once a ship has started moving 37 | -- it can't change course, instead it proceeds to its destination. 38 | -- 39 | -- You can't see enemy ships in flight (or at bases that aren't either 40 | -- friendly or have a friendly ship present). 41 | -- 42 | -- __Next__: 'Game.Update.Disease.diseaseSpread' 43 | shipsEmbark :: HashMap Player (HashMap ShipId PlaceId) -> State Model () 44 | shipsEmbark = 45 | hmTraverseWithKey_ playerShipsEmbark 46 | 47 | -- | Ships that have been given travel orders switch 'shipLocation' 48 | -- from 'AtPlace' to 'InFlight'. 49 | -- 50 | -- We avoid the word \"move\" because it can mean different things. 51 | -- Instead, ships \"embark\" and \"travel\" and players give \"orders\". 52 | playerShipsEmbark :: Player -> HashMap ShipId PlaceId -> State Model () 53 | playerShipsEmbark _ = do 54 | traverse_ f . hmToList 55 | where 56 | f :: (ShipId, PlaceId) -> State Model () 57 | f (shipId, destId) = do 58 | ship <- getShip shipId <$> use modelShipsL 59 | case shipLocation ship of 60 | InFlight{} -> 61 | pure () 62 | 63 | Destroyed -> 64 | pure () 65 | 66 | AtPlace placeId -> do 67 | place <- getPlace placeId <$> use modelPlacesL 68 | let isBoosted = 69 | case placeType place of 70 | Ruin -> 71 | NotBoosted 72 | 73 | PBase base -> 74 | let friendly = PlayerOwner (shipPlayer ship) == baseOwner base 75 | booster = Set.member Booster (baseInstallations base) 76 | in if friendly && booster 77 | then Boosted 78 | else NotBoosted 79 | 80 | modelShipsL %= 81 | HM.adjust 82 | (shipLocationL .~ InFlight (placePoint place) destId isBoosted) 83 | shipId 84 | 85 | -- | Ships in flight move across the board, perhaps arriving 86 | -- at their destinations. 87 | shipsTravel :: State Model () 88 | shipsTravel = do 89 | hmTraverseWithKey_ travel =<< use modelShipsL 90 | where 91 | travel :: ShipId -> Ship -> State Model () 92 | travel shipId ship = do 93 | case shipLocation ship of 94 | AtPlace _ -> pure () 95 | Destroyed -> pure () 96 | InFlight loc destId isBoosted -> do 97 | dest <- getPlace destId <$> use modelPlacesL 98 | let 99 | speed :: Float 100 | speed = 101 | shipSpeed ship isBoosted 102 | 103 | destPoint :: Point 104 | destPoint = 105 | placePoint dest 106 | 107 | newLoc :: ShipLocation 108 | newLoc = 109 | if distance loc destPoint <= speed 110 | then 111 | AtPlace destId 112 | else 113 | InFlight (travelTowards loc destPoint speed) destId isBoosted 114 | 115 | modelShipsL %= HM.insert shipId (ship & shipLocationL .~ newLoc) 116 | 117 | travelTowards :: Point -> Point -> Float -> Point 118 | travelTowards currentLocation@(x,y) destPoint speed = 119 | ( x + deltaX 120 | , y + deltaY 121 | ) 122 | where 123 | deltaX :: Float 124 | deltaY :: Float 125 | (deltaX, deltaY) = 126 | deltas angle speed 127 | 128 | angle :: Float 129 | angle = 130 | angleBetweenPoints currentLocation destPoint 131 | -------------------------------------------------------------------------------- /src/View/Hud.hs: -------------------------------------------------------------------------------- 1 | module View.Hud where 2 | 3 | import qualified Data.HashMap.Strict as HM 4 | import Game hiding (Model) 5 | import Game.Prelude 6 | import Layout 7 | import Lib.Gloss 8 | import Model 9 | import View.Board 10 | import View.Ship 11 | 12 | viewHud :: Model -> Box -> Picture 13 | viewHud m@Model{..} hudDimensions@(Box width height) = 14 | fold 15 | [ whiteOnBlackBox hudDimensions 16 | , Translate 0 (height / 2 - 30) baseNameHeader 17 | , Translate 0 (height / 2 - 180) photo 18 | , case mIdPlace of 19 | Nothing -> -- We're in flight 20 | mempty 21 | 22 | Just (placeId, place) -> 23 | case placeType place of 24 | Ruin -> 25 | mempty 26 | 27 | PBase base -> 28 | if baseOwner base == PlayerOwner modelWhoAmI 29 | then 30 | Translate 0 (height / 2 - 345) $ 31 | Scale 1.2 1.2 $ 32 | centeredText white (buildingText modelOrders placeId base) 33 | else 34 | mempty 35 | ] 36 | where 37 | -- Are we in flight? 38 | mIdPlace :: Maybe (PlaceId, Place) 39 | mIdPlace = do 40 | placeId <- focusedBase m 41 | Just (placeId, getPlace placeId (modelPlaces modelGame)) 42 | 43 | baseNameHeader :: Picture 44 | baseNameHeader = 45 | Scale 2 2 $ 46 | case mIdPlace of 47 | Nothing -> centeredText white "" 48 | Just (_, place) -> 49 | case placeType place of 50 | Ruin -> 51 | centeredText white ("Ruins of " <> placeName place) 52 | 53 | PBase base -> 54 | centeredText (ownerColor (baseOwner base)) (placeName place) 55 | 56 | photo :: Picture 57 | photo = 58 | fold 59 | [ Color black $ rectangleSolid w h 60 | , Color white $ rectangleWire w h 61 | , case mIdPlace of 62 | Nothing -> mempty 63 | Just (_, place) -> 64 | Scale 1.2 1.2 $ 65 | case placeType place of 66 | Ruin -> 67 | ruinPicture 68 | 69 | PBase base -> 70 | viewBasePhoto base (sizeToRadius (placeSize place)) 71 | ] 72 | where 73 | w :: Float 74 | w = 75 | width - 50 76 | 77 | h :: Float 78 | h = 79 | w 80 | 81 | viewHudShip :: Model -> ShipId -> Box -> Picture 82 | viewHudShip Model{..} shipId (Box width height) = 83 | fold 84 | [ Scale 2 2 $ viewShipWithShieldIndicator ship 85 | , Translate 100 (-10) destination 86 | , if isFocused 87 | then Color yellow $ rectangleWire width height 88 | else mempty 89 | ] 90 | where 91 | ship :: Ship 92 | ship = 93 | getShip shipId (modelShips modelGame) 94 | 95 | isFocused :: Bool 96 | isFocused = 97 | let focusedDueToBaseSelection = 98 | case shipLocation ship of 99 | InFlight{} -> 100 | False 101 | 102 | Destroyed -> 103 | False 104 | 105 | AtPlace placeId -> 106 | SelectionPlace placeId == modelSelection 107 | && shipPlayer ship == modelWhoAmI 108 | -- Station's don't all move along with other ships 109 | -- because they're slow slow this will rarely be what 110 | -- the player wants: 111 | && shipType ship /= Station 112 | 113 | in SelectionShip shipId == modelSelection 114 | || focusedDueToBaseSelection 115 | 116 | destination :: Picture 117 | destination = 118 | let showDest :: PlaceId -> Picture 119 | showDest placeId = 120 | centeredText white (placeName (getPlace placeId places)) 121 | 122 | in case shipLocation ship of 123 | InFlight _ dest _ -> 124 | showDest dest 125 | 126 | AtPlace _ -> 127 | case HM.lookup shipId (ordersEmbark modelOrders) of 128 | Nothing -> 129 | mempty 130 | 131 | Just placeId -> 132 | showDest placeId 133 | 134 | Destroyed -> 135 | mempty 136 | 137 | places = modelPlaces modelGame 138 | 139 | viewBuildButton :: BuildOrder -> Clickable -> Box -> Picture 140 | viewBuildButton buildOrder clickable box = 141 | fold 142 | [ case clickable of 143 | NotClickable -> 144 | mempty 145 | 146 | Clickable -> 147 | whiteOnBlackBox box 148 | 149 | , centeredText white (buildOrderText buildOrder) 150 | ] 151 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # *Hermetic* 2 | 3 | A two player, simultaneous turn desktop strategy game. 4 | 5 | screenshot 6 | 7 | # Install 8 | 9 | See [docs/install.md](./docs/install.md). 10 | 11 | # Player guide 12 | 13 | [Start here](http://ianjeffries.net/id/9627/hermetic-0.0/Game-Model.html#t:Base). 14 | 15 | # Haddocks 16 | 17 | [Hosted here](http://ianjeffries.net/id/9627/hermetic-0.0/index.html). 18 | 19 | # Design 20 | 21 | Core module layout: 22 | 23 | ![modules](./misc/generated/core-modules.svg) 24 | 25 | ## Components 26 | 27 | ### Game rules 28 | 29 | ![sloc-game](./misc/generated/sloc-game.svg) 30 | 31 | Located at [./src/Game](./src/Game). Completely UI-agnostic, could be broken into its own separate package if we wanted. Imports nothing local outside of `Game.*`. 32 | 33 | ### Gloss UI 34 | 35 | ![sloc-ui](./misc/generated/sloc-ui.svg) 36 | 37 | Everything in [./src](./src) outside of `./src/Game/*`. 38 | 39 | Tracks local state like what base the user has selected. Uses the server to exchange orders with the opponent. When both players have moved uses the game rules to step the game forward. 40 | 41 | ### Server 42 | 43 | ![sloc-json-relay](./misc/generated/sloc-json-relay.svg) 44 | 45 | A local package located at [./json-relay](./json-relay). Provides an executable server which allows clients to join rooms and relays JSON messages between clients in the same room. Knows nothing about this specific game. 46 | 47 | ## MVU 48 | 49 | The UI uses a Model/View/Update architecture. The game rules also have a Model and Update, but no View. 50 | 51 | This can be summarized with a few type signatures. 52 | 53 | Game rules: 54 | ```hs 55 | -- in Game.Model 56 | data Model = Model 57 | { modelPlaces :: HashMap PlaceId Place 58 | ... 59 | } 60 | 61 | -- in Game.Update 62 | update :: HashMap Player Orders -> Model -> Model 63 | ``` 64 | 65 | Gloss UI: 66 | ```hs 67 | -- in Model, with Game.Model imported as Game 68 | data Model = Model 69 | { modelGame :: Game.Model 70 | , modelSelection :: Selection 71 | ... 72 | } 73 | 74 | -- in View 75 | view :: Model -> Picture 76 | 77 | -- in Update 78 | update :: Input -> Model -> Model 79 | ``` 80 | 81 | In Gloss unlike Elm there's no `Msg` type. That leaves it up to us to figure out how to get the View and Update agreeing on where clickable things are displayed without drowning in duplicate code. 82 | 83 | Our solution is the [Layout](./src/Layout.hs) module, which provides a description of where each clickable item is in the UI: 84 | 85 | ```hs 86 | newtype Layout item 87 | = Layout { unLayout :: [Set item] } 88 | 89 | uiLayout :: Model -> Layout Item 90 | ``` 91 | 92 | This is used by the View to render the UI and by Update to process clicks. 93 | 94 | ## NIH 95 | 96 | Having many features or graphics isn't a goal of the game. So we can use simple tools and implement the rest of what we need ourselves. 97 | 98 | We use [Gloss](http://hackage.haskell.org/package/gloss) which provides a keyboard/mouse [input type](http://hackage.haskell.org/package/gloss/docs/Graphics-Gloss-Interface-IO-Game.html#t:Event), an image [output type](http://hackage.haskell.org/package/gloss/docs/Graphics-Gloss-Data-Picture.html#t:Picture), and a MVU [app runner](http://hackage.haskell.org/package/gloss/docs/Graphics-Gloss-Interface-IO-Game.html#v:playIO). Since we implement everything else the code provides examples of panning, zooming, and mapping mouse clicks to UI items. 99 | 100 | ## Multiplayer 101 | 102 | Multiplayer is synchronous. 103 | 104 | Each player has a [Game.Model](./src/Game/Model.hs). When both players have ended their turns, each calls [Game.Update.update](./src/Game/Update.hs) with the same inputs (both their and their opponent's orders). This rolls the game model forward to the start of the next turn. 105 | 106 | This means `Game.Update.update` must be deterministic. We avoid functions like `Data.HashMap.Strict.toList` in the game code. 107 | 108 | Each player also has a UI model: [Model](./src/Model.hs). These will have different values for each player. 109 | 110 | There's no attempt to make the game resistant to bad actors. If someone wants to cheat they can modify their client to view board info that should be hidden. 111 | 112 | # Why no PRs? 113 | 114 | For this particular project I wanted the satisfaction of doing the coding myself. 115 | 116 | Fork and add your own twist! 117 | 118 | # Special thanks 119 | 120 | + Mitchell Rosen: for getting multiplayer working in *The Depths*, an earlier game this multiplayer implementation is based off of. 121 | 122 | + Gib Jeffries: for map development in Onshape and playtesting. 123 | -------------------------------------------------------------------------------- /hermetic.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.31.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: cb26573dd4a92344a612e08df5f5ed9e0ee24eb6d79588db0b48aeb255fb1b74 8 | 9 | name: hermetic 10 | version: 0.0 11 | description: A two player, simultaneous turn desktop strategy game. Homepage [on GitHub](https://github.com/seagreen/hermetic). 12 | . 13 | If you're looking for a place to start reading I recommend "Game.Model". Data > code. 14 | license: BSD3 15 | build-type: Simple 16 | 17 | library 18 | exposed-modules: 19 | App 20 | Cli 21 | Game 22 | Game.Model 23 | Game.Outcome 24 | Game.Prelude 25 | Game.Update 26 | Game.Update.Bombard 27 | Game.Update.Build 28 | Game.Update.Combat 29 | Game.Update.Diplomacy 30 | Game.Update.Disease 31 | Game.Update.Shared 32 | Game.Update.Travel 33 | Layout 34 | Lib.Gloss 35 | Model 36 | Scenario.Crisis 37 | Scenario.Tannen 38 | Update 39 | View 40 | View.Board 41 | View.Hud 42 | View.Ship 43 | other-modules: 44 | Paths_hermetic 45 | hs-source-dirs: 46 | src 47 | default-extensions: NoImplicitPrelude RecordWildCards StrictData DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings PackageImports RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 48 | ghc-options: -Wall 49 | build-depends: 50 | MonadRandom 51 | , aeson 52 | , aeson-pretty 53 | , base 54 | , bytestring 55 | , containers 56 | , directory 57 | , filepath 58 | , gitrev 59 | , gloss 60 | , hashable 61 | , json-relay 62 | , lens 63 | , mtl 64 | , optparse-applicative 65 | , safe 66 | , safe-exceptions 67 | , split 68 | , stm 69 | , template-haskell 70 | , text 71 | , time 72 | , transformers 73 | , unordered-containers 74 | default-language: Haskell2010 75 | 76 | executable hermetic 77 | main-is: Main.hs 78 | other-modules: 79 | Paths_hermetic 80 | hs-source-dirs: 81 | ./misc 82 | default-extensions: NoImplicitPrelude RecordWildCards StrictData DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings PackageImports RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 83 | ghc-options: -Wall -threaded -rtsopts 84 | build-depends: 85 | MonadRandom 86 | , aeson 87 | , aeson-pretty 88 | , base 89 | , bytestring 90 | , containers 91 | , directory 92 | , filepath 93 | , gitrev 94 | , gloss 95 | , hashable 96 | , hermetic 97 | , json-relay 98 | , lens 99 | , mtl 100 | , optparse-applicative 101 | , safe 102 | , safe-exceptions 103 | , split 104 | , stm 105 | , template-haskell 106 | , text 107 | , time 108 | , transformers 109 | , unordered-containers 110 | default-language: Haskell2010 111 | 112 | test-suite spec 113 | type: exitcode-stdio-1.0 114 | main-is: Spec.hs 115 | other-modules: 116 | Game.ModelSpec 117 | LayoutSpec 118 | Lib.MathSpec 119 | Paths_hermetic 120 | hs-source-dirs: 121 | test 122 | default-extensions: NoImplicitPrelude RecordWildCards StrictData DataKinds DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings PackageImports RankNTypes ScopedTypeVariables TypeFamilies TypeOperators 123 | ghc-options: -Wall 124 | build-depends: 125 | MonadRandom 126 | , QuickCheck 127 | , aeson 128 | , aeson-pretty 129 | , base 130 | , bytestring 131 | , containers 132 | , directory 133 | , filepath 134 | , gitrev 135 | , gloss 136 | , hashable 137 | , hermetic 138 | , hspec 139 | , json-relay 140 | , lens 141 | , mtl 142 | , optparse-applicative 143 | , safe 144 | , safe-exceptions 145 | , split 146 | , stm 147 | , template-haskell 148 | , text 149 | , time 150 | , transformers 151 | , unordered-containers 152 | default-language: Haskell2010 153 | -------------------------------------------------------------------------------- /src/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Model where 4 | 5 | import Control.Monad.Trans.State 6 | import qualified Data.HashMap.Strict as HM 7 | import Game.Model hiding (Model) 8 | import qualified Game.Model 9 | import Game.Prelude 10 | import qualified Scenario.Crisis 11 | import qualified Scenario.Tannen 12 | 13 | data Model = Model 14 | { modelGame :: Game.Model.Model 15 | , modelSelection :: Selection 16 | , modelOrders :: Orders 17 | , modelTurnEnded :: Bool 18 | , modelOpponentOrders :: HashMap Player Orders 19 | , modelWhoAmI :: Player 20 | , modelPan :: BoardPoint 21 | , modelZoom :: Zoom 22 | , modelPlaceScroll :: HashMap PlaceId Natural 23 | , modelScreenSize :: Box 24 | , modelCursorDot :: ScreenPoint 25 | , modelDragToPan :: Drag 26 | , modelTick :: Tick 27 | , modelPopup :: [CombatLog] 28 | , modelExit :: Bool 29 | } deriving stock (Generic) 30 | deriving anyclass (ToJSON) 31 | 32 | init :: Gen -> Box -> Scenario -> Player -> Model 33 | init gen screenSize scenario currentPlayer = 34 | Model 35 | { modelGame = game 36 | , modelSelection = startingSelection 37 | , modelOrders = mempty 38 | , modelTurnEnded = False 39 | , modelOpponentOrders = mempty 40 | , modelWhoAmI = currentPlayer 41 | , modelPan = BoardPoint 0 0 42 | , modelZoom = NoZoom 43 | , modelPlaceScroll = mempty 44 | , modelScreenSize = screenSize 45 | , modelCursorDot = ScreenPoint 10000 10000 -- off the screen to start 46 | , modelDragToPan = NotDragging 47 | , modelTick = Tick 48 | , modelPopup = mempty 49 | , modelExit = False 50 | } 51 | where 52 | game :: Game.Model.Model 53 | game = 54 | let fillBoard :: State Game.Model.Model () 55 | fillBoard = case scenario of 56 | Tannen -> Scenario.Tannen.fillBoard 57 | Crisis -> Scenario.Crisis.fillBoard 58 | in execState fillBoard (Game.Model.init gen) 59 | 60 | startingSelection :: Selection 61 | startingSelection = 62 | case HM.keys (HM.filter friendly (modelPlaces game)) of 63 | [] -> SelectionNone 64 | id:_ -> SelectionPlace id 65 | where 66 | friendly :: Place -> Bool 67 | friendly place = 68 | case placeType place of 69 | Ruin -> 70 | False 71 | 72 | PBase base -> 73 | baseOwner base == PlayerOwner currentPlayer 74 | 75 | data Scenario 76 | = Tannen 77 | | Crisis 78 | deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) 79 | deriving anyclass (ToJSON, FromJSON) 80 | 81 | data Selection 82 | = SelectionNone 83 | | SelectionPlace PlaceId 84 | | SelectionShip ShipId 85 | deriving stock (Eq, Ord, Show, Generic) 86 | deriving anyclass (ToJSON) 87 | 88 | data CombatLog 89 | = CombatLog PlaceId (Set ShipId) 90 | deriving stock (Eq, Ord, Show, Generic) 91 | deriving anyclass (ToJSON) 92 | 93 | -- | Since we only have animations that blink on and off 94 | -- (like thursters for moving ships) we only need to track 95 | -- two states of time. 96 | data Tick 97 | = Tick 98 | | Tock 99 | deriving stock (Eq, Ord, Show, Generic) 100 | deriving anyclass (ToJSON) 101 | 102 | data Zoom 103 | = NoZoom 104 | | ZoomOut 105 | | ZoomOut2 106 | | ZoomOut3 107 | | ZoomOut4 108 | deriving stock (Eq, Ord, Show, Generic) 109 | deriving anyclass (ToJSON) 110 | 111 | data Drag 112 | = NotDragging 113 | | PossibleDragStart ScreenPoint 114 | -- ^ ScreenPoint is where the mouse was when the left button 115 | -- was pressed down. 116 | -- 117 | -- If the user then moves the mouse past a certan threshold 118 | -- we switch to Dragging. 119 | -- 120 | -- If they release the button before that happens 121 | -- they were using left click to clear their current 122 | -- selection, so we do that and switch to NotDragging. 123 | | Dragging ScreenPoint 124 | -- ^ ScreenPoint is the last position of the mouse. 125 | deriving stock (Eq, Ord, Show, Generic) 126 | deriving anyclass (ToJSON) 127 | 128 | -- | An unprocessed gloss point (to become a game point will need to be 129 | -- de-panned and de-zoomed). 130 | data ScreenPoint 131 | = ScreenPoint Float Float 132 | deriving stock (Eq, Ord, Show, Generic) 133 | deriving anyclass (ToJSON) 134 | 135 | data HudPoint 136 | = HudPoint Float Float 137 | deriving stock (Eq, Ord, Show, Generic) 138 | deriving anyclass (ToJSON) 139 | 140 | data BoardPoint 141 | = BoardPoint Float Float 142 | deriving stock (Eq, Ord, Show, Generic) 143 | deriving anyclass (ToJSON) 144 | 145 | fromScreenPoint :: ScreenPoint -> Point 146 | fromScreenPoint (ScreenPoint x y) = 147 | (x,y) 148 | 149 | fromHudPoint :: HudPoint -> Point 150 | fromHudPoint (HudPoint x y) = 151 | (x,y) 152 | 153 | fromBoardPoint :: BoardPoint -> Point 154 | fromBoardPoint (BoardPoint x y) = 155 | (x,y) 156 | 157 | maxZoom :: Zoom 158 | maxZoom = 159 | NoZoom 160 | 161 | zoomIn :: Zoom -> Zoom 162 | zoomIn = \case 163 | NoZoom -> NoZoom 164 | ZoomOut -> NoZoom 165 | ZoomOut2 -> ZoomOut 166 | ZoomOut3 -> ZoomOut2 167 | ZoomOut4 -> ZoomOut3 168 | 169 | zoomOut :: Zoom -> Zoom 170 | zoomOut = \case 171 | NoZoom -> ZoomOut 172 | ZoomOut -> ZoomOut2 173 | ZoomOut2 -> ZoomOut3 174 | ZoomOut3 -> ZoomOut4 175 | ZoomOut4 -> ZoomOut4 176 | 177 | -- * Lenses 178 | mkLenses ''Model 179 | -------------------------------------------------------------------------------- /src/Game/Update/Disease.hs: -------------------------------------------------------------------------------- 1 | module Game.Update.Disease 2 | ( diseaseSpread 3 | , shipsHeal 4 | ) where 5 | 6 | import Control.Monad.Trans.State 7 | import qualified Data.HashMap.Strict as HM 8 | import qualified Data.List as List 9 | import Game.Model 10 | import Game.Prelude 11 | import Game.Update.Shared 12 | 13 | -- | __Player guide previous__: 'Game.Update.Travel.shipsEmbark' 14 | -- 15 | -- The world contains diseases that can damage or destroy bases. 16 | -- 17 | -- There's a slight chance of a disease outbreak at each base each turn. 18 | -- When the base will have 'baseDisease' set to 'Latent' and you'll see 19 | -- an indicator of this. 20 | -- 21 | -- @Latent@ diseases have a small chance of spreading or getting worse each 22 | -- turn. If they get worse they become 'Plague's, which have a high chance 23 | -- of spreading or getting worse each turn. 24 | -- 25 | -- When @Plague@s get worse they reduce the population at that base by one, 26 | -- or if it is already at the minimum, have a slight chance of destroying it. 27 | -- 28 | -- If one player has uncontested ships at a base any disease there is countered 29 | -- in two ways: 30 | -- 31 | -- 1. There's a chance of the disease being healed, down to @Latent@ if it was 32 | -- a @Plague@, and healed entirely if it was @Latent@. 33 | -- 34 | -- 2. Disease are less likely to spread to the base, or if already there 35 | -- less likely to get worse. Unlike healing, this effect is stronger the more 36 | -- ships there are present. 37 | -- 38 | -- __Next__: 'ShipType' 39 | diseaseSpread :: State Model () 40 | diseaseSpread = do 41 | turn <- use modelTurnL 42 | frozenPlaces <- use modelPlacesL 43 | forBasesWithControlStatus (f turn frozenPlaces) 44 | where 45 | f :: Natural 46 | -> HashMap PlaceId Place 47 | -> PlaceId 48 | -> Base 49 | -> Maybe (Player, HashMap ShipId Ship) 50 | -> State Model () 51 | f turn frozenPlaces placeId _ mController = 52 | case placeType (getPlace placeId frozenPlaces) of 53 | Ruin -> 54 | pure () 55 | 56 | PBase base -> 57 | diseaseAtBase turn placeId base mController 58 | 59 | -- | Whether diseases get worse or spread is calculated 60 | -- based on the level of disease at the start of the turn. 61 | -- 62 | -- To ensure this in the function above we freeze the places hashmap, 63 | -- and use it to lookup bases which are passed into this function. 64 | -- 65 | -- That way this function doesn't have to pull the bases out of the 66 | -- of the 'State', potentially getting ones that have already had their 67 | -- disease level raised this turn. 68 | diseaseAtBase 69 | :: Natural 70 | -> PlaceId 71 | -> Base 72 | -> Maybe (Player, HashMap ShipId Ship) 73 | -> State Model () 74 | diseaseAtBase turn placeId base mController = do 75 | case baseDisease base of 76 | Healthy -> 77 | when (turn >= 10) runDeNovo 78 | 79 | Latent -> do 80 | runSpread (shipModifier 0.05) 81 | runWorsen (shipModifier 0.07) 82 | 83 | Plague -> do 84 | runSpread (shipModifier 0.4) 85 | runWorsen (shipModifier 0.5) 86 | where 87 | runDeNovo :: State Model () 88 | runDeNovo = do 89 | started <- runRandom $ probability (shipModifier 0.01) 90 | when started $ adjustBase placeId (baseDiseaseL .~ Latent) 91 | 92 | runSpread :: Double -> State Model () 93 | runSpread chance = do 94 | didSpread <- runRandom $ probability chance 95 | when didSpread $ do 96 | places <- use modelPlacesL 97 | res <- runRandom (frontWeightedChoice (sortByClosest placeId places)) 98 | case res of 99 | Nothing -> 100 | pure () 101 | 102 | Just target -> 103 | worsen target 104 | 105 | runWorsen :: Double -> State Model () 106 | runWorsen chance = do 107 | didWorsenHere <- runRandom $ probability chance 108 | when didWorsenHere (worsen placeId) 109 | 110 | -- If exactly one player has ships orbiting a base, the chance of disease 111 | -- effects is lessened. 112 | shipModifier :: Double -> Double 113 | shipModifier n = 114 | case mController of 115 | Nothing -> 116 | n 117 | 118 | Just (_, controllingShips) -> 119 | repeatedlyApply (* 0.5) (fromIntegral (HM.size controllingShips)) n 120 | 121 | sortByClosest :: PlaceId -> HashMap PlaceId Place -> [PlaceId] 122 | sortByClosest placeId places = 123 | map fst . List.sortOn f . HM.toList . HM.delete placeId $ places 124 | where 125 | place = getPlace placeId places 126 | 127 | f :: (PlaceId, Place) -> Float 128 | f (_,a) = 129 | distance (placePoint place) (placePoint a) 130 | 131 | worsen :: PlaceId -> State Model () 132 | worsen placeId = do 133 | places <- use modelPlacesL 134 | let place = getPlace placeId places 135 | case placeType place of 136 | Ruin -> 137 | pure () 138 | 139 | PBase base -> 140 | if baseDisease base /= maxBound 141 | then 142 | adjustBase placeId (baseDiseaseL %~ nextBounded) 143 | 144 | else 145 | if basePopulation base /= minPop 146 | then 147 | adjustBase placeId (basePopulationL %~ prevPop) 148 | else do 149 | fallIntoRuin <- runRandom (probability 0.05) 150 | when fallIntoRuin $ 151 | modelPlacesL %= HM.adjust (placeTypeL .~ Ruin) placeId 152 | 153 | -- | When a players ships are present at a base unopposed they have a chance 154 | -- of healing any disease there. 155 | shipsHeal :: State Model () 156 | shipsHeal = 157 | forControlledBases healCheck 158 | 159 | healCheck :: PlaceId -> Base -> Player -> HashMap ShipId Ship -> State Model () 160 | healCheck placeId base _ _ = do 161 | case baseDisease base of 162 | Healthy -> 163 | pure () 164 | 165 | Latent -> 166 | attemptHeal 167 | 168 | Plague -> 169 | attemptHeal 170 | where 171 | attemptHeal :: State Model () 172 | attemptHeal = do 173 | b <- runRandom (probability 0.3) 174 | when b $ adjustBase placeId (baseDiseaseL %~ prevBounded) 175 | -------------------------------------------------------------------------------- /src/View.hs: -------------------------------------------------------------------------------- 1 | module View 2 | ( view 3 | ) where 4 | 5 | import qualified Data.Set as Set 6 | import qualified Data.Text as T 7 | import Game hiding (Model) 8 | import Game.Prelude 9 | import Layout 10 | import Lib.Gloss 11 | import Model 12 | import View.Board 13 | import View.Hud 14 | import View.Ship 15 | 16 | view :: Model -> Picture 17 | view m@Model{..} = 18 | fold 19 | [ clickableItems 20 | , topLeft modelScreenSize (viewStatus m) 21 | , viewCursor m 22 | , viewPopup m modelPopup 23 | , viewTurnEndedNotice m 24 | , viewOutcomeNotice m 25 | ] 26 | where 27 | clickableItems :: Picture 28 | clickableItems = 29 | map viewLayoutItems (unLayout (uiLayout m)) 30 | & reverse -- Gloss's Picture monoid layers bottom-to-top, not top-to-bottom 31 | & fold 32 | 33 | viewLayoutItems :: Set Item -> Picture 34 | viewLayoutItems = 35 | fold . map (viewItem m) . Set.toList 36 | 37 | viewItem :: Model -> Item -> Picture 38 | viewItem m@Model{..} = \case 39 | HudItem item (ScreenPoint x y) -> 40 | Translate x y $ 41 | case item of 42 | ItemHudShip id box -> 43 | viewHudShip m id box 44 | 45 | ItemBuildButton _ buildOrder clickable box -> 46 | viewBuildButton buildOrder clickable box 47 | 48 | ItemPreviousPage _ box -> 49 | previousButton box 50 | 51 | ItemNextPage _ box -> 52 | nextButton box 53 | 54 | HudItself _ (ScreenPoint x y) hudDimensions -> 55 | if modelSelection == SelectionNone 56 | then mempty 57 | else Translate x y $ viewHud m hudDimensions 58 | 59 | BoardItem item (x,y) -> 60 | panAndZoom m . Translate x y $ 61 | case item of 62 | ItemBase id radius -> viewPlace m id radius 63 | ItemShip id radius -> viewShipInFlight m id (x,y) radius 64 | 65 | previousButton :: Box -> Picture 66 | previousButton box = 67 | fold 68 | [ whiteOnBlackBox box 69 | , centeredText white "Previous" 70 | ] 71 | 72 | nextButton :: Box -> Picture 73 | nextButton box = 74 | fold 75 | [ whiteOnBlackBox box 76 | , centeredText white "Next" 77 | ] 78 | 79 | viewPopup :: Model -> [CombatLog] -> Picture 80 | viewPopup m = \case 81 | [] -> 82 | mempty 83 | 84 | popup:_ -> 85 | viewSinglePopup m popup 86 | 87 | viewSinglePopup :: Model -> CombatLog -> Picture 88 | viewSinglePopup Model{..} (CombatLog id ships) = 89 | fold 90 | [ whiteOnBlackBox (Box 600 800) 91 | , Translate 0 280 $ Scale 2 2 $ centeredText white ("Combat at " <> placeName (getPlace id places)) 92 | , case Set.toList ships of 93 | [] -> 94 | mempty 95 | 96 | _ -> 97 | Scale 1.2 1.2 $ Translate 0 180 $ fold 98 | [ centeredText white "Destroyed" 99 | , Translate (-14) (-10) $ centeredText white "-------" 100 | , Translate 0 (-40) $ centeredText white destroyedMsg 101 | ] 102 | 103 | , Translate 0 (-300) $ 104 | centeredText white " to dismiss" 105 | ] 106 | where 107 | places = modelPlaces modelGame 108 | 109 | destroyedMsg :: Text 110 | destroyedMsg = 111 | T.intercalate ", " $ map destroyedName $ Set.toList ships 112 | 113 | destroyedName :: ShipId -> Text 114 | destroyedName shipId = 115 | case shipPlayer (getShip shipId (modelShips modelGame)) of 116 | Player1 -> "Player 1 ship" 117 | Player2 -> "Player 2 ship" 118 | 119 | viewTurnEndedNotice :: Model -> Picture 120 | viewTurnEndedNotice Model{..} = 121 | case outcome modelGame of 122 | Victor victor -> 123 | if modelWhoAmI == victor 124 | then 125 | fold 126 | [ coloredBox green (Box 400 100) 127 | , centeredText white "Victory" 128 | ] 129 | else 130 | defeat 131 | 132 | AllDefeated -> 133 | defeat 134 | 135 | Ongoing -> 136 | mempty 137 | where 138 | defeat :: Picture 139 | defeat = 140 | fold 141 | [ coloredBox red (Box 400 100) 142 | , centeredText white "Defeat" 143 | ] 144 | 145 | viewOutcomeNotice :: Model -> Picture 146 | viewOutcomeNotice Model{..} = 147 | if modelTurnEnded 148 | then 149 | fold 150 | [ whiteOnBlackBox (Box 400 100) 151 | , centeredText white "Waiting for opponent" 152 | ] 153 | else 154 | mempty 155 | 156 | viewStatus :: Model -> Picture 157 | viewStatus Model{modelGame, modelWhoAmI} = 158 | verticalConcatText 159 | [ viewPlayerName modelWhoAmI 160 | , viewTurn (modelTurn modelGame) 161 | , viewText white "[c] to center" 162 | ] 163 | 164 | viewPlayerName :: Player -> Picture 165 | viewPlayerName player = 166 | viewText (playerColor player) (playerName player) 167 | 168 | viewTurn :: Natural -> Picture 169 | viewTurn turn = 170 | viewText white ("Turn: " <> T.pack (show turn) <> " ( to end turn)") 171 | 172 | topLeft :: Box -> Picture -> Picture 173 | topLeft (Box screenWidth screenHeight) = 174 | Translate 20 (-40) . Translate (-x) y 175 | where 176 | x :: Float 177 | x = 178 | screenWidth / 2 179 | 180 | y :: Float 181 | y = 182 | screenHeight / 2 183 | 184 | viewCursor :: Model -> Picture 185 | viewCursor m@Model{..} = 186 | Translate mouseX mouseY $ color $ circleSolid 3 187 | where 188 | ScreenPoint mouseX mouseY = modelCursorDot 189 | 190 | color :: Picture -> Picture 191 | color = 192 | case uiLayoutLookup m modelCursorDot of 193 | Nothing -> Color (greyN 0.5) 194 | Just item -> 195 | case item of 196 | HudItem{} -> identity 197 | HudItself{} -> identity 198 | BoardItem ItemBase{} _ -> Color red 199 | BoardItem{} -> Color (greyN 0.5) 200 | 201 | panAndZoom :: Model -> Picture -> Picture 202 | panAndZoom Model{modelPan, modelZoom} = 203 | scaleZoom . translatePan -- The order (pan, then zoom) matters here. 204 | where 205 | translatePan :: Picture -> Picture 206 | translatePan = 207 | let BoardPoint x y = modelPan 208 | in Translate (negate x) (negate y) 209 | 210 | scaleZoom :: Picture -> Picture 211 | scaleZoom = 212 | let zf = zoomFactor modelZoom 213 | in Scale zf zf 214 | -------------------------------------------------------------------------------- /json-relay/src/JsonRelay/Server.hs: -------------------------------------------------------------------------------- 1 | -- | Server that bounces JSON messages between clients. 2 | -- 3 | -- Clients send 'Message's. 4 | -- 5 | -- 'messageRoom' is read to find the room, then the 'messageBody' is sent 6 | -- to each other client subscribed to that room. So clients send 7 | -- @Message@s and receive 'Value's. 8 | -- 9 | -- Clients are subscribed to the first room they send a message to. 10 | module JsonRelay.Server where 11 | 12 | import Control.Concurrent (forkFinally) 13 | import Control.Concurrent.Async 14 | import Control.Concurrent.STM 15 | import Control.Exception.Safe (bracket) 16 | import Control.Monad 17 | import Data.Aeson 18 | import Data.ByteString (ByteString) 19 | import Data.Text (Text) 20 | import JsonRelay.Shared 21 | (Message(..), MessagePart(..), RoomName(..), endOfMessage, getOneAddrInfo, 22 | maxBytes, splitMessages) 23 | import Network.Socket 24 | (AddrInfo(..), AddrInfoFlag(..), SockAddr(..), Socket(..), SocketOption(..), 25 | SocketType(..)) 26 | import Numeric.Natural 27 | import Prelude hiding (log) 28 | import System.IO.Error (ioError, userError) 29 | 30 | import qualified Data.ByteString as BS 31 | import qualified Data.ByteString.Lazy as LBS 32 | import qualified Data.Text as T 33 | import qualified Data.Text.IO as T 34 | import qualified Network.Socket as Socket 35 | import qualified Network.Socket.ByteString as NetworkBts 36 | import qualified Streaming.Prelude as S 37 | import qualified System.IO 38 | 39 | data Config = Config 40 | { configPort :: Natural 41 | } deriving Show 42 | 43 | newtype BroadcastChan 44 | = BroadcastChan { unBroadcastChan :: TChan (Message, SockAddr) } 45 | 46 | log :: Text -> IO () 47 | log = 48 | T.hPutStrLn System.IO.stderr 49 | 50 | run :: Config -> IO () 51 | run (Config port) = do 52 | 53 | addr <- resolve port 54 | 55 | chan <- BroadcastChan <$> newBroadcastTChanIO 56 | 57 | bracket 58 | (open addr) 59 | Socket.close 60 | -- Watch out for @(forever (acceptClient chan))@, which loops forever. 61 | (forever . acceptClient chan :: Socket -> IO void) 62 | 63 | resolve :: Natural -> IO AddrInfo 64 | resolve port = do 65 | addr <- getOneAddrInfo (Just hints) Nothing (Just (show port)) 66 | log (T.unlines 67 | [ "Filled out AddrInfo:" 68 | , T.pack (show addr) 69 | , "" 70 | ]) 71 | pure addr 72 | where 73 | hints :: AddrInfo 74 | hints = 75 | Socket.defaultHints 76 | { addrFlags = [AI_PASSIVE] 77 | , addrSocketType = Stream 78 | } 79 | 80 | -- | @socket@, @bind@ and @listen@. 81 | open :: AddrInfo -> IO Socket 82 | open addr = do 83 | sock <- Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 84 | Socket.setSocketOption sock ReuseAddr 1 85 | Socket.bind sock (addrAddress addr) 86 | -- From @network@: 87 | -- 88 | -- @ 89 | -- If the prefork technique is not used, set CloseOnExec for the security reasons. 90 | -- @ 91 | Socket.setCloseOnExecIfNeeded (Socket.fdSocket sock) 92 | Socket.listen sock maxQueuedConnections 93 | pure sock 94 | where 95 | -- From `network`: 96 | -- 97 | -- @ 98 | -- The second argument specifies the maximum number of queued connections 99 | -- and should be at least 1; the maximum value is system-dependent (usually 5). 100 | -- @ 101 | maxQueuedConnections :: Int 102 | maxQueuedConnections = 103 | 10 104 | 105 | -- | @accept@ 106 | acceptClient :: BroadcastChan -> Socket -> IO () 107 | acceptClient chan sock = do 108 | (conn :: Socket, peer :: SockAddr) <- Socket.accept sock 109 | log $ "Connection from " <> T.pack (show peer) 110 | void $ forkFinally (handleClient peer chan conn) (\_ -> Socket.close conn) 111 | 112 | -- | @recvFrom@ and @sendAll@. 113 | -- 114 | -- From @network@: 115 | -- 116 | -- @ 117 | -- If multiple threads use one Socket concurrently, unexpected things would happen. 118 | -- There is one exception for multiple threads vs a single Socket: 119 | -- one thread reads data from a Socket only and the other thread writes data to the Socket only. 120 | -- @ 121 | handleClient :: SockAddr -> BroadcastChan -> Socket -> IO () 122 | handleClient addr chan sock = do 123 | readingChannel <- atomically $ dupTChan (unBroadcastChan chan) 124 | room <- newTVarIO Nothing 125 | race_ 126 | (fromClient room sock chan) 127 | (forever (toClient room sock addr readingChannel)) 128 | 129 | toClient :: TVar (Maybe RoomName) -> Socket -> SockAddr -> TChan (Message, SockAddr) -> IO () 130 | toClient room sock sockAdr chan = do 131 | ((msg, addr), roomName) <- 132 | atomically $ (,) <$> readTChan chan <*> readTVar room 133 | 134 | when (addr /= sockAdr && Just (messageRoom msg) == roomName) $ 135 | NetworkBts.sendAll sock $ 136 | LBS.toStrict ( encode (messageBody msg) 137 | <> LBS.singleton endOfMessage 138 | ) 139 | 140 | fromClient :: TVar (Maybe RoomName) -> Socket -> BroadcastChan -> IO () 141 | fromClient room sock chan = do 142 | S.foldM_ next (pure []) (\_ -> pure ()) $ 143 | S.for (S.untilRight receive) splitMessages 144 | where 145 | next :: [ByteString] -> MessagePart -> IO [ByteString] 146 | next remainder part = do 147 | case part of 148 | Complete bts addr -> 149 | let final = BS.concat (reverse (bts : remainder)) 150 | in case eitherDecodeStrict final of 151 | Left e -> do 152 | ioError $ userError ("Error decoding message: " <> e) 153 | 154 | Right msg -> do 155 | process msg addr 156 | pure [] 157 | 158 | Partial bts _ -> 159 | pure (bts : remainder) 160 | 161 | receive :: IO (Either (ByteString, SockAddr) ()) 162 | receive = do 163 | (bts, addr) <- NetworkBts.recvFrom sock maxBytes 164 | if BS.null bts 165 | then 166 | pure $ Right () 167 | 168 | else 169 | pure $ Left (bts, addr) 170 | 171 | process :: Message -> SockAddr -> IO () 172 | process msg addr = do 173 | let name :: RoomName 174 | name = messageRoom msg 175 | oldName <- 176 | atomically $ do 177 | writeTChan (unBroadcastChan chan) (msg, addr) 178 | swapTVar room (Just name) 179 | when (oldName /= Just name) $ 180 | log ("Address " <> T.pack (show addr) <> " subscribed to room: " <> unRoomName name) 181 | -------------------------------------------------------------------------------- /src/Game/Update/Build.hs: -------------------------------------------------------------------------------- 1 | module Game.Update.Build 2 | ( baseProduction 3 | , buildCost 4 | , build 5 | ) where 6 | 7 | import Control.Monad.Trans.State 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.Set as Set 10 | import Game.Model 11 | import Game.Prelude 12 | import Game.Update.Shared 13 | 14 | -- | A base's production is determined by its 'Population'. 15 | -- 16 | -- (An exception is 'Neutral' bases, which progress at a smaller, fixed rate 17 | -- so they're not all at max population by the midgame). 18 | baseProduction :: HashMap ShipId Ship -> Base -> Double 19 | baseProduction shipsAtThisBase base = 20 | stationModifier $ 21 | case basePopulation base of 22 | Outpost -> 0.5 23 | Settlement -> 0.75 24 | City -> 1 25 | Megacity -> 1.25 26 | Ecumenopolis -> 1.5 27 | where 28 | stationModifier :: Double -> Double 29 | stationModifier = 30 | case HM.keys (HM.filter friendlyStation shipsAtThisBase) of 31 | [] -> identity 32 | [_] -> (+) 0.1 33 | _ -> (+) 0.2 34 | 35 | friendlyStation :: Ship -> Bool 36 | friendlyStation ship = 37 | PlayerOwner (shipPlayer ship) == baseOwner base 38 | && shipType ship == Station 39 | 40 | -- | Calculate a @BuildOrder@'s cost. 'BuildPopulation' costs more 41 | -- the higher the next population, so requires the @Base@ argument 42 | -- to calculate it. 43 | buildCost :: Base -> BuildOrder -> Double 44 | buildCost base = \case 45 | BuildShield -> 8 46 | BuildBooster -> 5 47 | BuildPopulation -> 48 | case basePopulation base of 49 | Outpost -> 3 50 | Settlement -> 5 51 | City -> 7 52 | Megacity -> 10 53 | Ecumenopolis -> 0 54 | BuildShip shipType -> 55 | case shipType of 56 | Corvette -> 5 57 | Station -> 8 58 | Monitor -> 15 59 | 60 | -- | If a base completes what it's currently building and can't build 61 | -- more of it (e.g. a base that just completed an 'Ecumenopolis') 62 | -- then it switches to 'Corvette's. 63 | build :: HashMap Player (HashMap PlaceId BuildOrder) -> State Model () 64 | build orders = do 65 | places <- use modelPlacesL 66 | for_ (HM.keys places) $ \id -> do 67 | switch placesToOrders id 68 | progress id 69 | checkForCompletion id 70 | where 71 | placesToOrders :: HashMap PlaceId (Player, BuildOrder) 72 | placesToOrders = 73 | let a1 :: [(Player, HashMap PlaceId BuildOrder)] 74 | a1 = 75 | HM.toList orders 76 | 77 | f :: ( Player 78 | , HashMap PlaceId BuildOrder 79 | ) 80 | -> HashMap PlaceId (Player, BuildOrder) 81 | f (player, a) = 82 | map (\b -> (player, b)) a 83 | 84 | a2 :: [HashMap PlaceId (Player, BuildOrder)] 85 | a2 = 86 | map f a1 87 | 88 | in 89 | fold a2 90 | 91 | switch :: HashMap PlaceId (Player, BuildOrder) -> PlaceId -> State Model () 92 | switch buildOrders id = do 93 | place <- getPlace id <$> use modelPlacesL 94 | case placeType place of 95 | Ruin -> 96 | -- NOTE: The UI should never send us building orders for ruins, 97 | -- so maybe a log statement should go here? 98 | pure () 99 | 100 | PBase base -> 101 | case HM.lookup id buildOrders of 102 | Just (orderingPlayer, newOrder) -> 103 | -- NOTE: The UI should never send us building orders from a player 104 | -- who doesn't own a base, so maybe a log statement should go here? 105 | when (PlayerOwner orderingPlayer == baseOwner base) $ 106 | adjustBase id (baseBuildingL .~ newOrder) 107 | 108 | Nothing -> 109 | pure () 110 | 111 | progress :: PlaceId -> State Model () 112 | progress id = do 113 | place <- getPlace id <$> use modelPlacesL 114 | case placeType place of 115 | Ruin -> 116 | pure () 117 | 118 | PBase base -> do 119 | ships <- shipsAtPlace id <$> use modelShipsL 120 | let amount :: Double 121 | amount = 122 | case baseOwner base of 123 | Neutral _ -> 124 | 0.1 125 | 126 | PlayerOwner _ -> 127 | baseProduction ships base 128 | adjustBase 129 | id 130 | (baseInProgressL %~ HM.insertWith (+) (baseBuilding base) amount) 131 | 132 | checkForCompletion :: PlaceId -> State Model () 133 | checkForCompletion id = do 134 | place <- getPlace id <$> use modelPlacesL 135 | case placeType place of 136 | Ruin -> 137 | pure () 138 | 139 | PBase base -> 140 | case HM.lookup (baseBuilding base) (baseInProgress base) of 141 | Nothing -> 142 | pure () 143 | 144 | Just soFar -> do 145 | let wouldRemain :: Double 146 | wouldRemain = 147 | soFar - buildCost base (baseBuilding base) 148 | when (wouldRemain >= 0) $ complete base wouldRemain 149 | where 150 | complete :: Base -> Double -> State Model () 151 | complete Base{..} remaining = do 152 | let f :: HashMap BuildOrder Double -> HashMap BuildOrder Double 153 | f = if remaining > 0 154 | then HM.insert baseBuilding remaining 155 | else HM.delete baseBuilding 156 | adjustBase id (baseInProgressL %~ f) 157 | case baseBuilding of 158 | BuildPopulation -> do 159 | modelPlacesL %= HM.adjust incrementPop id 160 | newPlace <- getPlace id <$> use modelPlacesL 161 | when (not (canExpand newPlace)) $ 162 | -- NOTE: This switches neutrals to building ships, so they'll seesaw 163 | -- because neutrals can't actually complete ships. 164 | adjustBase id (baseBuildingL .~ BuildShip Corvette) 165 | 166 | BuildShip shipType -> 167 | case baseOwner of 168 | Neutral _ -> 169 | adjustBase id (baseBuildingL .~ BuildPopulation) 170 | 171 | PlayerOwner player -> 172 | void $ newShip (Ship player (AtPlace id) shipType True) 173 | 174 | BuildShield -> do 175 | adjustBase id ( (baseInstallationsL %~ Set.insert Shield) 176 | . (baseShieldsL .~ startingShields) 177 | ) 178 | switchToCorvettes 179 | 180 | BuildBooster -> do 181 | adjustBase id (baseInstallationsL %~ Set.insert Booster) 182 | switchToCorvettes 183 | 184 | switchToCorvettes :: State Model () 185 | switchToCorvettes = 186 | adjustBase id (baseBuildingL .~ BuildShip Corvette) 187 | -------------------------------------------------------------------------------- /src/App.hs: -------------------------------------------------------------------------------- 1 | -- | Wrap 'Model.init', 'View.view', and 'Update.update' into a 2 | -- function @app :: Config -> IO ()@. 3 | -- 4 | -- In Elm this would be the @Main@ module, but Haskell requires that to be 5 | -- the name of the module containing the runnable @main :: IO a@ function. 6 | -- We're not ready to that yet until we also have code to parse a 'Config' 7 | -- from CLI arguments. 8 | module App 9 | ( Config(..) 10 | , app 11 | , runGame 12 | , runWithClient 13 | , RoomMsg(..) 14 | ) where 15 | 16 | import Control.Concurrent 17 | import Control.Concurrent.STM 18 | import Control.Monad.State.Lazy 19 | import Data.Aeson.Encode.Pretty (encodePretty) 20 | import qualified Data.ByteString as BS 21 | import qualified Data.ByteString.Lazy as LBS 22 | import qualified Data.Text as T 23 | import qualified Data.Text.IO as TIO 24 | import qualified Game 25 | import Game.Prelude 26 | import Graphics.Gloss.Interface.Environment (getScreenSize) 27 | import Graphics.Gloss.Interface.IO.Game (Display(FullScreen), black) 28 | import qualified Graphics.Gloss.Interface.IO.Game as Gloss 29 | import JsonRelay.Client (Client(..), RoomName(..)) 30 | import qualified JsonRelay.Client as Client 31 | import Model 32 | import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) 33 | import System.Exit (exitSuccess) 34 | import System.FilePath (()) 35 | import qualified System.IO 36 | import Update 37 | import View 38 | 39 | data Config = Config 40 | { configHost :: Text 41 | , configPort :: Natural 42 | , configRoom :: RoomName 43 | , configScenario :: Scenario 44 | , configSandbox :: Bool 45 | } deriving Show 46 | 47 | app :: Config -> IO () 48 | app (Config host port room scenario localSandbox) = 49 | if localSandbox 50 | then runSandbox scenario 51 | else runMultiplayer host port room scenario 52 | 53 | runGame 54 | :: (Game.Player -> Game.Orders -> IO ()) 55 | -> IO (Maybe (Game.Player, Game.Orders)) 56 | -> Scenario 57 | -> Game.Player 58 | -> Game.Gen 59 | -> IO () 60 | runGame sendOrders pollOpponentOrders scenario player seed = do 61 | modelLogFile <- createModelLogFile 62 | screenSize <- startingScreenSize 63 | 64 | Gloss.playIO 65 | FullScreen 66 | black -- background color 67 | 1 -- number of simulation steps to take for each second of real time 68 | (init seed screenSize scenario player) 69 | runView 70 | (runUpdate modelLogFile) 71 | runTickUpdate 72 | where 73 | runView :: Model -> IO Gloss.Picture 74 | runView = 75 | pure . view 76 | 77 | runUpdate :: FilePath -> Gloss.Event -> Model -> IO Model 78 | runUpdate modelLogFile event oldModel = do 79 | let m = update (UserEvent event) oldModel 80 | BS.writeFile modelLogFile (LBS.toStrict (encodePretty m)) 81 | case updateResult oldModel m of 82 | Exit -> 83 | exitSuccess 84 | 85 | PlayerEndedTurn orders -> do 86 | sendOrders (modelWhoAmI m) orders 87 | pure m 88 | 89 | Normal -> 90 | pure m 91 | 92 | runTickUpdate :: Float -> Model -> IO Model 93 | runTickUpdate elapsed model = do 94 | mOrders <- pollOpponentOrders 95 | let newModel = case mOrders of 96 | Nothing -> model 97 | Just (p, o) -> update (OpponentOrders p o) model 98 | pure $ update (TimePassed elapsed) newModel 99 | 100 | startingScreenSize :: IO Box 101 | startingScreenSize = do 102 | (width, height) <- getScreenSize 103 | pure $ Box (realToFrac width) (realToFrac height) 104 | 105 | runSandbox :: Scenario -> IO () 106 | runSandbox scenario = do 107 | seed <- Game.Gen <$> newStdGen 108 | runGame mockSend mockReceive scenario Game.Player1 seed 109 | where 110 | mockSend :: Game.Player -> Game.Orders -> IO () 111 | mockSend _ _ = 112 | pure () 113 | 114 | -- NOTE: This is sending a lot more opponent responses 115 | -- than usually expected (since it succeeds every time). 116 | -- 117 | -- Sadly, it also sends them more slowly than desireable 118 | -- for single player. If you end turn more than once 119 | -- in a second you'll see the "waiting for opponent" 120 | -- notification. 121 | mockReceive :: IO (Maybe (Game.Player, Game.Orders)) 122 | mockReceive = 123 | pure (Just (Game.Player2, mempty)) 124 | 125 | data RoomMsg 126 | = Announce 127 | | Existing Game.Gen Scenario 128 | | Turn Game.Player Game.Orders 129 | deriving stock (Show, Generic) 130 | deriving anyclass (ToJSON, FromJSON) 131 | 132 | runMultiplayer :: Text -> Natural -> RoomName -> Scenario -> IO () 133 | runMultiplayer host port room scenario = 134 | Client.run logTxt host port room (runWithClient scenario) 135 | 136 | runWithClient :: Scenario -> Client -> IO () 137 | runWithClient scenario Client{clientSend, clientReceive} = do 138 | c <- newTChanIO 139 | void $ forkIO (forever (receive c)) 140 | 141 | (player, chosenScenario, seed) <- start c 142 | 143 | runGame 144 | sendOrders 145 | (pollOpponentOrders c) 146 | chosenScenario 147 | player 148 | seed 149 | where 150 | sendOrders :: Game.Player -> Game.Orders -> IO () 151 | sendOrders p o = 152 | clientSend (toJSON (Turn p o)) 153 | 154 | receive :: TChan RoomMsg -> IO () 155 | receive chan = do 156 | bts <- clientReceive 157 | case eitherDecodeStrict bts of 158 | Left e -> 159 | error ("couldn't decode bts" <> show e) 160 | 161 | Right msg -> 162 | atomically (writeTChan chan msg) 163 | 164 | start :: TChan RoomMsg -> IO (Game.Player, Scenario, Game.Gen) 165 | start chan = do 166 | clientSend (toJSON Announce) 167 | res <- atomically (readTChan chan) 168 | case res of 169 | Announce -> do 170 | seed <- Game.Gen <$> newStdGen 171 | clientSend (toJSON (Existing seed scenario)) 172 | pure (Game.Player1, scenario, seed) 173 | 174 | Existing seed hostScenario -> 175 | pure (Game.Player2, hostScenario, seed) 176 | 177 | Turn{} -> 178 | error "unexpected turn message" 179 | 180 | pollOpponentOrders :: TChan RoomMsg -> IO (Maybe (Game.Player, Game.Orders)) 181 | pollOpponentOrders chan = do 182 | res <- atomically (tryReadTChan chan) 183 | case res of 184 | Nothing -> 185 | pure Nothing 186 | 187 | Just (Turn player orders) -> 188 | pure $ Just (player, orders) 189 | 190 | Just _ -> error "wrong message type received" 191 | 192 | createModelLogFile :: IO FilePath 193 | createModelLogFile = do 194 | temp <- getTemporaryDirectory 195 | 196 | -- GUID appended so we don't conflict with anything: 197 | let ourDir = temp "hermetic-7c6d1406-ee0c-4c15-95c6-8cf401c20a8b" 198 | 199 | createDirectoryIfMissing False ourDir 200 | 201 | let ourFile = ourDir "model.json" 202 | 203 | logTxt ("Writing the model to:\n" <> T.pack ourFile) 204 | pure ourFile 205 | 206 | logTxt :: Text -> IO () 207 | logTxt = 208 | TIO.hPutStrLn System.IO.stderr 209 | -------------------------------------------------------------------------------- /src/Game/Update/Shared.hs: -------------------------------------------------------------------------------- 1 | -- | Functions that are used by more than one @Game.Update.*@ module 2 | -- or are likely to be generally useful go here. 3 | module Game.Update.Shared where 4 | 5 | import Control.Monad.Trans.State 6 | import qualified Data.HashMap.Strict as HM 7 | import qualified Data.Set as Set 8 | import Game.Model 9 | import Game.Prelude 10 | 11 | startingShields :: Natural 12 | startingShields = 13 | 5 14 | 15 | -- | We could replace @State Model@ with a newtype throughout the code 16 | -- and make that newtype an instance of 'MonadRandom'. However in the 17 | -- interests of sight-reading we avoid that and use this function 18 | -- when we need randomness. 19 | runRandom :: Rand StdGen a -> State Model a 20 | runRandom go = do 21 | Gen stdGen <- use modelRandomL 22 | let (res, nextStdGen) = runRand go stdGen 23 | modelRandomL .= Gen nextStdGen 24 | pure res 25 | 26 | -- | The Maybe is whether there are controlling ships or not. 27 | -- 28 | -- There are controlling ships when only a single player has ships over the base. 29 | -- 30 | -- An alternate way of implementing this would be to write: 31 | -- 32 | -- @ 33 | -- basesWithControlStatus :: State Model [(PlaceId, Base, Maybe (Player, HashMap ShipId Ship))] 34 | -- @ 35 | -- 36 | -- but when we consumed this using: 37 | -- 38 | -- @ 39 | -- xs <- basesWithControlStatus 40 | -- traverse_ foo xs 41 | -- @ 42 | -- 43 | -- ... each @foo@ call would get statically frozen @Base@ and @HashMap ShipId Ship@ 44 | -- arguments, instead of ones that have been affected by earlier calls of @foo@. 45 | -- This is correct for some circumstances, but we don't default to it because 46 | -- the risk of overwriting new values with old ones is scary. 47 | forBasesWithControlStatus 48 | :: (PlaceId -> Base -> Maybe (Player, HashMap ShipId Ship) -> State Model ()) 49 | -> State Model () 50 | forBasesWithControlStatus action = 51 | traverse_ f =<< map HM.keys (use modelPlacesL) 52 | where 53 | f :: PlaceId -> State Model () 54 | f placeId = do 55 | place <- getPlace placeId <$> use modelPlacesL 56 | case placeType place of 57 | Ruin -> 58 | pure () 59 | 60 | PBase base -> do 61 | ships <- shipsAtPlace placeId <$> use modelShipsL 62 | let players :: Set Player 63 | players = 64 | Set.fromList $ shipPlayer <$> HM.elems ships 65 | 66 | case Set.toList players of 67 | [controllingPlayer] -> 68 | action placeId base (Just (controllingPlayer, ships)) 69 | 70 | _ -> 71 | action placeId base Nothing 72 | 73 | forControlledBases 74 | :: (PlaceId -> Base -> Player -> HashMap ShipId Ship -> State Model ()) 75 | -> State Model () 76 | forControlledBases action = 77 | forBasesWithControlStatus f 78 | where 79 | f :: PlaceId -> Base -> Maybe (Player, HashMap ShipId Ship) -> State Model () 80 | f placeId base mController = do 81 | case mController of 82 | Nothing -> 83 | pure () 84 | 85 | Just (controllingPlayer, ships) -> 86 | action placeId base controllingPlayer ships 87 | 88 | forOccupiedBases 89 | :: (PlaceId -> Base -> Player -> HashMap ShipId Ship -> State Model ()) 90 | -> State Model () 91 | forOccupiedBases action = 92 | forBasesWithControlStatus f 93 | where 94 | f :: PlaceId -> Base -> Maybe (Player, HashMap ShipId Ship) -> State Model () 95 | f placeId base mController = do 96 | case mController of 97 | Nothing -> 98 | pure () 99 | 100 | Just (controllingPlayer, ships) -> 101 | if PlayerOwner controllingPlayer == baseOwner base 102 | then 103 | pure () 104 | 105 | else 106 | action placeId base controllingPlayer ships 107 | 108 | forUnoccupiedBases 109 | :: (PlaceId -> Base -> State Model ()) 110 | -> State Model () 111 | forUnoccupiedBases action = 112 | forBasesWithControlStatus f 113 | where 114 | f :: PlaceId -> Base -> Maybe (Player, HashMap ShipId Ship) -> State Model () 115 | f placeId base mController = do 116 | case mController of 117 | Nothing -> 118 | action placeId base 119 | 120 | Just (controllingPlayer, _) -> 121 | if PlayerOwner controllingPlayer == baseOwner base 122 | then 123 | action placeId base 124 | 125 | else 126 | pure () 127 | 128 | -- | A common enough operation to get its own function. 129 | adjustBase :: PlaceId -> (Base -> Base) -> State Model () 130 | adjustBase id f = 131 | modelPlacesL %= HM.adjust (placeTypeL . _PBase %~ f) id 132 | 133 | newId :: State Model Natural 134 | newId = do 135 | n <- use modelNextIdL 136 | modelNextIdL += 1 137 | pure n 138 | 139 | newShip :: Ship -> State Model ShipId 140 | newShip ship = do 141 | id <- ShipId <$> newId 142 | modelShipsL %= HM.insert id ship 143 | pure id 144 | 145 | canExpand :: Place -> Bool 146 | canExpand place = 147 | case placeType place of 148 | Ruin -> 149 | False 150 | 151 | PBase base -> 152 | case placeSize place of 153 | Small -> 154 | basePopulation base < City 155 | 156 | Medium -> 157 | basePopulation base < Megacity 158 | 159 | Large -> 160 | basePopulation base < Ecumenopolis 161 | 162 | minPop :: Population 163 | minPop = 164 | Outpost 165 | 166 | prevPop :: Population -> Population 167 | prevPop = \case 168 | Outpost -> Outpost 169 | Settlement -> Outpost 170 | City -> Settlement 171 | Megacity -> City 172 | Ecumenopolis -> Megacity 173 | 174 | incrementPop :: Place -> Place 175 | incrementPop place = 176 | if canExpand place 177 | then place & placeTypeL . _PBase . basePopulationL %~ next 178 | else place 179 | where 180 | next :: Population -> Population 181 | next = \case 182 | Outpost -> Settlement 183 | Settlement -> City 184 | City -> Megacity 185 | Megacity -> Ecumenopolis 186 | Ecumenopolis -> Ecumenopolis 187 | 188 | getShip :: ShipId -> HashMap ShipId Ship -> Ship 189 | getShip id ships = 190 | case HM.lookup id ships of 191 | Just a -> a 192 | Nothing -> error "getShip failed" 193 | 194 | getPlace :: PlaceId -> HashMap PlaceId Place -> Place 195 | getPlace id bases = 196 | case HM.lookup id bases of 197 | Just a -> a 198 | _ -> error "getPlace failed" 199 | 200 | shipsInFlight :: HashMap ShipId Ship -> HashMap ShipId (Ship, Point, PlaceId) 201 | shipsInFlight = 202 | HM.mapMaybe f 203 | where 204 | f :: Ship -> Maybe (Ship, Point, PlaceId) 205 | f ship = 206 | case shipLocation ship of 207 | InFlight point dest _ -> Just (ship, point, dest) 208 | Destroyed -> Nothing 209 | AtPlace _ -> Nothing 210 | 211 | shipsAtPlace :: PlaceId -> HashMap ShipId Ship -> HashMap ShipId Ship 212 | shipsAtPlace placeId = 213 | HM.mapMaybe f 214 | where 215 | f :: Ship -> Maybe Ship 216 | f ship = do 217 | loc <- case shipLocation ship of 218 | InFlight{} -> Nothing 219 | Destroyed -> Nothing 220 | AtPlace a -> Just a 221 | guard (loc == placeId) 222 | pure ship 223 | -------------------------------------------------------------------------------- /src/Game/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK ignore-exports #-} 2 | 3 | -- | Re-exports hidden. They include a bunch of stuff from "Prelude", 4 | -- other parts of @base@, @containers@, etc. See source for details. 5 | module Game.Prelude 6 | ( module Game.Prelude 7 | , module X 8 | ) where 9 | 10 | import Control.Category as X ((>>>)) 11 | import Control.Lens as X hiding (Zoom, index, view, zoom) 12 | import Control.Monad as X hiding (fmap) 13 | import Control.Monad.Random as X hiding (next) 14 | import Data.Aeson as X hiding ((.=)) 15 | import Data.Foldable as X 16 | import Data.Hashable as X (Hashable) 17 | import Data.HashMap.Strict as X (HashMap) 18 | import Data.Map.Strict as X (Map) 19 | import Data.Maybe as X 20 | import Data.Ord as X hiding (Down) 21 | import Data.Set as X (Set) 22 | import Data.Text as X (Text) 23 | import Debug.Trace as X 24 | import GHC.Generics as X (Generic) 25 | import Graphics.Gloss.Interface.IO.Game as X (Point) 26 | import Numeric.Natural as X (Natural) 27 | import Prelude as X hiding (fmap, id, init, map, pred, succ) 28 | import Safe.Foldable as X (maximumByMay, minimumByMay) 29 | 30 | import qualified Control.Monad.Random as MonadRandom 31 | import qualified Data.HashMap.Strict as HM 32 | import qualified Data.List as List 33 | import qualified Data.Set as Set 34 | import qualified Data.Text as T 35 | import Language.Haskell.TH 36 | import qualified Numeric 37 | import qualified Prelude 38 | import qualified Safe 39 | 40 | atMostDecimals :: Natural -> Double -> Text 41 | atMostDecimals n d = 42 | T.dropWhileEnd (=='.') 43 | . T.dropWhileEnd (== '0') 44 | . T.pack 45 | $ Numeric.showFFloat (Just (fromIntegral n)) d "" 46 | 47 | enumerateAll :: (Enum a, Bounded a, Ord a) => Set a 48 | enumerateAll = 49 | Set.fromList [minBound .. maxBound] 50 | 51 | reverseOrdering :: Ordering -> Ordering 52 | reverseOrdering = \case 53 | LT -> GT 54 | EQ -> EQ 55 | GT -> LT 56 | 57 | -- | A replacement for 'HM.toList' where the result order is sorted 58 | -- by key instead of being left unspecified. 59 | hmToList :: Ord k => HashMap k v -> [(k,v)] 60 | hmToList = 61 | List.sortOn fst . HM.toList 62 | 63 | hmTraverseWithKey_ :: Applicative f => (k -> v1 -> f ()) -> HashMap k v1 -> f () 64 | hmTraverseWithKey_ f = 65 | traverse_ (uncurry f) . HM.toList 66 | 67 | identity :: a -> a 68 | identity = 69 | Prelude.id 70 | 71 | map :: Functor f => (a -> b) -> f a -> f b 72 | map = 73 | Prelude.fmap 74 | 75 | mapWithIndex :: (Natural -> a -> b) -> [a] -> [b] 76 | mapWithIndex f = 77 | zipWith f [0..] 78 | 79 | -- | Make lenses suffixed with "L" 80 | -- (from https://stackoverflow.com/a/26563262) 81 | mkLenses :: Name -> DecsQ 82 | mkLenses = 83 | makeLensesWith appendL 84 | where 85 | appendL :: LensRules 86 | appendL = 87 | lensRules 88 | & lensField .~ \_ _ name -> [TopName (mkName (nameBase name <> "L"))] 89 | 90 | repeatedlyApply :: (a -> a) -> Natural -> a -> a 91 | repeatedlyApply f n a = 92 | iterate f a !! fromIntegral n 93 | 94 | repeatedlyApplyM :: forall a m. Monad m => (a -> m a) -> Natural -> a -> m a 95 | repeatedlyApplyM f n start = 96 | foldM g start ns 97 | where 98 | ns :: [()] 99 | ns = 100 | replicate (fromIntegral n) () 101 | 102 | g :: a -> () -> m a 103 | g a () = 104 | f a 105 | 106 | -- | These rely on Enum and Bounded behaving as expected. 107 | prevBounded :: (Enum a, Eq a, Bounded a) => a -> a 108 | prevBounded = 109 | Safe.predSafe 110 | 111 | nextBounded :: (Enum a, Eq a, Bounded a) => a -> a 112 | nextBounded = 113 | Safe.succSafe 114 | 115 | -------------------------------------------------------------------------------- 116 | -- * Randomness 117 | 118 | probability 119 | :: MonadRandom m 120 | => Double -- ^ From 0 to 1. 121 | -> m Bool 122 | probability n = do 123 | res <- MonadRandom.getRandomR (0, 1) 124 | pure (res <= n) 125 | 126 | frontWeightedChoice :: forall a m. MonadRandom m => [a] -> m (Maybe a) 127 | frontWeightedChoice xs = 128 | MonadRandom.weightedMay (fst (foldl' f ([], 1) xs)) 129 | where 130 | f :: ([(a, Rational)], Double) -> a -> ([(a, Rational)], Double) 131 | f (ys, n) y = 132 | ( (y, toRational n) : ys 133 | , n * decreaseBy 134 | ) 135 | 136 | decreaseBy :: Double 137 | decreaseBy = 138 | 2/3 139 | 140 | -- | Given some number of "hits" spread them out over a collection of targets. 141 | distributeHits 142 | :: forall m k a. 143 | (MonadRandom m, Eq k, Hashable k) 144 | => (a -> Maybe a) 145 | -- ^ When a target is "hit", determine whether it can be hit any more. 146 | -- 147 | -- @Just@ means it can (e.g. it had shields and so wasn't destroyed). 148 | -- 149 | -- @Nothing@ means it cannot (e.g. it was destroyed). 150 | -> HashMap k a 151 | -- ^ Targets 152 | -> Natural 153 | -- ^ Number of hits 154 | -> m (HashMap k a, HashMap k a) 155 | -- ^ The first part of the tuple is destoyed targets, the second is not destroyed. 156 | distributeHits resultOfHit targets numHits = 157 | repeatedlyApplyM f numHits (mempty, targets) 158 | where 159 | f :: (HashMap k a, HashMap k a) -> m (HashMap k a, HashMap k a) 160 | f (destroyedSoFar, currentTargets) = do 161 | mTarget <- MonadRandom.uniformMay (HM.toList currentTargets) 162 | pure $ 163 | case mTarget of 164 | Nothing -> 165 | (destroyedSoFar, currentTargets) 166 | 167 | Just (id, target) -> 168 | case resultOfHit target of 169 | Nothing -> 170 | ( HM.insert id target destroyedSoFar 171 | , HM.delete id currentTargets 172 | ) 173 | 174 | Just updatedTarget -> 175 | ( destroyedSoFar 176 | , HM.insert id updatedTarget currentTargets 177 | ) 178 | 179 | -------------------------------------------------------------------------------- 180 | -- * Math 181 | 182 | data Rectangle = Rectangle 183 | { rectangleOrigin :: Point 184 | , rectangleWidth :: Float 185 | , rectangleHeight :: Float 186 | } deriving (Eq, Ord, Show, Generic) 187 | 188 | data Box = Box 189 | { boxWidth :: Float 190 | , boxHeight :: Float 191 | } deriving stock (Eq, Ord, Show, Generic) 192 | deriving anyclass (ToJSON) 193 | -- ToJSON needed because used by the model for screen size 194 | 195 | newtype Radius 196 | = Radius { unRadius :: Float } 197 | deriving (Eq, Ord, Show) 198 | 199 | -- | Given a point, if it's not in a certain rectangle return nothing. 200 | -- 201 | -- If it is in the rectangle, transform its coordinates to be 202 | -- relative to the center of the rectangle. 203 | rectangleCoordinates :: Point -> Rectangle -> Maybe Point 204 | rectangleCoordinates (x,y) (Rectangle (centerX,centerY) width height) = do 205 | guard (x >= centerX - width / 2) 206 | guard (x <= centerX + width / 2) 207 | guard (y >= centerY - height / 2) 208 | guard (y <= centerY + height / 2) 209 | Just (x - centerX , y - centerY) 210 | 211 | angleBetweenPoints :: Point -> Point -> Float 212 | angleBetweenPoints (x1,y1) (x2,y2) = 213 | atan2 (y2 - y1) (x2 - x1) 214 | 215 | distance :: Point -> Point -> Float 216 | distance (x1,y1) (x2,y2) = 217 | sqrt ((x1 - x2)^(2 :: Int) + (y1 - y2)^(2 :: Int)) 218 | 219 | deltas :: Float -> Float -> (Float, Float) 220 | deltas angle speed = 221 | ( speed * cos angle 222 | , speed * sin angle 223 | ) 224 | 225 | toDegrees :: Float -> Float 226 | toDegrees n = 227 | n * 180 / pi 228 | -------------------------------------------------------------------------------- /misc/generated/core-modules.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | 6 | 7 | 9 | 10 | %3 11 | 12 | 13 | cluster_1 14 | 15 | Game rules 16 | 17 | 18 | cluster_2 19 | 20 | Gloss UI 21 | 22 | 23 | cluster_3 24 | 25 | Server 26 | 27 | 28 | 29 | Game.Model 30 | 31 | Game.Model 32 | 33 | 34 | 35 | Game.Update 36 | 37 | Game.Update 38 | 39 | 40 | 41 | Game.Model->Game.Update 42 | 43 | 44 | 45 | 46 | 47 | Model 48 | 49 | Model 50 | 51 | 52 | 53 | Game.Model->Model 54 | 55 | 56 | 57 | 58 | 59 | Layout 60 | 61 | Layout 62 | 63 | 64 | 65 | Game.Update->Layout 66 | 67 | 68 | 69 | 70 | 71 | View 72 | 73 | View 74 | 75 | 76 | 77 | App 78 | 79 | App 80 | 81 | 82 | 83 | View->App 84 | 85 | 86 | 87 | 88 | 89 | Model->Layout 90 | 91 | 92 | 93 | 94 | 95 | Layout->View 96 | 97 | 98 | 99 | 100 | 101 | Update 102 | 103 | Update 104 | 105 | 106 | 107 | Layout->Update 108 | 109 | 110 | 111 | 112 | 113 | Update->App 114 | 115 | 116 | 117 | 118 | 119 | Cli 120 | 121 | Cli 122 | 123 | 124 | 125 | App->Cli 126 | 127 | 128 | 129 | 130 | 131 | JsonRelay.Client 132 | 133 | JsonRelay.Client 134 | 135 | 136 | 137 | JsonRelay.Client->App 138 | 139 | 140 | 141 | 142 | 143 | -------------------------------------------------------------------------------- /src/View/Board.hs: -------------------------------------------------------------------------------- 1 | module View.Board 2 | ( viewPlace 3 | , ruinPicture 4 | , viewBasePhoto 5 | , buildingText 6 | , viewShipInFlight 7 | , buildOrderText 8 | , ownerColor 9 | , playerName 10 | ) where 11 | 12 | import qualified Data.HashMap.Strict as HM 13 | import qualified Data.Set as Set 14 | import qualified Data.Text as T 15 | import Game hiding (Model) 16 | import Game.Prelude 17 | import Layout 18 | import Lib.Gloss 19 | import Model 20 | import View.Ship 21 | 22 | viewPlace :: Model -> PlaceId -> Radius -> Picture 23 | viewPlace m@Model{..} id radius = 24 | case placeType place of 25 | Ruin -> 26 | viewRuin m id radius 27 | 28 | PBase base -> 29 | viewBase m id base radius 30 | where 31 | place = getPlace id places 32 | 33 | places = modelPlaces modelGame 34 | 35 | viewRuin :: Model -> PlaceId -> Radius -> Picture 36 | viewRuin m id radius = 37 | fold 38 | [ ruinPicture 39 | , focusCircle m id radius 40 | , translateBelowBase radius $ verticalConcatText $ 41 | viewText white "Ruin" 42 | : viewShipsAtPlace m id 43 | ] 44 | 45 | ruinPicture :: Picture 46 | ruinPicture = 47 | foldMap craterLine [0, 45, 90, 135, 180, 225, 270, 315] 48 | where 49 | craterLine :: Float -> Picture 50 | craterLine degrees = 51 | Rotate degrees $ Color white $ Line [(0,20), (0, 30)] 52 | 53 | viewBase :: Model -> PlaceId -> Base -> Radius -> Picture 54 | viewBase m@Model{..} id base@Base{..} radius = 55 | fold 56 | [ viewBasePhoto base radius 57 | , focusCircle m id radius 58 | , translateBelowBase radius $ 59 | verticalConcatText 60 | ( [ viewText (ownerColor baseOwner) (placeName place) 61 | , viewText white (T.pack (show basePopulation)) 62 | , case baseOwner of 63 | Neutral attitude -> 64 | -- Show attitude 65 | case HM.lookup modelWhoAmI attitude of 66 | Nothing -> 67 | mempty 68 | 69 | Just friendliness -> 70 | viewText white ("Friendliness: " <> T.pack (show friendliness)) 71 | 72 | PlayerOwner _ -> 73 | -- Show production 74 | 75 | let prodShips = 76 | if hasDetection modelWhoAmI (Just place) shipsAtThisBase 77 | then 78 | shipsAtThisBase 79 | else 80 | -- Don't show the production bonus of Stations 81 | -- if we can't see them. 82 | mempty 83 | 84 | in viewText white ("Production: " <> atMostDecimals 2 (baseProduction prodShips base)) 85 | 86 | , if baseOwner == PlayerOwner modelWhoAmI 87 | then viewText white (buildingText modelOrders id base) 88 | else mempty 89 | , if baseShields /= 0 && baseShields < startingShields 90 | then viewText shieldColor $ "Shields: " <> T.pack (show baseShields) 91 | <> "/" <> T.pack (show startingShields) 92 | else mempty 93 | ] 94 | <> viewShipsAtPlace m id 95 | ) 96 | , viewDisease modelTick baseDisease 97 | ] 98 | where 99 | place = getPlace id places 100 | 101 | places = modelPlaces modelGame 102 | 103 | shipsAtThisBase = shipsAtPlace id (modelShips modelGame) 104 | 105 | viewBasePhoto :: Base -> Radius -> Picture 106 | viewBasePhoto Base{..} radius = 107 | fold 108 | [ Color (ownerColor baseOwner) $ Circle (unRadius radius) 109 | , viewBaseShields radius baseShields 110 | ] 111 | 112 | viewBaseShields :: Radius -> Natural -> Picture 113 | viewBaseShields radius shields = 114 | if shields < 1 115 | then 116 | mempty 117 | else 118 | Color shieldColor $ ThickCircle (unRadius radius - 4) 2 119 | 120 | viewShipsAtPlace :: Model -> PlaceId -> [Picture] 121 | viewShipsAtPlace Model{..} id = 122 | if hasDetection modelWhoAmI (Just place) ships 123 | then 124 | viewPlayerShips <$> Set.toList enumerateAll 125 | 126 | else 127 | mempty 128 | where 129 | viewPlayerShips :: Player -> Picture 130 | viewPlayerShips p = 131 | case snd <$> sortShipsForUI (HM.filter (\s -> shipPlayer s == p) ships) of 132 | [] -> mempty 133 | [x] -> Translate 15 5 $ viewShip x 134 | x:xs -> 135 | Translate 15 5 $ 136 | viewShip x 137 | <> Translate 8 (-5) 138 | (viewText 139 | (playerColor p) 140 | (" x" <> T.pack (show (length xs + 1)))) 141 | 142 | ships :: HashMap ShipId Ship 143 | ships = 144 | shipsAtPlace id (modelShips modelGame) 145 | 146 | place :: Place 147 | place = 148 | getPlace id (modelPlaces modelGame) 149 | 150 | focusCircle :: Model -> PlaceId -> Radius -> Picture 151 | focusCircle m id radius = 152 | if isFocusedBase m id 153 | then Color yellow $ Circle (unRadius radius + 2) 154 | else mempty 155 | 156 | translateBelowBase :: Radius -> Picture -> Picture 157 | translateBelowBase (Radius radius) = 158 | Translate (negate (radius / 2)) (negate (radius + 20)) 159 | 160 | viewDisease :: Tick -> Disease -> Picture 161 | viewDisease tick = \case 162 | Healthy -> 163 | mempty 164 | 165 | Latent -> 166 | fold 167 | [ Color orange $ ThickCircle 10 10 168 | , case tick of 169 | Tick -> mempty 170 | Tock -> 171 | Translate 40 0 $ 172 | fold 173 | [ Translate 50 0 $ 174 | fold 175 | [ Color black $ rectangleSolid 130 25 176 | , Color orange $ rectangleWire 130 25 177 | ] 178 | , verticallyCenteredText orange "Disease latent" 179 | ] 180 | ] 181 | 182 | Plague -> 183 | fold 184 | [ Color red $ ThickCircle 10 10 185 | , case tick of 186 | Tick -> mempty 187 | Tock -> 188 | Translate 40 0 $ 189 | fold 190 | [ Translate 25 0 $ 191 | fold 192 | [ Color black $ rectangleSolid 80 25 193 | , Color orange $ rectangleWire 80 25 194 | ] 195 | , verticallyCenteredText red "Plague" 196 | ] 197 | ] 198 | 199 | buildingText :: Orders -> PlaceId -> Base -> Text 200 | buildingText orders id base@Base{..} = 201 | case HM.lookup id (ordersBuild orders) of 202 | Nothing -> 203 | "Building: " <> T.toLower (buildOrderText baseBuilding) <> " " <> progress baseBuilding 204 | Just new -> 205 | "Switching to: " <> T.toLower (buildOrderText new) <> " " <> progress new 206 | where 207 | progress :: BuildOrder -> Text 208 | progress build = 209 | let n = case HM.lookup build baseInProgress of 210 | Nothing -> "0" 211 | Just a -> atMostDecimals 2 a 212 | in "(" <> n <> "/" <> atMostDecimals 2 (buildCost base build) <> ")" 213 | 214 | viewShipInFlight :: Model -> ShipId -> Point -> Radius -> Picture 215 | viewShipInFlight Model{..} id loc _ 216 | | modelWhoAmI /= shipPlayer ship = mempty 217 | | otherwise = 218 | Rotate (negate (toDegrees angle)) $ fold 219 | [ viewShip ship 220 | , perhapsViewThrust 221 | ] 222 | where 223 | ship :: Ship 224 | ship = getShip id ships 225 | 226 | perhapsViewThrust :: Picture 227 | perhapsViewThrust = 228 | case isBoosted of 229 | Boosted -> 230 | thrustPicture 231 | 232 | NotBoosted -> 233 | case modelTick of 234 | Tick -> 235 | mempty 236 | 237 | Tock -> 238 | thrustPicture 239 | 240 | thrustPicture :: Picture 241 | thrustPicture = 242 | viewThrust (shipPlayer ship) 243 | & Scale (1/2) (1/2) 244 | 245 | -- move thrust behind the ship 246 | -- (the ship hasn't been rotated towards its destination yet). 247 | & Translate translateAmount 0 248 | 249 | translateAmount :: Float 250 | translateAmount = 251 | case shipType ship of 252 | Corvette -> 253 | -24 254 | 255 | Station -> 256 | -18 257 | 258 | Monitor -> 259 | -24 260 | 261 | angle :: Float 262 | angle = 263 | angleBetweenPoints loc destPoint 264 | 265 | destPoint :: Point 266 | isBoosted :: IsBoosted 267 | (destPoint, isBoosted) = 268 | case shipLocation ship of 269 | AtPlace _ -> 270 | error "ship should be in flight" 271 | 272 | Destroyed -> 273 | error "ship should be in flight" 274 | 275 | InFlight _ destId boosted -> 276 | (placePoint (getPlace destId places), boosted) 277 | 278 | places = modelPlaces modelGame 279 | 280 | ships = modelShips modelGame 281 | 282 | buildOrderText :: BuildOrder -> Text 283 | buildOrderText = \case 284 | BuildPopulation -> "Population" 285 | BuildShield -> "Shield" 286 | BuildBooster -> "Booster" 287 | BuildShip shipType -> 288 | case shipType of 289 | Corvette -> "Corvette" 290 | Station -> "Station" 291 | Monitor -> "Monitor" 292 | 293 | ownerColor :: Owner -> Color 294 | ownerColor = \case 295 | PlayerOwner player -> playerColor player 296 | Neutral _ -> white 297 | 298 | playerName :: Player -> Text 299 | playerName = \case 300 | Player1 -> "Player 1" 301 | Player2 -> "Player 2" 302 | -------------------------------------------------------------------------------- /src/Game/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Types for the state of the game. 4 | module Game.Model where 5 | 6 | import qualified Data.Text as T 7 | import Game.Prelude 8 | import Text.Read (readMaybe) 9 | 10 | -- | The core game state. 11 | data Model = Model 12 | { modelPlaces :: HashMap PlaceId Place 13 | , modelShips :: HashMap ShipId Ship 14 | , modelLog :: Log 15 | -- ^ Records what combat occured this turn. Cleared at the start of each turn. 16 | , modelTurn :: Natural 17 | , modelNextId :: Natural 18 | -- ^ The supply for place and ship ids, which must be unique. 19 | , modelRandom :: Gen 20 | } deriving stock (Generic) 21 | deriving anyclass (ToJSON) 22 | 23 | -- | The starting @Model@. Creates an empty @modelPlaces@ and @modelShips@. 24 | -- These will be filled out by the a chosen scenario at the start of the game. 25 | init :: Gen -> Model 26 | init gen = 27 | Model 28 | { modelPlaces = mempty 29 | , modelShips = mempty 30 | , modelLog = mempty 31 | , modelTurn = 1 32 | , modelNextId = 1 33 | , modelRandom = gen 34 | } 35 | 36 | -------------------------------------------------------------------------------- 37 | -- * Places 38 | -------------------------------------------------------------------------------- 39 | 40 | -- | Places are either bases or ruins. 41 | -- These are the only locations ships can move to. 42 | data Place = Place 43 | { placeName :: Text 44 | , placePoint :: Point 45 | , placeSize :: PlaceSize 46 | , placeType :: PlaceType 47 | } deriving stock (Eq, Ord, Show, Generic) 48 | deriving anyclass (ToJSON) 49 | 50 | -- | Invariant: unique per game. 51 | newtype PlaceId 52 | = PlaceId Natural 53 | deriving stock (Eq, Ord, Show, Generic) 54 | deriving newtype (Hashable, ToJSON, ToJSONKey, FromJSON, FromJSONKey) 55 | 56 | -- | Affects how large a base at this place can grow. 57 | -- 58 | -- Fixed for the duration of the game. 59 | data PlaceSize 60 | = Small 61 | | Medium 62 | | Large 63 | deriving stock (Eq, Ord, Show, Generic) 64 | deriving anyclass (ToJSON) 65 | 66 | -- | Each place is either a base or a ruin. 67 | data PlaceType 68 | = PBase Base 69 | | Ruin 70 | deriving stock (Eq, Ord, Show, Generic) 71 | deriving anyclass (ToJSON) 72 | 73 | -- | __Player guide starts here__. 74 | -- 75 | -- Bases are either owned by you, neutral, or owned by your opponent. 76 | -- 77 | -- Each player starts with at least one base and wins by destroying all the 78 | -- opponent's bases. 79 | -- 80 | -- Friendly bases can build population, installations, and ships. 81 | -- The higher the population, the faster it builds things. 82 | -- 83 | -- Ships are used for diplomacy, combat, and fighting disease. 84 | -- 85 | -- __Next__: 'Update.update' 86 | data Base = Base 87 | { baseOwner :: Owner 88 | , basePopulation :: Population 89 | , baseDisease :: Disease 90 | , baseInstallations :: Set Installation 91 | , baseShields :: Natural 92 | , baseBuilding :: BuildOrder 93 | , baseInProgress :: HashMap BuildOrder Double 94 | -- ^ Tracks progress for each build order. Production only goes towards 95 | -- the build order in @baseBuilding@, but since you can switch what that 96 | -- is this also tracks partially completed build orders. 97 | -- 98 | -- Note that switching build orders wastes a turn of production 99 | -- while the economy re-tools. 100 | -- 101 | -- See "Game.Update.Build" for details. 102 | } deriving stock (Eq, Ord, Show, Generic) 103 | deriving anyclass (ToJSON) 104 | 105 | -- | Bases are either owned by a player or neutral. 106 | data Owner 107 | = PlayerOwner Player 108 | | Neutral (HashMap Player Natural) 109 | -- ^ The HashMap is the friendliness of the neutral base towards the players. 110 | -- It starts at 0 for each player. 111 | -- 112 | -- When a player is the only one with ships at a neutral base, it ticks 113 | -- up by one for them. When it reaches 5 the base switches allegiance to them. 114 | -- 115 | -- See "Game.Update.Diplomacy" for details. 116 | deriving stock (Eq, Ord, Show, Generic) 117 | deriving anyclass (ToJSON) 118 | 119 | -- | Population can only grow to a Megacity or Ecumenopolis when the host 120 | -- Place has a large enough 'PlaceSize'. So we don't derive 'Enum' or 121 | -- 'Bounded' for it because the behavior of 'maxBound' and 'nextBounded' will be 122 | -- incorrect. 123 | -- 124 | -- Instead we define @minPop@, @prevPop@ and @incrementPop@ 125 | -- in "Game.Update.Shared". 126 | data Population 127 | = Outpost 128 | | Settlement 129 | | City 130 | | Megacity 131 | | Ecumenopolis 132 | deriving stock (Eq, Ord, Show, Generic) 133 | deriving anyclass (ToJSON) 134 | 135 | -- | See "Game.Update.Disease" for details. 136 | data Disease 137 | = Healthy 138 | | Latent 139 | | Plague 140 | deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) 141 | deriving anyclass (ToJSON) 142 | 143 | -- | __Player guide previous__: 'ShipType' 144 | -- 145 | -- Base installations give special abilities, see below for details. 146 | -- 147 | -- __This concludes the player guide__. 148 | data Installation 149 | = Shield 150 | -- ^ Bases with a shield have their 'baseShields' set to five instead of 151 | -- zero. 152 | -- 153 | -- If a base with @baseShields@ is bombarded, its @baseShields@ 154 | -- is reduced instead of its 'basePopulation'. 155 | -- 156 | -- If a 'Shield' is present, 'baseShields' recharges by one every turn 157 | -- the base isn't bombarded (to a max of five). 158 | | Booster 159 | -- ^ Friendly ships leaving a base with a booster travel at x2 speed 160 | -- until they reach their destination. 161 | deriving stock (Eq, Ord, Show, Generic) 162 | deriving anyclass (ToJSON) 163 | 164 | data BuildOrder 165 | = BuildPopulation 166 | | BuildShip ShipType 167 | | BuildShield 168 | | BuildBooster 169 | deriving stock (Eq, Ord, Show, Generic) 170 | deriving anyclass (Hashable, ToJSON, ToJSONKey, FromJSON) 171 | 172 | -------------------------------------------------------------------------------- 173 | -- * Ships 174 | -------------------------------------------------------------------------------- 175 | 176 | data Ship = Ship 177 | { shipPlayer :: Player 178 | , shipLocation :: ShipLocation 179 | , shipType :: ShipType 180 | , shipShields :: Bool 181 | } deriving stock (Eq, Ord, Show, Generic) 182 | deriving anyclass (ToJSON) 183 | 184 | -- | Invariant: unique per game. 185 | newtype ShipId 186 | = ShipId Natural 187 | deriving stock (Eq, Ord, Show, Generic) 188 | deriving newtype (Hashable, ToJSON, ToJSONKey, FromJSON, FromJSONKey) 189 | 190 | data ShipLocation 191 | = AtPlace PlaceId 192 | | InFlight Point PlaceId IsBoosted 193 | -- ^ Currently at Point, flying to PlaceId 194 | | Destroyed 195 | deriving stock (Eq, Ord, Show, Generic) 196 | deriving anyclass (ToJSON, ToJSONKey) 197 | 198 | data IsBoosted 199 | = Boosted 200 | | NotBoosted 201 | deriving stock (Eq, Ord, Show, Generic) 202 | deriving anyclass (ToJSON, ToJSONKey) 203 | 204 | -- | __Player guide previous__: 'Game.Update.Disease.diseaseSpread' 205 | -- 206 | -- There are multiple kinds of ships, see below for details. 207 | -- 208 | -- __Next__: 'Installation' 209 | data ShipType 210 | = Corvette 211 | -- ^ Standard ship. 212 | -- 213 | -- * __Move__: 3 214 | -- * __Attack__: 1 215 | -- * __Cost__: 5 216 | | Station 217 | -- ^ Defensive ship, so slow it's almost an installation. 218 | -- 219 | -- * __Move__: 1 220 | -- * __Attack__: 1 221 | -- * __Cost__: 8 222 | -- 223 | -- The first station on each side in a battle has +2 attack, 224 | -- the second has +1. 225 | -- 226 | -- The first two stations at a friendly base give +0.1 production. 227 | | Monitor 228 | -- ^ A bombardment focused ship. 229 | -- 230 | -- * __Move__: 3 231 | -- * __Attack__: 3 232 | -- * __Cost__: 15 233 | -- 234 | -- If bombarding and a 'Shield' installation is present, it's destroyed. 235 | -- If bombarding and a 'Shield' isn't present, the base is destroyed. 236 | deriving stock (Eq, Ord, Show, Generic) 237 | -- Order matters for the derived Ord instance since we use it to 238 | -- show more important ships in the UI first 239 | deriving anyclass (Hashable, ToJSON, FromJSON) 240 | 241 | -------------------------------------------------------------------------------- 242 | -- * Other 243 | -------------------------------------------------------------------------------- 244 | 245 | data Player 246 | = Player1 247 | | Player2 248 | deriving stock (Eq, Ord, Show, Enum, Bounded, Generic) 249 | deriving anyclass (Hashable, ToJSON, ToJSONKey, FromJSON) 250 | 251 | data Log = Log 252 | { logCombat :: HashMap PlaceId (Set ShipId) 253 | } deriving stock (Eq, Ord, Show, Generic) 254 | deriving anyclass (ToJSON) 255 | 256 | instance Semigroup Log where 257 | Log a1 <> Log a2 = Log (a1 <> a2) 258 | 259 | instance Monoid Log where 260 | mempty = Log mempty 261 | 262 | newtype Gen 263 | = Gen { unGen :: StdGen } 264 | deriving (Show) 265 | 266 | instance Eq Gen where 267 | -- | Needed for testing invertability through JSON. 268 | Gen a == Gen b = show a == show b 269 | 270 | instance ToJSON Gen where 271 | toJSON (Gen stdGen) = 272 | String (T.pack (show stdGen)) 273 | 274 | instance FromJSON Gen where 275 | parseJSON = withText "Gen" $ \t -> 276 | case readMaybe (T.unpack t) of 277 | Nothing -> fail ("Couldn't parse Gen: " <> T.unpack t) 278 | Just stdGen -> pure (Gen stdGen) 279 | 280 | data Orders = Orders 281 | { ordersBuild :: HashMap PlaceId BuildOrder 282 | , ordersEmbark :: HashMap ShipId PlaceId 283 | } deriving stock (Eq, Show, Ord, Generic) 284 | deriving anyclass (ToJSON, FromJSON) 285 | 286 | instance Semigroup Orders where 287 | Orders a1 b1 <> Orders a2 b2 = Orders (a1 <> a2) (b1 <> b2) 288 | 289 | instance Monoid Orders where 290 | mempty = Orders mempty mempty 291 | 292 | -- * Lenses 293 | mkLenses ''Base 294 | mkLenses ''Log 295 | mkLenses ''Model 296 | mkLenses ''Place 297 | mkLenses ''Ship 298 | mkLenses ''Orders 299 | 300 | makePrisms ''Owner 301 | makePrisms ''PlaceType 302 | -------------------------------------------------------------------------------- /src/Update.hs: -------------------------------------------------------------------------------- 1 | module Update where 2 | 3 | import Control.Monad.Trans.State 4 | import qualified Data.HashMap.Strict as HM 5 | import qualified Data.Set as Set 6 | import Game hiding (Model) 7 | import Game.Prelude 8 | import Graphics.Gloss.Interface.IO.Game 9 | (Event(..), Key(..), KeyState(..), MouseButton(..), SpecialKey(..)) 10 | import Layout 11 | import Model 12 | 13 | data Input 14 | = UserEvent Event 15 | | OpponentOrders Player Orders 16 | | TimePassed Float 17 | 18 | -- | __Player guide previous__: 'Base' 19 | -- 20 | -- Use left click to select, right click to move. In detail, to: 21 | -- 22 | -- === Select a base 23 | -- 24 | -- 1. Left click it. 25 | -- 26 | -- === Change what a friendly base is building 27 | -- 28 | -- 1. Select it. 29 | -- 2. Click one of the production options on the right (e.g. @Corvette@). 30 | -- 31 | -- === Move a single ship 32 | -- 33 | -- 1. Select the base where it is. 34 | -- 2. Select the ship by left clicking it from the list on the right. 35 | -- 3. Right click the destination base. 36 | -- 37 | -- === Move all the friendly ships at a base 38 | -- 39 | -- 1. Select the base. 40 | -- 2. Right click the destination base. 41 | -- (Note that this doesn't move @Station@s. They're so slow you'll usually 42 | -- want to leave them behind). 43 | -- 44 | -- This ends the essential section of the player guide. If you want to learn 45 | -- the rest by experimentation you can start playing now. If not read on. 46 | -- 47 | -- __Next__: 'Game.Update.Diplomacy.diplomacy' 48 | update :: Input -> Model -> Model 49 | update i m = 50 | case i of 51 | UserEvent event -> 52 | execState (userInput event) m 53 | 54 | TimePassed _ -> 55 | tickOrTock m 56 | 57 | OpponentOrders p o -> 58 | execState checkForNewTurn (m & modelOpponentOrdersL %~ HM.insert p o) 59 | 60 | -------------------------------------------------------------------------------- 61 | -- * Time passed 62 | -------------------------------------------------------------------------------- 63 | 64 | tickOrTock :: Model -> Model 65 | tickOrTock = 66 | modelTickL %~ next 67 | where 68 | next :: Tick -> Tick 69 | next = \case 70 | Tick -> Tock 71 | Tock -> Tick 72 | 73 | -------------------------------------------------------------------------------- 74 | -- * checkForNewTurn 75 | -- 76 | -- Called after we receive opponent orders or end our own turn. 77 | -------------------------------------------------------------------------------- 78 | 79 | checkForNewTurn :: State Model () 80 | checkForNewTurn = do 81 | b <- isTurnOver 82 | when b updateTurnEnd 83 | where 84 | isTurnOver :: State Model Bool 85 | isTurnOver = do 86 | playerTurnEnded <- use modelTurnEndedL 87 | opOrders <- use modelOpponentOrdersL 88 | pure $ playerTurnEnded && HM.size opOrders > 0 89 | 90 | updateTurnEnd :: State Model () 91 | updateTurnEnd = do 92 | currentPlayer <- use modelWhoAmIL 93 | allOrders <- do 94 | playerOrders <- use modelOrdersL 95 | opponentOrders <- use modelOpponentOrdersL 96 | pure $ opponentOrders <> HM.singleton currentPlayer playerOrders 97 | 98 | modelGameL %= Game.update allOrders 99 | 100 | lastTurnLog <- use (modelGameL . modelLogL) 101 | modelPopupL .= map (uncurry CombatLog) (hmToList (logCombat lastTurnLog)) 102 | 103 | modelOrdersL .= mempty 104 | modelOpponentOrdersL .= mempty 105 | resetPaginations 106 | perhapsClearSelection 107 | modelTurnEndedL .= False 108 | 109 | resetPaginations :: State Model () 110 | resetPaginations = 111 | modelPlaceScrollL .= mempty 112 | 113 | perhapsClearSelection :: State Model () 114 | perhapsClearSelection = do 115 | currentPlayer <- use modelWhoAmIL 116 | ships <- use (modelGameL . modelShipsL) 117 | selected <- use modelSelectionL 118 | case selected of 119 | SelectionNone -> 120 | pure () 121 | 122 | SelectionPlace _ -> 123 | pure () 124 | 125 | SelectionShip shipId -> do 126 | let ship = getShip shipId ships 127 | case shipLocation ship of 128 | Destroyed -> 129 | modelSelectionL .= SelectionNone 130 | 131 | InFlight{} -> 132 | when (shipPlayer ship /= currentPlayer) $ 133 | modelSelectionL .= SelectionNone 134 | 135 | AtPlace _ -> 136 | pure () 137 | 138 | -------------------------------------------------------------------------------- 139 | -- * Result check 140 | -------------------------------------------------------------------------------- 141 | 142 | data UpdateResult 143 | = Normal 144 | | PlayerEndedTurn Orders 145 | | Exit 146 | 147 | updateResult :: Model -> Model -> UpdateResult 148 | updateResult oldModel m 149 | | modelExit m = Exit 150 | | playerEndedTurn = PlayerEndedTurn (modelOrders oldModel) 151 | | otherwise = Normal 152 | where 153 | playerEndedTurn :: Bool 154 | playerEndedTurn = 155 | (not (modelTurnEnded oldModel) && modelTurnEnded m) 156 | || turnRolledForward 157 | 158 | turnRolledForward :: Bool 159 | turnRolledForward = 160 | let f = modelTurn . modelGame 161 | in f oldModel /= f m 162 | 163 | -------------------------------------------------------------------------------- 164 | -- * User input 165 | -------------------------------------------------------------------------------- 166 | 167 | userInput :: Event -> State Model () 168 | userInput event = 169 | case event of 170 | EventKey (SpecialKey KeyEsc) Down _ _ -> 171 | modelExitL .= True 172 | 173 | _ -> do 174 | model <- get 175 | case modelPopup model of 176 | [] -> 177 | updateNormal event 178 | 179 | popup:rest -> 180 | updatePopup event popup rest 181 | 182 | updatePopup :: Event -> CombatLog -> [CombatLog] -> State Model () 183 | updatePopup event _ rest = do 184 | case event of 185 | EventKey (SpecialKey KeyEnter) Down _ _ -> 186 | modelPopupL .= rest 187 | 188 | _ -> 189 | pure () 190 | 191 | updateNormal :: Event -> State Model () 192 | updateNormal event = do 193 | model <- get 194 | let currentPlayer = modelWhoAmI model 195 | places = modelPlaces (modelGame model) 196 | ships = modelShips (modelGame model) 197 | 198 | whenCanMove :: State Model () -> State Model () 199 | whenCanMove move = 200 | case outcome (modelGame model) of 201 | Victor _ -> 202 | pure () 203 | 204 | AllDefeated -> 205 | pure () 206 | 207 | Ongoing -> 208 | when (not (modelTurnEnded model)) move 209 | 210 | case event of 211 | EventMotion (x,y) -> do 212 | let 213 | screenPoint :: ScreenPoint 214 | screenPoint = 215 | ScreenPoint x y 216 | 217 | modelCursorDotL .= screenPoint 218 | 219 | dragToPan <- use modelDragToPanL 220 | case dragToPan of 221 | NotDragging -> 222 | pure () 223 | 224 | PossibleDragStart initial@(ScreenPoint initialX initialY) -> do 225 | if distance (x,y) (initialX,initialY) < 10 226 | then 227 | pure () 228 | 229 | else do 230 | modelDragToPanL .= Dragging initial 231 | 232 | Dragging old -> do 233 | BoardPoint oldX oldY <- runScreenToBoardPoint old 234 | BoardPoint newX newY <- runScreenToBoardPoint screenPoint 235 | let f :: BoardPoint -> BoardPoint 236 | f (BoardPoint panX panY) = 237 | BoardPoint (panX + (oldX - newX)) (panY + (oldY - newY)) 238 | modelPanL %= f 239 | modelDragToPanL .= Dragging screenPoint 240 | 241 | EventResize (width, height) -> 242 | modelScreenSizeL .= Box (realToFrac width) (realToFrac height) 243 | 244 | -- The meaning of latestMouseX, latestMouseY needs to be documented in gloss. 245 | EventKey key upOrDown _ (latestMouseX, latestMouseY) -> do 246 | let 247 | screenPoint :: ScreenPoint 248 | screenPoint = 249 | ScreenPoint latestMouseX latestMouseY 250 | 251 | case upOrDown of 252 | Up -> 253 | case key of 254 | MouseButton LeftButton -> do 255 | dragToPan <- use modelDragToPanL 256 | case dragToPan of 257 | -- We didn't move very much while we had the mouse down 258 | -- so we weren't dragging at all! Instead we were 259 | -- left clicking to clear the selection. 260 | PossibleDragStart _ -> 261 | modelSelectionL .= SelectionNone 262 | 263 | NotDragging -> 264 | pure () 265 | 266 | Dragging _ -> 267 | pure () 268 | 269 | modelDragToPanL .= NotDragging 270 | 271 | _ -> 272 | pure () 273 | 274 | Down -> 275 | case key of 276 | Char 'c' -> 277 | modelPanL .= BoardPoint 0 0 278 | 279 | Char '=' -> do 280 | currentZoom <- use modelZoomL 281 | when (currentZoom /= maxZoom) (panTowardsCursor screenPoint) 282 | 283 | modelZoomL %= zoomIn 284 | 285 | Char '-' -> 286 | modelZoomL %= zoomOut 287 | 288 | Char _ -> 289 | pure () 290 | 291 | SpecialKey KeySpace -> 292 | whenCanMove $ do 293 | modelTurnEndedL .= True 294 | checkForNewTurn 295 | 296 | SpecialKey _ -> 297 | pure () 298 | 299 | MouseButton WheelUp -> do 300 | currentZoom <- use modelZoomL 301 | when (currentZoom /= maxZoom) (panTowardsCursor screenPoint) 302 | 303 | modelZoomL %= zoomIn 304 | 305 | MouseButton WheelDown -> 306 | modelZoomL %= zoomOut 307 | 308 | MouseButton button -> do 309 | case interpretMouseMsg model screenPoint button of 310 | BaseSelect placeId -> 311 | modelSelectionL .= SelectionPlace placeId 312 | 313 | SwitchBuilding placeId buildOrder -> 314 | whenCanMove $ do 315 | let place = getPlace placeId places 316 | case placeType place of 317 | Ruin -> 318 | pure () 319 | 320 | PBase base -> 321 | when (baseOwner base == PlayerOwner currentPlayer) $ do 322 | if baseBuilding base == buildOrder 323 | then 324 | modelOrdersL . ordersBuildL %= HM.delete placeId 325 | else 326 | modelOrdersL . ordersBuildL %= HM.insert placeId buildOrder 327 | 328 | ShipSelect shipId -> 329 | modelSelectionL .= SelectionShip shipId 330 | 331 | ShipsEmbark shipIds _ destId -> 332 | whenCanMove $ 333 | for_ shipIds $ \shipId -> do 334 | let ship = getShip shipId ships 335 | when (shipPlayer ship == currentPlayer) $ 336 | modelOrdersL . ordersEmbarkL %= HM.insert shipId destId 337 | 338 | PreviousPage placeId -> 339 | modelPlaceScrollL %= HM.adjust (subtract 1) placeId 340 | 341 | NextPage placeId -> 342 | modelPlaceScrollL %= HM.insertWith (+) placeId 1 343 | 344 | EmptySpace -> 345 | modelDragToPanL .= PossibleDragStart screenPoint 346 | 347 | NoOp -> 348 | pure () 349 | 350 | -- | Do this softly so zooming in doesn't fling us away from the map. 351 | -- 352 | -- This calculation isn't needed by View so no need to move it into Msg. 353 | panTowardsCursor :: ScreenPoint -> State Model () 354 | panTowardsCursor screenPoint = do 355 | uiPoint <- runScreenToUIPoint screenPoint 356 | case uiPoint of 357 | Left _ -> pure () 358 | Right selectedPoint -> 359 | modelPanL %= panTowards selectedPoint 360 | where 361 | panTowards :: BoardPoint -> BoardPoint -> BoardPoint 362 | panTowards selectedPoint panPoint@(BoardPoint px py) = 363 | let 364 | sel = fromBoardPoint selectedPoint 365 | pan = fromBoardPoint panPoint 366 | d = distance sel pan 367 | speed = d / 3 368 | (x,y) = deltas (angleBetweenPoints pan sel) speed 369 | in BoardPoint (px + x) (py + y) 370 | 371 | runScreenToUIPoint :: ScreenPoint -> State Model (Either HudPoint BoardPoint) 372 | runScreenToUIPoint screenPoint = do 373 | screenSize <- use modelScreenSizeL 374 | pan <- use modelPanL 375 | zoom <- use modelZoomL 376 | pure (screenToUIPoint screenSize zoom pan screenPoint) 377 | 378 | runScreenToBoardPoint :: ScreenPoint -> State Model BoardPoint 379 | runScreenToBoardPoint screenPoint = do 380 | pan <- use modelPanL 381 | zoom <- use modelZoomL 382 | pure (screenToBoardPoint zoom pan screenPoint) 383 | 384 | data Msg 385 | = BaseSelect PlaceId 386 | | SwitchBuilding PlaceId BuildOrder 387 | | ShipSelect ShipId 388 | | ShipsEmbark (Set ShipId) PlaceId PlaceId -- ^ ships, departure, destination 389 | | PreviousPage PlaceId 390 | | NextPage PlaceId 391 | | EmptySpace 392 | | NoOp 393 | 394 | interpretMouseMsg :: Model -> ScreenPoint -> MouseButton -> Msg 395 | interpretMouseMsg m@Model{..} screenPoint button = do 396 | case button of 397 | LeftButton -> 398 | handleLeftButton 399 | 400 | RightButton -> 401 | fromMaybe NoOp handleRightButton 402 | 403 | _ -> 404 | NoOp 405 | 406 | where 407 | mChosenItem :: Maybe Item 408 | mChosenItem = 409 | uiLayoutLookup m screenPoint 410 | 411 | handleLeftButton :: Msg 412 | handleLeftButton = 413 | case mChosenItem of 414 | Nothing -> 415 | EmptySpace 416 | 417 | Just chosenItem -> 418 | case chosenItem of 419 | HudItem item _ -> 420 | case item of 421 | ItemHudShip id _ -> 422 | ShipSelect id 423 | 424 | ItemBuildButton placeId buildOrder clickable _ -> 425 | case clickable of 426 | NotClickable -> 427 | NoOp 428 | 429 | Clickable -> 430 | SwitchBuilding placeId buildOrder 431 | 432 | ItemPreviousPage placeId _ -> 433 | PreviousPage placeId 434 | 435 | ItemNextPage placeId _ -> 436 | NextPage placeId 437 | 438 | HudItself mPlaceId _ _ -> 439 | maybe NoOp BaseSelect mPlaceId 440 | 441 | BoardItem item _ -> 442 | case item of 443 | ItemBase id _ -> 444 | BaseSelect id 445 | 446 | ItemShip id _ -> 447 | ShipSelect id 448 | 449 | handleRightButton :: Maybe Msg 450 | handleRightButton = do 451 | chosenItem <- mChosenItem 452 | case chosenItem of 453 | BoardItem (ItemBase chosenId _) _ -> do 454 | case modelSelection of 455 | SelectionNone -> 456 | Nothing 457 | 458 | SelectionPlace placeId -> 459 | let ships = shipsAtPlace placeId (modelShips modelGame) 460 | shipsLessStations = HM.filter (\s -> shipType s /= Station) ships 461 | ids = Set.fromList (HM.keys shipsLessStations) 462 | in Just (ShipsEmbark ids placeId chosenId) 463 | 464 | SelectionShip shipId -> 465 | let ship = getShip shipId (modelShips modelGame) 466 | in case shipLocation ship of 467 | InFlight{} -> 468 | Nothing 469 | 470 | Destroyed -> 471 | Nothing 472 | 473 | AtPlace departureId -> 474 | Just (ShipsEmbark (Set.singleton shipId) departureId chosenId) 475 | 476 | _ -> 477 | Nothing 478 | -------------------------------------------------------------------------------- /src/Layout.hs: -------------------------------------------------------------------------------- 1 | module Layout 2 | ( Layout(..) 3 | , uiLayout 4 | , uiLayoutLookup 5 | , Item(..) 6 | , HudItem(..) 7 | , Clickable(..) 8 | , BoardItem(..) 9 | 10 | , sortShipsForUI 11 | , hasDetection 12 | , isFocusedBase 13 | , focusedBase 14 | 15 | , screenToUIPoint 16 | , screenToBoardPoint 17 | , sizeToRadius 18 | , zoomFactor 19 | ) where 20 | 21 | import qualified Data.HashMap.Strict as HM 22 | import qualified Data.List as List 23 | import Data.List.Split (chunksOf) 24 | import qualified Data.Set as Set 25 | import Game hiding (Model) 26 | import Game.Prelude 27 | import Model 28 | 29 | -- | Eg: 30 | -- 31 | -- @ 32 | -- [ { hudButton1, hudButton2 } 33 | -- , { hudBox } 34 | -- , { ship1, ship2, ship3 } 35 | -- , { place1, place2 } 36 | -- ] 37 | -- @ 38 | newtype Layout item 39 | = Layout { unLayout :: [Set item] } 40 | deriving newtype (Semigroup, Monoid) 41 | 42 | layoutLookup :: forall item. (item -> Bool) -> Layout item -> Maybe item 43 | layoutLookup isItemUnderPoint = 44 | foldl' lkup Nothing . unLayout 45 | where 46 | lkup :: Maybe item -> Set item -> Maybe item 47 | lkup mAcc layerItems = 48 | case mAcc of 49 | Just item -> 50 | Just item 51 | 52 | Nothing -> 53 | listToMaybe (Set.toAscList (Set.filter isItemUnderPoint layerItems)) 54 | 55 | uiLayoutLookup :: Model -> ScreenPoint -> Maybe Item 56 | uiLayoutLookup m@Model{..} clickPoint = 57 | layoutLookup isItemUnderPoint (uiLayout m) 58 | where 59 | isItemUnderPoint :: Item -> Bool 60 | isItemUnderPoint item = 61 | case item of 62 | HudItem hudItem itemScreenPoint -> 63 | let dimensions = case hudItem of 64 | ItemHudShip _ box -> box 65 | ItemBuildButton _ _ _ box -> box 66 | ItemPreviousPage _ box -> box 67 | ItemNextPage _ box -> box 68 | in withinScreenBox itemScreenPoint dimensions 69 | 70 | HudItself _ itemScreenPoint dimensions -> 71 | withinScreenBox itemScreenPoint dimensions 72 | 73 | BoardItem boardItem itemBoardPoint -> 74 | let radius = case boardItem of 75 | ItemBase _ (Radius r) -> r 76 | ItemShip _ (Radius r) -> r 77 | 78 | clickPointOnBoard :: Point 79 | clickPointOnBoard = 80 | fromBoardPoint $ screenToBoardPoint modelZoom modelPan clickPoint 81 | 82 | in distance clickPointOnBoard itemBoardPoint <= radius 83 | 84 | withinScreenBox :: ScreenPoint -> Box -> Bool 85 | withinScreenBox (ScreenPoint a b) box = 86 | let ScreenPoint x y = clickPoint 87 | rectangle = Rectangle (a,b) (boxWidth box) (boxHeight box) 88 | in case rectangleCoordinates (x,y) rectangle of 89 | Just _ -> True 90 | Nothing -> False 91 | 92 | data Item 93 | = HudItem HudItem ScreenPoint 94 | | HudItself (Maybe PlaceId) ScreenPoint Box 95 | -- ^ Just is a focused base, Nothing if we're in flight. 96 | | BoardItem BoardItem Point 97 | deriving (Eq, Ord, Show) 98 | 99 | data HudItem 100 | = ItemHudShip ShipId Box 101 | | ItemBuildButton PlaceId BuildOrder Clickable Box 102 | | ItemPreviousPage PlaceId Box 103 | | ItemNextPage PlaceId Box 104 | deriving (Eq, Ord, Show) 105 | 106 | data Clickable 107 | = Clickable 108 | | NotClickable 109 | deriving (Eq, Ord, Show) 110 | 111 | data BoardItem 112 | = ItemBase PlaceId Radius 113 | | ItemShip ShipId Radius 114 | deriving (Eq, Ord, Show) 115 | 116 | uiLayout :: Model -> Layout Item 117 | uiLayout m@Model{..} = 118 | Layout 119 | [ Set.map (\(hp,i) -> HudItem i (f hp)) (hudLayer m hudDimensions) 120 | , case modelSelection of 121 | SelectionNone -> 122 | mempty 123 | 124 | _ -> 125 | let mPlaceId :: Maybe PlaceId 126 | mPlaceId = 127 | focusedBase m -- Nothing is in flight 128 | in Set.singleton (HudItself mPlaceId (ScreenPoint huX huY) (Box hudWidth hudHeight)) 129 | 130 | , Set.map (\(p,i) -> BoardItem i p) (flightLayer m) 131 | , Set.map (\(p,i) -> BoardItem i p) (baseLayer m) 132 | ] 133 | where 134 | f :: HudPoint -> ScreenPoint 135 | f (HudPoint x y) = 136 | ScreenPoint (x + huX) (y + huY) 137 | 138 | hudDimensions = Box hudWidth hudHeight 139 | 140 | Rectangle (huX, huY) hudWidth hudHeight = hudPlacement modelScreenSize 141 | 142 | -- | First build button row. 143 | firstButtonRowHeight :: Box -> Float 144 | firstButtonRowHeight hudDimensions = 145 | boxHeight hudDimensions / 2 - 400 146 | 147 | -- | Second build button row. 148 | secondButtonRowHeight :: Box -> Float 149 | secondButtonRowHeight hudDimensions = 150 | firstButtonRowHeight hudDimensions 151 | - buildButtonHeight -- one full button down 152 | - 15 -- margin between buttons 153 | 154 | hudLayer :: Model -> Box -> Set (HudPoint, HudItem) 155 | hudLayer m@Model{..} hudDimensions = 156 | case modelSelection of 157 | SelectionNone -> 158 | mempty 159 | 160 | SelectionPlace placeId -> 161 | hudButtonsAndShips (Just placeId) (placeShips placeId) 162 | 163 | SelectionShip shipId -> 164 | let ship = getShip shipId (modelShips modelGame) 165 | in case shipLocation ship of 166 | InFlight point _ _ -> 167 | let nearbyShips = 168 | modelShips modelGame 169 | & HM.filter (\s -> 170 | case shipLocation s of 171 | InFlight p _ _ -> 172 | distance p point < flightGroupRadius 173 | && shipPlayer s == shipPlayer ship 174 | 175 | AtPlace _ -> False 176 | 177 | Destroyed -> False) 178 | in hudButtonsAndShips Nothing nearbyShips 179 | 180 | Destroyed -> 181 | error "don't allow destroyed ships to be selected" 182 | 183 | AtPlace placeId -> do 184 | hudButtonsAndShips (Just placeId) (placeShips placeId) 185 | where 186 | -- If a ship in flight is selected, the HUD also shows other ships 187 | -- which are overlapping it or very close by. 188 | flightGroupRadius :: Float 189 | flightGroupRadius = 190 | 20 191 | 192 | placeShips :: PlaceId -> HashMap ShipId Ship 193 | placeShips placeId = 194 | shipsAtPlace placeId (modelShips modelGame) 195 | 196 | hudButtonsAndShips :: Maybe PlaceId -> HashMap ShipId Ship -> Set (HudPoint, HudItem) 197 | hudButtonsAndShips mPlaceId ships = 198 | maybe mempty hudBuildButtons mPlaceId <> hudShips m hudDimensions mPlaceId ships 199 | 200 | hudBuildButtons :: PlaceId -> Set (HudPoint, HudItem) 201 | hudBuildButtons placeId = 202 | case placeType place of 203 | Ruin -> 204 | mempty 205 | 206 | PBase base -> 207 | if hasDetection modelWhoAmI (Just place) (placeShips placeId) 208 | then 209 | Set.fromList 210 | [ ( HudPoint (-95) row1Height 211 | , ItemBuildButton placeId (BuildShip Corvette) Clickable button 212 | ) 213 | , ( HudPoint 0 row1Height 214 | , ItemBuildButton placeId (BuildShip Station) Clickable button 215 | ) 216 | , ( HudPoint 95 row1Height 217 | , ItemBuildButton placeId (BuildShip Monitor) Clickable button 218 | ) 219 | , ( HudPoint (-95) row2Height 220 | , ItemBuildButton placeId BuildPopulation popClickable button 221 | ) 222 | , ( HudPoint 0 row2Height 223 | , ItemBuildButton placeId BuildBooster (boosterClickable base) button 224 | ) 225 | , ( HudPoint 95 row2Height 226 | , ItemBuildButton placeId BuildShield (shieldClickable base) button 227 | ) 228 | ] 229 | else 230 | mempty 231 | where 232 | popClickable :: Clickable 233 | popClickable = 234 | if canExpand place 235 | then Clickable 236 | else NotClickable 237 | 238 | shieldClickable :: Base -> Clickable 239 | shieldClickable base = 240 | if Set.member Shield (baseInstallations base) 241 | then NotClickable 242 | else Clickable 243 | 244 | boosterClickable :: Base -> Clickable 245 | boosterClickable base = 246 | if Set.member Booster (baseInstallations base) 247 | then NotClickable 248 | else Clickable 249 | 250 | place = getPlace placeId (modelPlaces modelGame) 251 | 252 | row1Height :: Float 253 | row1Height = 254 | firstButtonRowHeight hudDimensions 255 | 256 | row2Height :: Float 257 | row2Height = 258 | secondButtonRowHeight hudDimensions 259 | 260 | button :: Box 261 | button = 262 | Box 80 buildButtonHeight 263 | 264 | hudShips :: Model -> Box -> Maybe PlaceId -> HashMap ShipId Ship -> Set (HudPoint, HudItem) 265 | hudShips Model{..} hudDimensions mPlaceId ships = 266 | if hasDetection modelWhoAmI mPlace ships 267 | then 268 | paginatedShips <> (case mPlaceId of 269 | Nothing -> 270 | mempty 271 | 272 | Just placeId -> 273 | mPrevious placeId <> mNext placeId) 274 | else 275 | mempty 276 | where 277 | mPlace :: Maybe Place 278 | mPlace = 279 | map (\placeId -> getPlace placeId (modelPlaces modelGame)) mPlaceId 280 | 281 | paginatedShips :: Set (HudPoint, HudItem) 282 | paginatedShips = 283 | Set.fromList . map g $ 284 | map (_1 +~ shipStartY) $ 285 | mapWithIndex 286 | (\i ship -> (realToFrac i * negate shipHeight, ship)) 287 | shipsOnThisPage 288 | where 289 | g :: (Float, (ShipId, Ship)) -> (HudPoint, HudItem) 290 | g (height, (id, _)) = 291 | ( HudPoint 0 height 292 | , ItemHudShip id (Box (boxWidth hudDimensions) shipHeight) 293 | ) 294 | 295 | shipStartY :: Float 296 | shipStartY = 297 | secondButtonRowHeight hudDimensions 298 | - buildButtonHeight / 2 -- bottom of second button 299 | - 20 -- arbitrary padding 300 | - shipHeight / 2 301 | 302 | paginationRowY :: Float 303 | paginationRowY = 304 | - (boxHeight hudDimensions / 2) + paginationButtonHeight 305 | 306 | -- How many ships the UI has room to show 307 | maxShips :: Natural 308 | maxShips = 309 | floor $ abs (paginationRowY - shipStartY) / shipHeight 310 | 311 | pagesOfShips :: [[(ShipId, Ship)]] 312 | pagesOfShips = 313 | chunksOf (fromIntegral maxShips) (sortShipsForUI ships) 314 | 315 | shipsOnThisPage :: [(ShipId, Ship)] 316 | shipsOnThisPage = 317 | case pagesOfShips ^? element (fromIntegral page) of 318 | Nothing -> mempty 319 | Just xs -> xs 320 | 321 | page :: Natural 322 | page = 323 | case mPlaceId of 324 | Nothing -> 325 | 0 326 | 327 | Just placeId -> 328 | fromMaybe 0 (HM.lookup placeId modelPlaceScroll) 329 | 330 | mPrevious :: PlaceId -> Set (HudPoint, HudItem) 331 | mPrevious placeId = 332 | if page == 0 333 | then 334 | mempty 335 | 336 | else 337 | Set.singleton 338 | ( HudPoint (-70) paginationRowY 339 | , ItemPreviousPage placeId (Box 80 paginationButtonHeight) 340 | ) 341 | 342 | mNext :: PlaceId -> Set (HudPoint, HudItem) 343 | mNext placeId = 344 | if fromIntegral page < length pagesOfShips - 1 345 | then 346 | Set.singleton 347 | ( HudPoint 70 paginationRowY 348 | , ItemNextPage placeId (Box 80 paginationButtonHeight) 349 | ) 350 | 351 | else 352 | mempty 353 | 354 | sortShipsForUI :: HashMap ShipId Ship -> [(ShipId, Ship)] 355 | sortShipsForUI ships = 356 | let f :: (ShipId, Ship) -> (ShipId, Ship) -> Ordering 357 | f (id1, s1) (id2, s2) = 358 | if shipType s1 == shipType s2 359 | then compare id1 id2 360 | else reverseOrdering $ compare (shipType s1) (shipType s2) 361 | in List.sortBy f (HM.toList ships) 362 | 363 | -- | A player has detection at a place if they have ships 364 | -- present or are the owner of a base there. 365 | hasDetection 366 | :: Player 367 | -> Maybe Place 368 | -- ^ Place is a Maybe since we might be in flight. 369 | -> HashMap ShipId Ship 370 | -- ^ The ships at this place. 371 | -> Bool 372 | hasDetection player mPlace ships = 373 | ownsBase || hasShipsThere 374 | where 375 | ownsBase :: Bool 376 | ownsBase = 377 | case mPlace of 378 | Nothing -> 379 | False 380 | 381 | Just place -> 382 | case placeType place of 383 | Ruin -> 384 | False 385 | 386 | PBase base -> 387 | PlayerOwner player == baseOwner base 388 | 389 | hasShipsThere :: Bool 390 | hasShipsThere = 391 | case HM.keys (HM.filter (\s -> shipPlayer s == player) ships) of 392 | [] -> 393 | False 394 | 395 | _ -> 396 | True 397 | 398 | isFocusedBase :: Model -> PlaceId -> Bool 399 | isFocusedBase m placeId = 400 | Just placeId == focusedBase m 401 | 402 | focusedBase :: Model -> Maybe PlaceId 403 | focusedBase Model{..} = 404 | case modelSelection of 405 | SelectionNone -> 406 | Nothing 407 | 408 | SelectionPlace placeId -> 409 | Just placeId 410 | 411 | SelectionShip shipId -> 412 | let ship = getShip shipId (modelShips modelGame) 413 | in case shipLocation ship of 414 | InFlight{} -> 415 | Nothing 416 | 417 | Destroyed -> 418 | Nothing 419 | 420 | AtPlace placeId -> 421 | Just placeId 422 | 423 | flightLayer :: Model -> Set (Point, BoardItem) 424 | flightLayer Model{..} = 425 | Set.fromList . map f . hmToList $ flyingShips 426 | where 427 | flyingShips :: HashMap ShipId Point 428 | flyingShips = 429 | (\(_, loc, _) -> loc) <$> shipsInFlight (modelShips modelGame) 430 | 431 | f :: (ShipId, Point) -> (Point, BoardItem) 432 | f (id, loc) = 433 | (loc, ItemShip id (Radius shipClickRadius)) 434 | 435 | baseLayer :: Model -> Set (Point, BoardItem) 436 | baseLayer Model{..} = 437 | Set.fromList . map f . hmToList $ places 438 | where 439 | f :: (PlaceId, Place) -> (Point, BoardItem) 440 | f (id, place) = 441 | ( placePoint place 442 | , ItemBase id (sizeToRadius (placeSize place)) 443 | ) 444 | 445 | places :: HashMap PlaceId Place 446 | places = 447 | modelPlaces modelGame 448 | 449 | hudPlacement :: Box -> Rectangle 450 | hudPlacement (Box screenWidth screenHeight) = 451 | Rectangle center hudWidth (screenHeight - margin * 2) 452 | where 453 | center :: Point 454 | center = 455 | ( (screenWidth / 2 - margin) - hudWidth / 2 456 | , 0 457 | ) 458 | 459 | margin :: Float 460 | margin = 461 | 20 462 | 463 | hudWidth :: Float 464 | hudWidth = 465 | 300 466 | 467 | -- | If this function seems to be broken, make sure that the view 468 | -- is displaying things correctly on the screen. 469 | screenToUIPoint :: Box -> Zoom -> BoardPoint -> ScreenPoint -> Either HudPoint BoardPoint 470 | screenToUIPoint screenSize zoom pan screenPoint = 471 | case hudSelection of 472 | Just hudPoint -> 473 | Left hudPoint 474 | 475 | Nothing -> 476 | Right $ screenToBoardPoint zoom pan screenPoint 477 | where 478 | hudSelection :: Maybe HudPoint 479 | hudSelection = 480 | map (uncurry HudPoint) $ 481 | rectangleCoordinates 482 | (fromScreenPoint screenPoint) 483 | (hudPlacement screenSize) 484 | 485 | screenToBoardPoint :: Zoom -> BoardPoint -> ScreenPoint -> BoardPoint 486 | screenToBoardPoint zoom (BoardPoint panX panY) (ScreenPoint screenX screenY) = 487 | BoardPoint (screenX / zf + panX) (screenY / zf + panY) 488 | where 489 | zf :: Float 490 | zf = 491 | zoomFactor zoom 492 | 493 | sizeToRadius :: PlaceSize -> Radius 494 | sizeToRadius size = 495 | Radius $ 496 | case size of 497 | Large -> 65 498 | Medium -> 50 499 | Small -> 35 500 | 501 | zoomFactor :: Zoom -> Float 502 | zoomFactor = \case 503 | NoZoom -> 1 504 | ZoomOut -> 0.7 505 | ZoomOut2 -> 0.5 506 | ZoomOut3 -> 0.3 507 | ZoomOut4 -> 0.2 508 | 509 | -- | We pick an arbitrary distance from the center of a ship and count 510 | -- clicks in that radius as on that ship. 511 | shipClickRadius :: Float 512 | shipClickRadius = 513 | 20 514 | 515 | -- | The height of an entry in the ship hud list. Not all of it will 516 | -- necessarily be filled by the ship. 517 | shipHeight :: Float 518 | shipHeight = 519 | 50 520 | 521 | buildButtonHeight :: Float 522 | buildButtonHeight = 523 | 40 524 | 525 | paginationButtonHeight :: Float 526 | paginationButtonHeight = 527 | 30 528 | --------------------------------------------------------------------------------