├── Setup.hs ├── screenshot.png ├── .gitignore ├── stack.yaml ├── default.nix ├── release.nix ├── shell.nix ├── infinisweep.nix ├── stack.yaml.lock ├── nix ├── sources.json ├── nixpkgs.nix └── sources.nix ├── LICENSE ├── infinisweep.cabal ├── src └── Sweeper │ ├── Grid.hs │ ├── Grid │ └── BalancedTernary.hs │ └── Game.hs ├── .github └── workflows │ └── ci.yml ├── README.md └── app └── Main.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/basile-henry/infinisweep/HEAD/screenshot.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | result 3 | .stack-work/ 4 | .ghc.environment* 5 | result-* 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.10 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - ncurses-0.2.16 6 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | nixpkgs.pkgs.haskellPackages.callPackage ./infinisweep.nix {} 3 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | 3 | with nixpkgs; 4 | { 5 | infinisweep = import ./. {}; 6 | infinisweep-static = 7 | haskell.lib.mkStaticExe 8 | (pkgsMusl.haskellPackages.callPackage ./infinisweep.nix {}); 9 | } 10 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import ./nix/nixpkgs.nix {} }: 2 | 3 | nixpkgs.mkShell { 4 | name = "infinisweep-shell"; 5 | packages = [ 6 | nixpkgs.niv 7 | ]; 8 | inputsFrom = [ 9 | (import ./default.nix { inherit nixpkgs; }) 10 | ]; 11 | } 12 | -------------------------------------------------------------------------------- /infinisweep.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, lib, base, hashable, optparse-applicative, random, strict, vty, gitignoreSource 2 | }: 3 | mkDerivation { 4 | pname = "infinisweep"; 5 | version = "1.0.0"; 6 | src = gitignoreSource ./.; 7 | isLibrary = true; 8 | isExecutable = true; 9 | libraryHaskellDepends = [ base random ]; 10 | executableHaskellDepends = [ 11 | base hashable optparse-applicative random strict vty 12 | ]; 13 | license = lib.licenses.mit; 14 | } 15 | -------------------------------------------------------------------------------- /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 | - completed: 8 | hackage: ncurses-0.2.16@sha256:8ad9fe6562a80d28166d76adbac1eb4d40c6511fe4e9272ed6e1166dc2f1cdf1,3575 9 | pantry-tree: 10 | size: 674 11 | sha256: 093bdc85ed518c81724f5b6b81c24ab4ebdd231551861f4feaa43361136f70b7 12 | original: 13 | hackage: ncurses-0.2.16 14 | snapshots: 15 | - completed: 16 | size: 618509 17 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/10.yaml 18 | sha256: 005f204647467d65c4ab549a5ca35d54b3d90a84a99a4ffc5d421a4018854fe2 19 | original: lts-19.10 20 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "gitignore.nix": { 3 | "branch": "master", 4 | "description": "Nix functions for filtering local git sources", 5 | "homepage": "", 6 | "owner": "hercules-ci", 7 | "repo": "gitignore.nix", 8 | "rev": "bff2832ec341cf30acb3a4d3e2e7f1f7b590116a", 9 | "sha256": "0va0janxvmilm67nbl81gdbpppal4aprxzb25gp9pqvf76ahxsci", 10 | "type": "tarball", 11 | "url": "https://github.com/hercules-ci/gitignore.nix/archive/bff2832ec341cf30acb3a4d3e2e7f1f7b590116a.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "release-22.05", 16 | "description": "Nix Packages collection", 17 | "homepage": "", 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "641328243848f927e4c3a5bdd743a7dd68cce415", 21 | "sha256": "1aviffa55mzx3gk9csm8jg1a20l412zdqnx1hda3c43yih0lx2rk", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/641328243848f927e4c3a5bdd743a7dd68cce415.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Basile Henry & David Eichmann 4 | Copyright (c) 2018 Basile Henry & Nathan van Doorn 5 | Copyright (c) 2021-2022 Basile Henry 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | -------------------------------------------------------------------------------- /infinisweep.cabal: -------------------------------------------------------------------------------- 1 | name: infinisweep 2 | version: 1.0.0 3 | license-file: LICENSE 4 | license: MIT 5 | author: Basile Henry & David Eichmann 6 | maintainer: bjm.henry@gmail.com 7 | copyright: 2016 Basile Henry & David Eichmann 8 | 2018 Basile Henry & Nathan van Doorn 9 | 2021 Basile Henry 10 | 2022 Basile Henry 11 | category: Game 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | library 16 | exposed-modules: Sweeper.Grid 17 | Sweeper.Grid.BalancedTernary 18 | Sweeper.Game 19 | build-depends: base >= 4.9 && < 4.17 20 | , random >= 1.1 && < 1.3 21 | hs-source-dirs: src 22 | default-language: Haskell2010 23 | ghc-options: -Wall 24 | 25 | executable infinisweep 26 | main-is: Main.hs 27 | hs-source-dirs: app 28 | build-depends: base 29 | , directory >= 1.3.1 && < 1.4 30 | , filepath >= 1.4.2 && < 1.5 31 | , infinisweep 32 | , optparse-applicative >= 0.11 && < 0.17 33 | , random 34 | , vty >= 5.21 && < 5.36 35 | default-language: Haskell2010 36 | ghc-options: -Wall -O2 -threaded 37 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { sources ? import ./sources.nix }: 2 | 3 | let compiler = "ghc902"; 4 | 5 | # Inspired by https://github.com/dhall-lang/dhall-haskell/blob/master/nix/shared.nix 6 | haskellStaticOverlay = self: super: { 7 | haskellPackages = self.haskell.packages."${compiler}"; 8 | 9 | fixedCabal = self.pkgsMusl.haskell.packages."${compiler}".Cabal_3_6_3_0; 10 | 11 | haskell = super.haskell // { 12 | lib = super.haskell.lib // { 13 | useFixedCabal = drv: 14 | (self.haskell.lib.overrideCabal drv (old: { 15 | setupHaskellDepends = (old.setupHaskellDepends or []) ++ [ self.fixedCabal ]; 16 | } 17 | )).overrideAttrs (old: { 18 | preCompileBuildDriver = (old.preCompileBuildDriver or "") + '' 19 | cabalPackageId=$(basename --suffix=.conf ${self.fixedCabal}/lib/ghc-*/package.conf.d/*.conf) 20 | setupCompileFlags="$setupCompileFlags -package-id $cabalPackageId" 21 | ''; 22 | } 23 | ); 24 | 25 | mkStaticExe = drv: 26 | self.haskell.lib.appendConfigureFlags 27 | (self.haskell.lib.justStaticExecutables 28 | (self.haskell.lib.useFixedCabal (self.haskell.lib.dontCheck drv)) 29 | ) 30 | [ "--enable-executable-static" 31 | "--extra-lib-dirs=${self.pkgsMusl.ncurses.override { enableStatic = true; }}/lib" 32 | "--extra-lib-dirs=${self.pkgsMusl.gmp6.override { withStatic = true; }}/lib" 33 | "--extra-lib-dirs=${self.pkgsMusl.libffi.overrideAttrs (old: { dontDisableStatic = true; })}/lib" 34 | ]; 35 | }; 36 | }; 37 | }; 38 | 39 | overlay = self: super: { 40 | inherit (import sources."gitignore.nix" { inherit (self) lib; }) gitignoreSource; 41 | }; 42 | in 43 | import sources.nixpkgs { overlays = [haskellStaticOverlay overlay] ; config = {}; } 44 | -------------------------------------------------------------------------------- /src/Sweeper/Grid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Sweeper.Grid (Grid, Position(Cartesian), zeroPosition, movePosition, Panel, getCell, surroundingPositions, inBounds, randomGrid, setCell, modifyCell) where 5 | 6 | -- random 7 | import System.Random (StdGen, split) 8 | 9 | -- infinisweep 10 | import Sweeper.Grid.BalancedTernary 11 | 12 | -- | Infinite 2D grid of cells 13 | newtype Grid a = Grid (Stream (Stream a)) 14 | 15 | -- | Position in the grid 16 | data Position = Position Index Index 17 | deriving (Eq, Ord) 18 | 19 | pattern Cartesian :: Integer -> Integer -> Position 20 | pattern Cartesian x y <- Position (fromIndex -> x) (fromIndex -> y) 21 | where 22 | Cartesian x y = Position (toIndex x) (toIndex y) 23 | {-# COMPLETE Cartesian #-} 24 | 25 | zeroPosition :: Position 26 | zeroPosition = Position mempty mempty 27 | 28 | movePosition :: Integer -> Integer -> Position -> Position 29 | movePosition dx dy (Position x y) = Position (x <> toIndex dx) (y <> toIndex dy) 30 | 31 | -- | The panel is used as limits for recursing down empty cells (it is supposed 32 | -- to be bigger than the terminal) 33 | type Panel = (Position, Position) 34 | 35 | -- Get a cell from the 2D infinite grid 36 | -- TODO: rename? 37 | getCell :: Position -> Grid a -> a 38 | getCell (Position x y) (Grid grid) = index y (index x grid) 39 | 40 | setCell :: Position -> a -> Grid a -> Grid a 41 | setCell (Position x y) a (Grid grid) = Grid $ update x (update y (const a)) grid 42 | 43 | modifyCell :: Position -> (a -> a) -> Grid a -> Grid a 44 | modifyCell (Position x y) f (Grid grid) = Grid $ update x (update y f) grid 45 | 46 | surroundingPositions :: Position -> [Position] 47 | surroundingPositions (Position x y) = [Position i j | i<-[pred x..succ x], j<-[pred y..succ y], x /= i || y /= j] 48 | 49 | inBounds :: Position -> Panel -> Bool 50 | inBounds (Cartesian x y) (Cartesian a b, Cartesian c d) = a <= x && x <= c && b <= y && y <= d 51 | 52 | randomGrid :: (StdGen -> (a, StdGen)) -> StdGen -> Grid a 53 | randomGrid f gen = 54 | Grid $ randomStream (\g -> let (g0, g1) = split g in (randomStream f g0, g1)) gen 55 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | cabal: 12 | runs-on: ubuntu-latest 13 | strategy: 14 | matrix: 15 | cabal: ["3.2"] 16 | ghc: ["8.4.3", "9.0.2"] 17 | steps: 18 | - uses: actions/checkout@v3 19 | - uses: haskell/actions/setup@v2 20 | with: 21 | ghc-version: ${{ matrix.ghc }} 22 | cabal-version: ${{ matrix.cabal }} 23 | - run: cabal v2-update 24 | - run: cabal v2-freeze 25 | - uses: actions/cache@v3 26 | with: 27 | path: | 28 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 29 | dist-newstyle 30 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 31 | restore-keys: | 32 | ${{ runner.os }}-${{ matrix.ghc }}- 33 | - run: sudo apt-get install libncursesw5-dev # install ncurses 34 | - run: cabal v2-build 35 | 36 | stack: 37 | strategy: 38 | matrix: 39 | os: [ubuntu-latest, macos-latest] 40 | runs-on: ${{ matrix.os }} 41 | steps: 42 | - uses: actions/checkout@v3 43 | - uses: haskell/actions/setup@v2 44 | with: 45 | ghc-version: '9.0.2' 46 | enable-stack: true 47 | stack-version: 'latest' 48 | - uses: actions/cache@v3 49 | name: Cache ~/.stack 50 | with: 51 | path: ~/.stack 52 | key: ${{ matrix.os }}-stack 53 | - if: matrix.os == 'ubuntu-latest' 54 | run: sudo apt-get install libncursesw5-dev # install ncurses 55 | - if: matrix.os == 'macos-latest' 56 | run: brew install ncurses 57 | - run: stack build 58 | 59 | nix: 60 | strategy: 61 | matrix: 62 | os: [ubuntu-latest, macos-latest] 63 | runs-on: ${{ matrix.os }} 64 | steps: 65 | - uses: actions/checkout@v3 66 | - uses: cachix/install-nix-action@v17 67 | with: 68 | nix_path: nixpkgs=channel:nixos-22.05 69 | - uses: cachix/cachix-action@v10 70 | with: 71 | name: basile-henry 72 | signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' 73 | - run: nix-build 74 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # InfiniSweep 2 | 3 | ![ci](https://github.com/basile-henry/infinisweep/actions/workflows/ci.yml/badge.svg) 4 | 5 | InfiniSweep is a clone of the famous [Minesweeper](https://en.wikipedia.org/wiki/Minesweeper_%28video_game%29) game written in Haskell. It features an infinite grid which means that a game could (in theory) go on forever. 6 | 7 | This game is played in a terminal using `ncurses` to render it. 8 | 9 | ![InfiniSweep game screenshot](screenshot.png) 10 | 11 | ## Download static binary 12 | 13 | [Download latest release](https://github.com/basile-henry/infinisweep/releases/latest), make executable and then play! 14 | 15 | For example: 16 | ``` 17 | wget https://github.com/basile-henry/infinisweep/releases/download/v1.0.0/infinisweep-x86_64-linux-static 18 | chmod +x infinisweep-x86_64-linux-static 19 | ``` 20 | 21 | ## How to play 22 | 23 | With the following `options`: 24 | 25 | ``` 26 | Usage: infinisweep [-a|--auto-open] [-d|--density PERCENT] 27 | 28 | Available options: 29 | -h,--help Show this help text 30 | -a,--auto-open Open cells automatically (as per flags/markers) 31 | -d,--density PERCENT Density of the minefield, as a percentage 32 | ``` 33 | 34 | When a cell in the grid is opened it either contains a mine and therefore explodes (Game Over) or will show the player the number of mines in the neighbouring cells (there are 8 neighbouring cells). 35 | 36 | - To move around the grid use: 37 | - Arrow keys (←, ↑, ↓, →) 38 | - W, A, S, D 39 | - HJKLYUBN (H - left, J - down, K - up, L - right, Y - up left, U - up right, B - down left, N - down right) 40 | - Number pad (1 - down left, 2 - down, 3 - down right, 4 - left, 6 - right, 7 - up left, 8 - up, 9 - up right, 5 - mark, 0 - open) 41 | - Press space or 0 to open a cell. 42 | - Press M, E, or 5 to mark a cell (if you think it contains a mine). 43 | - Press Q to quit the game. 44 | - Press R to start a new game. 45 | 46 | If an open cell is satisfied (the number of mines the cell indicates matches the number of markers) you can click it (with space) and it will open all the remaining closed cells surrounding it that aren't marked. If you select the `auto` mode this behaviour is completely automated. 47 | 48 | ## How to build from source 49 | 50 | For `cabal` and `stack` the `C` library `libncursesw5-dev` needs to be installed 51 | separately. On Ubuntu: 52 | 53 | ```sh 54 | sudo apt install libncursesw-dev 55 | ``` 56 | 57 | ### Cabal 58 | 59 | ```sh 60 | cabal new-build 61 | ``` 62 | 63 | ### Stack 64 | 65 | ```sh 66 | stack setup 67 | stack build 68 | ``` 69 | 70 | ### Nix 71 | 72 | ```sh 73 | nix build 74 | ``` 75 | 76 | ## How to run the game 77 | 78 | ### Cabal 79 | 80 | ```sh 81 | cabal new-exec -- infinisweep 82 | ``` 83 | 84 | ### Stack 85 | 86 | ```sh 87 | stack exec -- infinisweep 88 | ``` 89 | 90 | ### Nix 91 | 92 | ```sh 93 | result/bin/infinisweep 94 | ``` 95 | 96 | ## License 97 | 98 | This project is licensed under the MIT License. 99 | 100 | ``` 101 | Copyright (c) 2016 Basile Henry & David Eichmann 102 | Copyright (c) 2018 Basile Henry & Nathan van Doorn 103 | Copyright (c) 2021-2022 Basile Henry 104 | ``` 105 | -------------------------------------------------------------------------------- /src/Sweeper/Grid/BalancedTernary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Sweeper.Grid.BalancedTernary (Stream, index, update, Index, toIndex, fromIndex, randomStream) where 6 | 7 | -- base 8 | import Data.Coerce 9 | import Data.Functor.Const 10 | import Data.Functor.Identity 11 | 12 | -- random 13 | import System.Random 14 | 15 | data Trit = T | O | I 16 | deriving (Eq, Ord, Show) 17 | 18 | predTernary :: [Trit] -> [Trit] 19 | predTernary [] = [T] 20 | predTernary [I] = [] 21 | predTernary (O:ns) = T:ns 22 | predTernary (I:ns) = O:ns 23 | predTernary (T:ns) = I:predTernary ns 24 | 25 | succTernary :: [Trit] -> [Trit] 26 | succTernary [] = [I] 27 | succTernary [T] = [] 28 | succTernary (T:ns) = O:ns 29 | succTernary (O:ns) = I:ns 30 | succTernary (I:ns) = T:succTernary ns 31 | 32 | consO :: [Trit] -> [Trit] 33 | consO [] = [] 34 | consO xs = O:xs 35 | 36 | plusTernary :: [Trit] -> [Trit] -> [Trit] 37 | plusTernary [] ns = ns 38 | plusTernary ms [] = ms 39 | plusTernary (T:ms) (O:ns) = T:plusTernary ms ns 40 | plusTernary (T:ms) (I:ns) = consO $ plusTernary ms ns 41 | plusTernary (O:ms) (O:ns) = consO $ plusTernary ms ns 42 | plusTernary (O:ms) (n:ns) = n:plusTernary ms ns 43 | plusTernary (I:ms) (T:ns) = consO $ plusTernary ms ns 44 | plusTernary (I:ms) (O:ns) = I:plusTernary ms ns 45 | plusTernary (T:ms) (T:ns) = predTernary $ T:plusTernary ms ns 46 | plusTernary (I:ms) (I:ns) = succTernary $ I:plusTernary ms ns 47 | 48 | toBalancedTernary :: Integer -> [Trit] 49 | toBalancedTernary 0 = [] 50 | toBalancedTernary x = case x `divMod` 3 of 51 | (q, 0) -> O : toBalancedTernary q 52 | (q, 1) -> I : toBalancedTernary q 53 | (q, 2) -> T : toBalancedTernary (q + 1) 54 | _ -> error "Unreachable" 55 | 56 | fromBalancedTernary :: [Trit] -> Integer 57 | fromBalancedTernary [] = 0 58 | fromBalancedTernary (T:ns) = (-1) + 3 * fromBalancedTernary ns 59 | fromBalancedTernary (O:ns) = 3 * fromBalancedTernary ns 60 | fromBalancedTernary (I:ns) = 1 + 3 * fromBalancedTernary ns 61 | 62 | newtype Index = Index {getIndex :: [Trit]} -- invariant no trailing zeros 63 | deriving (Eq, Ord) 64 | 65 | instance Semigroup Index where 66 | (<>) = coerce plusTernary 67 | 68 | instance Monoid Index where 69 | mempty = Index [] 70 | 71 | instance Enum Index where 72 | succ = coerce succTernary 73 | pred = coerce predTernary 74 | fromEnum = fromInteger . fromIndex 75 | toEnum = toIndex . toInteger 76 | 77 | toIndex :: Integer -> Index 78 | toIndex = coerce toBalancedTernary 79 | 80 | fromIndex :: Index -> Integer 81 | fromIndex = coerce fromBalancedTernary 82 | 83 | ------------------------------------------------------------------------------- 84 | 85 | data Nat = Z | S Nat 86 | 87 | data SNat n where 88 | SZ :: SNat 'Z 89 | SS :: SNat n -> SNat ('S n) 90 | 91 | data TernaryTree n a where 92 | Leaf :: a -> TernaryTree 'Z a 93 | Branch :: TernaryTree n a -> TernaryTree n a -> TernaryTree n a -> TernaryTree ('S n) a 94 | 95 | data CoTernaryTree n a where 96 | CoTernaryTree :: TernaryTree n a -> CoTernaryTree ('S n) a -> TernaryTree n a -> CoTernaryTree n a 97 | 98 | -- | Skew balanced ternary skip stream 99 | data Stream a = Stream a (CoTernaryTree 'Z a) 100 | 101 | data Vec n a where 102 | Nil :: Vec 'Z a 103 | Cons :: a -> Vec n a -> Vec ('S n) a 104 | 105 | ternaryTreeLens :: Functor f => Vec n Trit -> (a -> f a) -> TernaryTree n a -> f (TernaryTree n a) 106 | ternaryTreeLens Nil f (Leaf a) = fmap Leaf (f a) 107 | ternaryTreeLens (Cons x n) f (Branch t o i) = case x of 108 | T -> fmap (\t' -> Branch t' o i) (ternaryTreeLens n f t) 109 | O -> fmap (\o' -> Branch t o' i) (ternaryTreeLens n f o) 110 | I -> fmap (\i' -> Branch t o i') (ternaryTreeLens n f i) 111 | 112 | coTernaryTreeLens :: Functor f => Vec n Trit -> [Trit] -> (a -> f a) -> CoTernaryTree n a -> f (CoTernaryTree n a) 113 | coTernaryTreeLens _ [] _ _ = error "Unreachable" 114 | coTernaryTreeLens v [x] f (CoTernaryTree t o i) = case x of 115 | T -> fmap (\t' -> CoTernaryTree t' o i) (ternaryTreeLens v f t) 116 | O -> error "Unreachable" 117 | I -> fmap (\i' -> CoTernaryTree t o i') (ternaryTreeLens v f i) 118 | coTernaryTreeLens v (x:xs) f (CoTernaryTree i o t) = fmap (\o' -> CoTernaryTree i o' t) (coTernaryTreeLens (Cons x v) xs f o) 119 | 120 | -- sbtssLens :: [Trit] -> Lens' (Stream a) a 121 | sbtssLens :: Functor f => [Trit] -> (a -> f a) -> Stream a -> f (Stream a) 122 | sbtssLens [] f (Stream a b) = fmap (\a' -> Stream a' b) (f a) 123 | sbtssLens xs f (Stream a b) = fmap (\b' -> Stream a b') (coTernaryTreeLens Nil xs f b) 124 | 125 | streamIx :: forall f a. Functor f => Index -> (a -> f a) -> Stream a -> f (Stream a) 126 | streamIx = sbtssLens . getIndex 127 | 128 | index :: Index -> Stream a -> a 129 | index i s = getConst $ streamIx i Const s 130 | 131 | update :: Index -> (a -> a) -> Stream a -> Stream a 132 | update i f = runIdentity . streamIx i (Identity . f) 133 | 134 | randomStream :: forall a. (StdGen -> (a, StdGen)) -> StdGen -> Stream a 135 | randomStream f gen = 136 | let (a, gen') = f gen 137 | in Stream a $ randomCoTernaryTree gen' SZ 138 | where 139 | randomCoTernaryTree :: StdGen -> SNat n -> CoTernaryTree n a 140 | randomCoTernaryTree g n = 141 | let (g0, g1) = split g 142 | (g2, g3) = split g0 143 | in CoTernaryTree (randomTernaryTree g1 n) (randomCoTernaryTree g2 (SS n)) (randomTernaryTree g3 n) 144 | 145 | randomTernaryTree :: StdGen -> SNat n -> TernaryTree n a 146 | randomTernaryTree g SZ = Leaf . fst $ f g 147 | randomTernaryTree g (SS n) = 148 | let (g0, g1) = split g 149 | (g2, g3) = split g0 150 | in Branch (randomTernaryTree g1 n) (randomTernaryTree g2 n) (randomTernaryTree g3 n) 151 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | if spec ? ref then spec.ref else 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; 34 | submodules = if spec ? submodules then spec.submodules else false; 35 | submoduleArg = 36 | let 37 | nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0; 38 | emptyArgWithWarning = 39 | if submodules == true 40 | then 41 | builtins.trace 42 | ( 43 | "The niv input \"${name}\" uses submodules " 44 | + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " 45 | + "does not support them" 46 | ) 47 | {} 48 | else {}; 49 | in 50 | if nixSupportsSubmodules 51 | then { inherit submodules; } 52 | else emptyArgWithWarning; 53 | in 54 | builtins.fetchGit 55 | ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); 56 | 57 | fetch_local = spec: spec.path; 58 | 59 | fetch_builtin-tarball = name: throw 60 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 61 | $ niv modify ${name} -a type=tarball -a builtin=true''; 62 | 63 | fetch_builtin-url = name: throw 64 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 65 | $ niv modify ${name} -a type=file -a builtin=true''; 66 | 67 | # 68 | # Various helpers 69 | # 70 | 71 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 72 | sanitizeName = name: 73 | ( 74 | concatMapStrings (s: if builtins.isList s then "-" else s) 75 | ( 76 | builtins.split "[^[:alnum:]+._?=-]+" 77 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 78 | ) 79 | ); 80 | 81 | # The set of packages used when specs are fetched using non-builtins. 82 | mkPkgs = sources: system: 83 | let 84 | sourcesNixpkgs = 85 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 86 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 87 | hasThisAsNixpkgsPath = == ./.; 88 | in 89 | if builtins.hasAttr "nixpkgs" sources 90 | then sourcesNixpkgs 91 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 92 | import {} 93 | else 94 | abort 95 | '' 96 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 97 | add a package called "nixpkgs" to your sources.json. 98 | ''; 99 | 100 | # The actual fetching function. 101 | fetch = pkgs: name: spec: 102 | 103 | if ! builtins.hasAttr "type" spec then 104 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 105 | else if spec.type == "file" then fetch_file pkgs name spec 106 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 107 | else if spec.type == "git" then fetch_git name spec 108 | else if spec.type == "local" then fetch_local spec 109 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 110 | else if spec.type == "builtin-url" then fetch_builtin-url name 111 | else 112 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 113 | 114 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 115 | # the path directly as opposed to the fetched source. 116 | replace = name: drv: 117 | let 118 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 119 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 120 | in 121 | if ersatz == "" then drv else 122 | # this turns the string into an actual Nix path (for both absolute and 123 | # relative paths) 124 | if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; 125 | 126 | # Ports of functions for older nix versions 127 | 128 | # a Nix version of mapAttrs if the built-in doesn't exist 129 | mapAttrs = builtins.mapAttrs or ( 130 | f: set: with builtins; 131 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 132 | ); 133 | 134 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 135 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 136 | 137 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 138 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 139 | 140 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 141 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 142 | concatMapStrings = f: list: concatStrings (map f list); 143 | concatStrings = builtins.concatStringsSep ""; 144 | 145 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 146 | optionalAttrs = cond: as: if cond then as else {}; 147 | 148 | # fetchTarball version that is compatible between all the versions of Nix 149 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 150 | let 151 | inherit (builtins) lessThan nixVersion fetchTarball; 152 | in 153 | if lessThan nixVersion "1.12" then 154 | fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 155 | else 156 | fetchTarball attrs; 157 | 158 | # fetchurl version that is compatible between all the versions of Nix 159 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 160 | let 161 | inherit (builtins) lessThan nixVersion fetchurl; 162 | in 163 | if lessThan nixVersion "1.12" then 164 | fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 165 | else 166 | fetchurl attrs; 167 | 168 | # Create the final "sources" from the config 169 | mkSources = config: 170 | mapAttrs ( 171 | name: spec: 172 | if builtins.hasAttr "outPath" spec 173 | then abort 174 | "The values in sources.json should not have an 'outPath' attribute" 175 | else 176 | spec // { outPath = replace name (fetch config.pkgs name spec); } 177 | ) config.sources; 178 | 179 | # The "config" used by the fetchers 180 | mkConfig = 181 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 182 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 183 | , system ? builtins.currentSystem 184 | , pkgs ? mkPkgs sources system 185 | }: rec { 186 | # The sources, i.e. the attribute set of spec name to spec 187 | inherit sources; 188 | 189 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 190 | inherit pkgs; 191 | }; 192 | 193 | in 194 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 195 | -------------------------------------------------------------------------------- /src/Sweeper/Game.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module Sweeper.Game where 4 | 5 | -- base 6 | import Numeric.Natural 7 | import Prelude hiding (Left, Right) 8 | 9 | -- random 10 | import System.Random (StdGen, randomR, split) 11 | 12 | -- infinisweep 13 | import Sweeper.Grid 14 | 15 | data Cell = Empty Bool | Mark Bool | Visible Int deriving Eq 16 | 17 | isMine :: Cell -> Bool 18 | isMine (Empty mine) = mine 19 | isMine (Mark mine) = mine 20 | isMine _ = False 21 | 22 | isVisible :: Cell -> Bool 23 | isVisible Visible{} = True 24 | isVisible _ = False 25 | 26 | isMarked :: Cell -> Bool 27 | isMarked Mark{} = True 28 | isMarked _ = False 29 | 30 | mark :: Cell -> Cell 31 | mark (Empty mine) = Mark mine 32 | mark cell = cell 33 | 34 | unmark :: Cell -> Cell 35 | unmark (Mark mine) = Empty mine 36 | unmark cell = cell 37 | 38 | -- | The score corresponds to the sum of all the numbers showing in the visible cells 39 | type Score = Int 40 | data PlayState = Alive | Dead deriving Eq 41 | 42 | data Options = Options 43 | { autoOpen :: Bool 44 | , density :: Int 45 | } 46 | 47 | prettyShow :: Options -> [String] 48 | prettyShow opts = 49 | ["Auto Open" | autoOpen opts] ++ 50 | ["Density: " ++ show (density opts)] 51 | 52 | data Move = Up | Down | Left | Right | UpLeft | UpRight | DownLeft | DownRight -- Possible ways to move on the grid 53 | data GameState = GameState 54 | { 55 | grid :: Grid Cell, 56 | visible :: Natural, 57 | score :: Score, 58 | position :: Position, 59 | highscore :: Score, 60 | playState :: PlayState, 61 | panel :: Panel, 62 | randomgen :: StdGen, 63 | options :: Options 64 | } 65 | 66 | -- | Count the number of mines in the positions around a given position 67 | tallyMines :: Grid Cell -> Position -> Int 68 | tallyMines grid pos = length $ filter isMine $ map (`getCell` grid) (surroundingPositions pos) 69 | 70 | -- | Count the number of marked cells in the positions around a given position 71 | tallyMarkers :: Grid Cell -> Position -> Int 72 | tallyMarkers grid pos = length $ filter isMarked $ map (`getCell` grid) (surroundingPositions pos) 73 | 74 | -- | Randomly generate a cell given a density 75 | randomCell :: Int -> StdGen -> (Cell, StdGen) 76 | randomCell density gen = 77 | let (n, g) = randomR (0,99) gen 78 | in (Empty (n < density), g) 79 | 80 | -- | Generate a random initial GameState 81 | createGameState :: StdGen -> Options -> Score -> GameState 82 | createGameState gen opts hs = let (g, g') = split gen in 83 | GameState 84 | { 85 | grid = randomGrid (randomCell (density opts)) g, 86 | visible = 0, 87 | position = zeroPosition, 88 | score = 0, 89 | highscore = hs, 90 | playState = Alive, 91 | panel = (movePosition (-150) (-50) zeroPosition, movePosition 150 50 zeroPosition), 92 | randomgen = g', 93 | options = opts 94 | } 95 | 96 | newGame :: GameState -> GameState 97 | newGame GameState{randomgen=gen, options=opts, highscore=hs} = createGameState gen opts hs 98 | 99 | -- | Recursively open cells that are empty (limited by panel to avoid infinite recursion) 100 | getEmptyCells :: GameState -> Position -> GameState 101 | getEmptyCells g@GameState{grid, visible, panel, score, highscore} pos 102 | | not (inBounds pos panel) 103 | || isMarked (getCell pos grid) 104 | || isVisible (getCell pos grid) = g 105 | | t > 0 = g{grid=newGrid, score=score + t, highscore=max highscore (score + t), visible=visible+1} 106 | | otherwise = foldl getEmptyCells g{grid=newGrid} (surroundingPositions pos) 107 | where 108 | t :: Int 109 | t = tallyMines grid pos 110 | 111 | newGrid :: Grid Cell 112 | newGrid = setCell pos (Visible t) grid 113 | 114 | -- | A Cell (at a given position) is satisfied if the number of Mines around it matches the number of cells 115 | -- Markers could still be missplaced! 116 | isSatisfied :: GameState -> Position -> Bool 117 | isSatisfied GameState{grid} p = tallyMines grid p == tallyMarkers grid p 118 | 119 | type GameUpdate = GameState -> Maybe GameState 120 | 121 | -- | Change the current position on the grid 122 | makeMove :: Move -> GameUpdate 123 | makeMove move g@GameState{grid, position, panel=(topLeft@(Cartesian left top), bottomRight@(Cartesian right bottom))} = 124 | pure newGameState{position = movePosition dx dy position} 125 | where 126 | -- deltas from a Move 127 | (dx, dy) = case move of 128 | Up -> ( 0, -1) 129 | Down -> ( 0, 1) 130 | Left -> (-1, 0) 131 | Right -> ( 1, 0) 132 | UpLeft -> (-1, -1) 133 | UpRight -> ( 1, -1) 134 | DownLeft -> (-1, 1) 135 | DownRight -> ( 1, 1) 136 | 137 | newPanel :: Panel 138 | newPanel = (movePosition dx dy topLeft, movePosition dx dy bottomRight) 139 | 140 | -- cells on the edge of the panel that need to be updated because the panel is moving 141 | -- this update is necessary since the cells opened recursively stopped at the edge of the panel 142 | cells :: [Position] 143 | cells = concatMap surroundingPositions $ filter (\p -> isVisible (getCell p grid) && (tallyMines grid p == 0)) $ case move of 144 | Up -> [Cartesian i top | i <- [left..right]] 145 | Down -> [Cartesian i bottom | i <- [left..right]] 146 | Left -> [Cartesian left i | i <- [top..bottom]] 147 | Right -> [Cartesian right i | i <- [top..bottom]] 148 | UpLeft -> [Cartesian i top | i <- [left..right]] ++ [Cartesian left i | i <- [top..bottom]] 149 | UpRight -> [Cartesian i top | i <- [left..right]] ++ [Cartesian right i | i <- [top..bottom]] 150 | DownLeft -> [Cartesian i bottom | i <- [left..right]] ++ [Cartesian left i | i <- [top..bottom]] 151 | DownRight -> [Cartesian i bottom | i <- [left..right]] ++ [Cartesian right i | i <- [top..bottom]] 152 | 153 | -- get the new GameState with the updated cells and panel 154 | newGameState = foldl getEmptyCells g{panel=newPanel} cells 155 | 156 | -- | Implements the AutoOpen option by opening cells surrounding satisfied cells 157 | updateMarker :: Position -> GameUpdate 158 | updateMarker pos g@GameState{grid,visible=vn} 159 | | vn == visible newGameState = pure newGameState 160 | | otherwise = updateMarker pos newGameState 161 | where 162 | cells :: [Position] 163 | cells = concatMap surroundingPositions $ filter (\p -> isVisible (getCell p grid) && isSatisfied g p) (surroundingPositions pos) 164 | 165 | newGameState :: GameState 166 | newGameState = foldl clickCellPos g cells 167 | 168 | -- | Handle the placement of a marker on the grid 169 | placeMarker :: GameUpdate 170 | placeMarker g@GameState{playState=Dead} = pure g 171 | placeMarker g@GameState{grid, position=pos, options} 172 | | isVisible (getCell pos grid) = pure g 173 | | isMarked (getCell pos grid) = pure g{grid = modifyCell pos unmark grid} 174 | | autoOpen options = updateMarker pos newGameState 175 | | otherwise = pure newGameState 176 | where 177 | newGameState :: GameState 178 | newGameState = g{grid = modifyCell pos mark grid} 179 | 180 | -- | Handle a player click on the current cell 181 | clickCell :: GameUpdate 182 | clickCell g@GameState{playState=Dead} = pure g 183 | clickCell g = pure $ clickCellPos g (position g) 184 | 185 | -- | Handle opening a cell (both user actions on automatic ones) 186 | clickCellPos :: GameState -> Position -> GameState 187 | clickCellPos g@GameState{grid} pos 188 | | isMarked (getCell pos grid) = g 189 | | isVisible (getCell pos grid) = updatedMarkers 190 | | isMine (getCell pos grid) = g{playState=Dead} 191 | | otherwise = getEmptyCells g pos 192 | where 193 | updatedMarkers :: GameState 194 | updatedMarkers 195 | | isSatisfied g pos = foldl clickCellPos g (filter (\p -> not $ isVisible (getCell p grid)) (surroundingPositions pos)) 196 | | otherwise = g 197 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | 5 | module Main(main) where 6 | 7 | -- base 8 | import Data.Bool (bool) 9 | import Data.List (intercalate) 10 | import Prelude hiding (Either (..)) 11 | import qualified Prelude as P 12 | import System.Environment (lookupEnv) 13 | import System.IO.Error (tryIOError) 14 | 15 | -- directory 16 | import System.Directory (createDirectoryIfMissing) 17 | 18 | -- filepath 19 | import System.FilePath.Posix (()) 20 | 21 | -- optparse-applicative 22 | import qualified Options.Applicative as Opt 23 | 24 | -- random 25 | import System.Random (getStdGen) 26 | 27 | -- vty 28 | import Graphics.Vty 29 | 30 | -- infinisweep 31 | import Sweeper.Game 32 | import Sweeper.Grid 33 | 34 | {-# ANN module ("HLint: ignore Use head") #-} 35 | -- we often use "palette !! x" for some x 36 | 37 | optionsParser :: Opt.Parser Options 38 | optionsParser = Options 39 | <$> Opt.switch 40 | (Opt.short 'a' <> Opt.long "auto-open" <> Opt.help "Open cells automatically (as per flags/markers)") 41 | <*> Opt.option Opt.auto 42 | (Opt.short 'd' <> Opt.long "density" <> Opt.help "Density of the minefield, as a percentage" <> Opt.value 20 <> Opt.metavar "PERCENT") 43 | 44 | showGrid :: GameState -> Panel -> Image 45 | showGrid gamestate ~(Cartesian left top, Cartesian right bottom) = 46 | vertCat 47 | [ horizCat 48 | [ showCell gamestate (Cartesian x y) 49 | | x <- [left..right] 50 | ] 51 | | y <- [top..bottom] 52 | ] 53 | 54 | showCell :: GameState -> Position -> Image 55 | showCell GameState{grid, playState} pos = showCell' currentCell 56 | where 57 | currentCell :: Cell 58 | currentCell = getCell pos grid 59 | 60 | showCell' :: Cell -> Image 61 | showCell' (Empty True) 62 | | playState == Dead = drawMine 63 | showCell' (Mark _) = char (markerColor playState currentCell) '#' 64 | showCell' (Visible t) = 65 | char 66 | (defAttr `withForeColor` (numColor !! t)) 67 | (if t == 0 then '-' else head $ show t) 68 | showCell' _ = char defAttr ' ' 69 | 70 | numColor :: [Color] 71 | numColor = 72 | [ blue -- 0 73 | , white -- 1 74 | , yellow -- 2 75 | , green -- 3 76 | , cyan -- 4 77 | , magenta -- 5 78 | , brightBlue -- 6 79 | , brightGreen -- 7 80 | , brightMagenta -- 8 81 | ] 82 | 83 | drawMine :: Image 84 | drawMine = char (defAttr `withForeColor` red) 'X' 85 | 86 | markerColor :: PlayState -> Cell -> Attr 87 | markerColor Dead c | not (isMine c) = defAttr `withForeColor` yellow 88 | markerColor _ _ = defAttr `withForeColor` red 89 | 90 | -- Highscore file path depends on the options 91 | -- This uses the XDG spec to determine the location of the data directory 92 | getHighscorePath :: Options -> IO FilePath 93 | getHighscorePath Options{autoOpen, density} = do 94 | let fileName = concat 95 | [ "highscore_" 96 | , bool "" "auto_" autoOpen 97 | , show density 98 | ] 99 | 100 | dataDir <- lookupEnv "XDG_DATA_HOME" >>= \case 101 | Just dataHome -> return dataHome 102 | Nothing -> 103 | lookupEnv "HOME" >>= \case 104 | Just home -> return (home ".local" "share") 105 | Nothing -> error $ unlines 106 | [ "Unable to set path for highscore file." 107 | , "One of $XDG_DATA_HOME or $HOME needs to be set." 108 | ] 109 | 110 | let infinisweepDataDir = dataDir "infinisweep" 111 | createDirectoryIfMissing True infinisweepDataDir 112 | 113 | return (infinisweepDataDir fileName) 114 | 115 | readHighscore :: Options -> IO Score 116 | readHighscore options = do 117 | highscorePath <- getHighscorePath options 118 | strOrExc <- tryIOError $ readFile highscorePath 119 | let 120 | getScore :: [String] -> Score 121 | getScore [] = 0 122 | getScore (x:_) = read $ last $ words x 123 | 124 | highscore = case strOrExc of 125 | P.Left _ -> 0 126 | P.Right contents -> getScore $ lines contents 127 | 128 | return highscore 129 | 130 | writeHighscore :: Options -> Score -> IO () 131 | writeHighscore options score = do 132 | highscorePath <- getHighscorePath options 133 | writeFile highscorePath (show score) 134 | 135 | main :: IO () 136 | main = do 137 | gen <- getStdGen 138 | options <- Opt.execParser $ Opt.info (Opt.helper <*> optionsParser) Opt.fullDesc 139 | !highscore <- readHighscore options -- get the saved highscore 140 | 141 | cfg <- standardIOConfig 142 | vty <- mkVty cfg 143 | 144 | -- Start the UI and the mainloop 145 | -- get the new highscore 146 | new_highscore <- doUpdate vty (createGameState gen options highscore) 147 | 148 | -- save the new highscore 149 | writeHighscore options new_highscore 150 | shutdown vty 151 | 152 | -- Mainloop 153 | -- Update the UI 154 | doUpdate :: Vty -> GameState -> IO Score 155 | doUpdate vty g@GameState{position = ~(Cartesian x y), score, highscore, playState, options} = do 156 | (displayWidth, displayHeight) <- displayBounds (outputIface vty) 157 | 158 | let sizeX = toInteger displayWidth 159 | sizeY = toInteger displayHeight 160 | 161 | topLeft@(Cartesian left top) = Cartesian (x - (sizeX `div` 2)) (y - (sizeY `div` 2)) 162 | bottomRight = Cartesian (left + sizeX - 1) (top + sizeY - 3) 163 | panel = (topLeft, bottomRight) 164 | 165 | image = vertCat 166 | [ showGrid g panel 167 | , string (defAttr `withForeColor` yellow) (replicate displayWidth '─') 168 | , string (defAttr `withForeColor` blue) $ take displayWidth $ 169 | intercalate " | " ( 170 | prettyShow options ++ 171 | case playState of 172 | Alive -> ["Score: " ++ show score] 173 | Dead -> ["Game over! Your score is: " ++ show score, "Highscore is: " ++ show highscore] 174 | ) 175 | ++ repeat ' ' 176 | ] 177 | 178 | picture = Picture 179 | { picCursor = AbsoluteCursor (displayWidth `div` 2) (displayHeight `div` 2) 180 | , picLayers = [image] 181 | , picBackground = ClearBackground 182 | } 183 | 184 | update vty picture 185 | inputUpdate vty g 186 | 187 | -- Take keyboard inputs and update GameState 188 | inputUpdate :: Vty -> GameState -> IO Score 189 | inputUpdate vty g = do 190 | event <- nextEvent vty 191 | case stepGameWorld event g of 192 | Nothing -> pure (highscore g) 193 | Just g' -> doUpdate vty g' 194 | 195 | -- Handle keyboard inputs on the current GameState and update the GameState accordingly 196 | stepGameWorld :: Event -> GameUpdate 197 | stepGameWorld (EvKey key _) 198 | | quit key = const Nothing 199 | | restart key = pure . newGame 200 | | moveUp key = makeMove Up 201 | | moveDown key = makeMove Down 202 | | moveLeft key = makeMove Left 203 | | moveRight key = makeMove Right 204 | | moveUpLeft key = makeMove UpLeft 205 | | moveUpRight key = makeMove UpRight 206 | | moveDownLeft key = makeMove DownLeft 207 | | moveDownRight key = makeMove DownRight 208 | | placeMarkerK key = placeMarker 209 | | clickCellK key = clickCell 210 | | otherwise = pure 211 | where 212 | quit = \case 213 | KChar c | c `elem` "qQ" -> True 214 | _ -> False 215 | 216 | restart = \case 217 | KChar c | c `elem` "rR" -> True 218 | _ -> False 219 | 220 | moveUp = \case 221 | KChar c | c `elem` "wWkK8" -> True 222 | KUp -> True 223 | _ -> False 224 | 225 | moveDown = \case 226 | KChar c | c `elem` "sSjJ2" -> True 227 | KDown -> True 228 | _ -> False 229 | 230 | moveLeft = \case 231 | KChar c | c `elem` "aAhH4" -> True 232 | KLeft -> True 233 | _ -> False 234 | 235 | moveRight = \case 236 | KChar c | c `elem` "dDlL6" -> True 237 | KRight -> True 238 | _ -> False 239 | 240 | moveUpLeft = \case 241 | KChar c | c `elem` "yY7" -> True 242 | KUpLeft -> True 243 | _ -> False 244 | 245 | moveUpRight = \case 246 | KChar c | c `elem` "uU9" -> True 247 | KUpRight -> True 248 | _ -> False 249 | 250 | moveDownLeft = \case 251 | KChar c | c `elem` "bB1" -> True 252 | KDownLeft -> True 253 | _ -> False 254 | 255 | moveDownRight = \case 256 | KChar c | c `elem` "nN3" -> True 257 | KDownRight -> True 258 | _ -> False 259 | 260 | placeMarkerK = \case 261 | KChar c | c `elem` "mMeE5" -> True 262 | _ -> False 263 | 264 | clickCellK = \case 265 | KChar c | c `elem` " 0" -> True 266 | _ -> False 267 | stepGameWorld _ = pure 268 | --------------------------------------------------------------------------------