├── static └── github.png ├── .idea ├── codeStyles │ ├── codeStyleConfig.xml │ └── Project.xml ├── vcs.xml ├── .gitignore ├── modules.xml ├── misc.xml └── yaet.iml ├── src ├── index.html ├── Ports.elm ├── UIHelpers.elm ├── Coord.elm ├── index.js ├── DroppingShape.elm ├── Scoring.elm ├── GameBoard.elm ├── Button.elm ├── Modal.elm ├── HighlightAnimation.elm ├── Main.elm ├── UserGameControl.elm ├── Shape.elm ├── GameOver.elm ├── Settings.elm ├── SettingsScreen.elm ├── BoardView.elm ├── HighScores.elm └── WelcomeScreen.elm ├── package.json ├── elm.json ├── .github └── workflows │ └── node.js.yml ├── .gitignore ├── README.md └── tests ├── AsciiGrid.elm ├── ShapeTests.elm ├── BoardTests.elm ├── ShapeUtils.elm └── GameTests.elm /static/github.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yonigibbs/yaet/HEAD/static/github.png -------------------------------------------------------------------------------- /.idea/codeStyles/codeStyleConfig.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | -------------------------------------------------------------------------------- /.idea/vcs.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | -------------------------------------------------------------------------------- /.idea/.gitignore: -------------------------------------------------------------------------------- 1 | # Default ignored files 2 | /shelf/ 3 | /workspace.xml 4 | # Datasource local storage ignored files 5 | /dataSources/ 6 | /dataSources.local.xml 7 | # Editor-based HTTP Client requests 8 | /httpRequests/ 9 | -------------------------------------------------------------------------------- /src/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Yet Another Elm Tetris 5 | 6 | 7 |
8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /.idea/modules.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /src/Ports.elm: -------------------------------------------------------------------------------- 1 | port module Ports exposing (persistHighScores, persistSettings) 2 | 3 | {-| This module defines all ports used by the system. 4 | -} 5 | 6 | import Json.Encode as JE 7 | 8 | 9 | {-| Persists settings to local storage. 10 | -} 11 | port persistSettings : JE.Value -> Cmd msg 12 | 13 | 14 | {-| Persists high scores to local storage. 15 | -} 16 | port persistHighScores : JE.Value -> Cmd msg 17 | -------------------------------------------------------------------------------- /.idea/codeStyles/Project.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 8 | 9 | 11 | 12 | 14 | 15 | -------------------------------------------------------------------------------- /.idea/misc.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 14 | -------------------------------------------------------------------------------- /src/UIHelpers.elm: -------------------------------------------------------------------------------- 1 | module UIHelpers exposing (edges, mainBackgroundColour, mainForegroundColour) 2 | 3 | {-| Miscellaneous helper functions related to the UI/rendering. 4 | -} 5 | 6 | import Element exposing (Element) 7 | 8 | 9 | edges : { top : Int, right : Int, bottom : Int, left : Int } 10 | edges = 11 | { top = 0 12 | , right = 0 13 | , bottom = 0 14 | , left = 0 15 | } 16 | 17 | 18 | {-| The main background colour of the screen. 19 | -} 20 | mainBackgroundColour : Element.Color 21 | mainBackgroundColour = 22 | Element.rgb255 30 30 30 23 | 24 | 25 | {-| The colour to use by default for the foreground (fonts, buttons, etc) 26 | -} 27 | mainForegroundColour : Element.Color 28 | mainForegroundColour = 29 | Element.rgb255 198 195 195 30 | -------------------------------------------------------------------------------- /src/Coord.elm: -------------------------------------------------------------------------------- 1 | module Coord exposing (Coord) 2 | 3 | {-| Module for the `Coord` type (see that type for details). 4 | -} 5 | 6 | 7 | {-| Represents the coordinates of a block within some parent "container": this could be the coordinates of a block on a 8 | board, or a block within a shape. This is simply a tuple of integer values representing the x- and y-coordinates of the 9 | block, where the x-axis runs along the bottom of the containing grid, and the y-axis runs up the left hand side of it 10 | (i.e. like a standard line chart, rather than like SVG coordinates, where the y-axis runs _down_ the left hand side). 11 | 12 | (A tuple is used rather than a record as it is comparable, allowing for easier comparisons etc.) 13 | 14 | -} 15 | type alias Coord = 16 | ( Int, Int ) 17 | -------------------------------------------------------------------------------- /.idea/yaet.iml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "yaet", 3 | "version": "1.0.0", 4 | "description": "", 5 | "main": "index.js", 6 | "scripts": { 7 | "test": "elm-test", 8 | "serve": "parcel src/index.html", 9 | "build": "rm -rf deploy && parcel build src/*.html --out-dir deploy --public-url /yaet", 10 | "predeploy": "npm run build && npm run test", 11 | "deploy": "gh-pages -d deploy", 12 | "clean": "rm -rf deploy && rm -rf dist" 13 | }, 14 | "keywords": [], 15 | "author": "", 16 | "license": "ISC", 17 | "devDependencies": { 18 | "elm": "^0.19.1-5", 19 | "elm-format": "^0.8.5", 20 | "elm-hot": "^1.1.6", 21 | "elm-test": "^0.19.1-revision6", 22 | "gh-pages": "^3.1.0", 23 | "node-elm-compiler": "^5.0.5", 24 | "parcel-bundler": "^1.12.4", 25 | "parcel-plugin-static-files-copy": "^2.5.1" 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /src/index.js: -------------------------------------------------------------------------------- 1 | import {Elm} from "./Main.elm" 2 | 3 | // Read the settings and high scores from local storage. This is sent into the Elm app as JSON which is decoded using 4 | // Elm. Any errors in decoding (or null values) result in the default settings and high scores being used instead. 5 | const settings = localStorage.getItem("settings") 6 | const highScores = localStorage.getItem("highScores") 7 | 8 | const app = Elm.Main.init({ 9 | node: document.querySelector("main"), 10 | flags: { 11 | settings: settings ? JSON.parse(settings) : null, 12 | highScores: highScores ? JSON.parse(highScores) : null 13 | } 14 | }) 15 | 16 | /** 17 | * Persists the settings in local storage. 18 | */ 19 | app.ports.persistSettings.subscribe(settings => localStorage.setItem("settings", JSON.stringify(settings))) 20 | 21 | /** 22 | * Persists the high scores in local storage. 23 | */ 24 | app.ports.persistHighScores.subscribe(highScores => localStorage.setItem("highScores", JSON.stringify(highScores))) 25 | -------------------------------------------------------------------------------- /elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "avh4/elm-color": "1.0.0", 10 | "elm/browser": "1.0.2", 11 | "elm/core": "1.0.5", 12 | "elm/html": "1.0.0", 13 | "elm/json": "1.1.3", 14 | "elm/random": "1.0.0", 15 | "elm/time": "1.0.0", 16 | "elm-community/random-extra": "3.1.0", 17 | "elm-community/typed-svg": "6.0.0", 18 | "mdgriffith/elm-ui": "1.1.8", 19 | "pzp1997/assoc-list": "1.0.0" 20 | }, 21 | "indirect": { 22 | "elm/url": "1.0.0", 23 | "elm/virtual-dom": "1.0.2", 24 | "owanturist/elm-union-find": "1.0.0" 25 | } 26 | }, 27 | "test-dependencies": { 28 | "direct": { 29 | "elm/parser": "1.1.0", 30 | "elm-explorations/test": "1.2.2" 31 | }, 32 | "indirect": {} 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /.github/workflows/node.js.yml: -------------------------------------------------------------------------------- 1 | # This workflow will do a clean install of node dependencies, build the source code and run tests across different versions of node 2 | # For more information see: https://help.github.com/actions/language-and-framework-guides/using-nodejs-with-github-actions 3 | 4 | name: Node.js CI 5 | 6 | on: 7 | push: 8 | branches: [ master ] 9 | pull_request: 10 | branches: [ master ] 11 | 12 | jobs: 13 | build: 14 | 15 | runs-on: ubuntu-latest 16 | 17 | strategy: 18 | matrix: 19 | node-version: [14.x] 20 | 21 | steps: 22 | - uses: actions/checkout@v2 23 | - name: Use Node.js ${{ matrix.node-version }} 24 | uses: actions/setup-node@v1 25 | with: 26 | node-version: ${{ matrix.node-version }} 27 | - name: Install Node dependencies 28 | run: npm ci 29 | - name: Build 30 | run: npm run build 31 | - name: Test 32 | run: npm test 33 | - name: Deploy to GitHub Pages 34 | uses: peaceiris/actions-gh-pages@v3 35 | if: ${{ github.event_name == 'push' }} 36 | with: 37 | github_token: ${{ secrets.GITHUB_TOKEN }} 38 | publish_dir: ./deploy 39 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Most taken from https://github.com/github/gitignore/blob/master/Global/JetBrains.gitignore, 2 | # with some stuff manually added. 3 | 4 | # User-specific stuff 5 | **/.idea/workspace.xml 6 | **/.idea/tasks.xml 7 | **/.idea/usage.statistics.xml 8 | **/.idea/dictionaries 9 | **/.idea/shelf 10 | 11 | # Generated files 12 | **/.idea/contentModel.xml 13 | **/.idea/compiler.xml 14 | 15 | # Sensitive or high-churn files 16 | **/.idea/dataSources/ 17 | **/.idea/dataSources.ids 18 | **/.idea/dataSources.local.xml 19 | **/.idea/sqlDataSources.xml 20 | **/.idea/dynamic.xml 21 | **/.idea/uiDesigner.xml 22 | **/.idea/dbnavigator.xml 23 | 24 | # Gradle 25 | **/.idea/gradle.xml 26 | **/.idea/libraries 27 | .gradle 28 | build/ 29 | !gradle/wrapper/gradle-wrapper.jar 30 | .gradletasknamecache 31 | 32 | # Gradle and Maven with auto-import 33 | # When using Gradle or Maven with auto-import, you should exclude module files, 34 | # since they will be recreated, and may cause churn. Uncomment if using 35 | # auto-import. 36 | #**/.idea/modules.xml 37 | #**/.idea/*.iml 38 | #**/.idea/modules 39 | #*.iml 40 | #*.ipr 41 | 42 | # CMake 43 | cmake-build-*/ 44 | 45 | # File-based project format 46 | *.iws 47 | 48 | # IntelliJ 49 | out/ 50 | 51 | # VS Code 52 | .vscode/ 53 | 54 | # Mac 55 | .DS_Store 56 | 57 | # Node 58 | node_modules/ 59 | 60 | # File generated when viewing a folder in Dolphin (launched from IntelliJ) 61 | .directory 62 | 63 | # Elm 64 | elm-stuff/ 65 | 66 | # Parcel 67 | .cache/ 68 | dist/ 69 | deploy/ 70 | -------------------------------------------------------------------------------- /src/DroppingShape.elm: -------------------------------------------------------------------------------- 1 | module DroppingShape exposing (DroppingShape, calcBoardCoords, calcShapeBlocksBoardCoords) 2 | 3 | import Coord exposing (Coord) 4 | import Shape exposing (Shape) 5 | 6 | 7 | {-| A shape currently dropping on the board (either in the actual game, or on the welcome screen). Contains the `Shape` 8 | itself, and its coordinates. The latter are the coordinates on the board of the bottom left corner of the grid which 9 | contains the shape (see comments on the `Shape` module itself for more info). 10 | -} 11 | type alias DroppingShape = 12 | { shape : Shape -- The shape itself 13 | , gridCoord : Coord -- The coordinates of the bottom-left corner of the grid containing the shape, on the board 14 | } 15 | 16 | 17 | {-| Calculates the coordinates of the blocks of the supplied dropping shape on the board. The dropping shape's blocks' 18 | coordinates are relative to the coordinates of the shape itself. 19 | -} 20 | calcShapeBlocksBoardCoords : DroppingShape -> List Coord 21 | calcShapeBlocksBoardCoords { gridCoord, shape } = 22 | Shape.data shape 23 | |> .blocks 24 | |> calcBoardCoords gridCoord 25 | 26 | 27 | {-| Like `calcShapeBlocksBoardCoords` but not specifically tied to the `DroppingShape` type, to allow more general usage 28 | (e.g. on the welcome screen where it's a letter being dropped, not the opaque `Shape` type). 29 | -} 30 | calcBoardCoords : Coord -> List Coord -> List Coord 31 | calcBoardCoords gridCoordOnBoard blockCoordsInGrid = 32 | let 33 | ( shapeX, shapeY ) = 34 | gridCoordOnBoard 35 | in 36 | blockCoordsInGrid |> List.map (\( x, y ) -> ( x + shapeX, y + shapeY )) 37 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Elm Tetris 2 | 3 | [![Actions Status](https://github.com/yonigibbs/yaet/workflows/Node.js%20CI/badge.svg)](https://github.com/yonigibbs/yaet/actions) 4 | 5 | This repo contains a version of Tetris, written in Elm. 6 | 7 | #### Play the game [here](https://yonigibbs.github.io/yaet/). 8 | 9 | ## Development 10 | 11 | To run the project locally clone the repo, run `npm install` (only needed once), then run `npm run serve`. This will 12 | start [Parcel](https://parceljs.org/) to serve the app on http://localhost:1234. 13 | 14 | The entry point to the app is [index.html](src/index.html). This loads [index.js](src/index.js), which in turn loads the 15 | Elm app itself. The entry point to the Elm code is [Main.elm](src/Main.elm). This module, like the rest, contains 16 | comments at the top that explain a bit about it, and should help you find your way around the code. 17 | 18 | ## Possible future enhancements 19 | 20 | * Allow game to be played on more devices 21 | * Add buttons to control the game, for devices without keyboards 22 | * Make the UI responsive 23 | * Prevent default browser behaviour on key presses, otherwise arrow keys can cause the viewport to move if the browser 24 | window is small (see https://github.com/elm/browser/issues/89) 25 | * Some complex moves currently might not be fully possible: investigate T-spin triple, for example 26 | * Let user pause/resume by clicking on game 27 | * Add bonus points for hard drop 28 | * Improve Game Over animation - drop the "Game Over" message down from top of board 29 | * Use `elm-animator` instead of doing animations manually 30 | * Add smoother transitions (e.g. fade out/in) between welcome screen and game screen 31 | * Minor issues with some corner cases around trapping Enter key on modal dialogs - if the Cancel (or Restore Defaults) 32 | button has focus and user presses Enter, what should happen? Is it even normal in web UI to treat Enter as Submit, in 33 | modals with no editable controls? 34 | -------------------------------------------------------------------------------- /src/Scoring.elm: -------------------------------------------------------------------------------- 1 | module Scoring exposing (Scoring, getLevel, getLines, getPoints, init, plusRemovedLines) 2 | 3 | {-| This module contains all functionality related to the scoring of the game, namely the number of points scored so far, 4 | the level, and the number of cleared lines. 5 | -} 6 | 7 | 8 | {-| The main type exposed (as an opaque type) from this module. 9 | -} 10 | type Scoring 11 | = Scoring ScoringData 12 | 13 | 14 | {-| Record containing the three values related to scoring (points, level and lines). 15 | -} 16 | type alias ScoringData = 17 | { points : Int, level : Int, lines : Int } 18 | 19 | 20 | {-| Gets the initial `Scoring` value to assign to a new game. This is 0 points and 0 lines, and level 1. 21 | -} 22 | init : Scoring 23 | init = 24 | Scoring { points = 0, level = 1, lines = 0 } 25 | 26 | 27 | {-| Increments the score based on the number of lines that have just been removed. 28 | -} 29 | plusRemovedLines : Int -> Scoring -> Scoring 30 | plusRemovedLines lines scoring = 31 | scoring 32 | |> plusPoints (removedLinePoints lines scoring) 33 | |> plusLines lines 34 | |> calcLevel 35 | 36 | 37 | getPoints : Scoring -> Int 38 | getPoints (Scoring { points }) = 39 | points 40 | 41 | 42 | getLevel : Scoring -> Int 43 | getLevel (Scoring { level }) = 44 | level 45 | 46 | 47 | getLines : Scoring -> Int 48 | getLines (Scoring { lines }) = 49 | lines 50 | 51 | 52 | plusPoints : Int -> Scoring -> Scoring 53 | plusPoints points (Scoring scoringData) = 54 | Scoring { scoringData | points = points + scoringData.points } 55 | 56 | 57 | plusLines : Int -> Scoring -> Scoring 58 | plusLines lines (Scoring scoringData) = 59 | Scoring { scoringData | lines = lines + scoringData.lines } 60 | 61 | 62 | {-| Calculates the level the score should be at. Every 10 cleared lines the level increments, starting initially at level 1. 63 | -} 64 | calcLevel : Scoring -> Scoring 65 | calcLevel (Scoring scoringData) = 66 | let 67 | level = 68 | scoringData.lines 69 | + 1 70 | |> toFloat 71 | |> (\lines -> lines / 10) 72 | |> ceiling 73 | in 74 | Scoring { scoringData | level = level } 75 | 76 | 77 | {-| Calculates the number of points to award for the supplied number of removed lines. 78 | -} 79 | removedLinePoints : Int -> Scoring -> Int 80 | removedLinePoints lines (Scoring { level }) = 81 | removedLineMultiplier lines * level 82 | 83 | 84 | {-| Gets the value to multiply by the number of removed lines: the more lines are cleared in one more the higher the 85 | multiplier. 86 | -} 87 | removedLineMultiplier : Int -> Int 88 | removedLineMultiplier lines = 89 | case lines of 90 | 1 -> 91 | 40 92 | 93 | 2 -> 94 | 100 95 | 96 | 3 -> 97 | 300 98 | 99 | _ -> 100 | 1200 101 | -------------------------------------------------------------------------------- /tests/AsciiGrid.elm: -------------------------------------------------------------------------------- 1 | module AsciiGrid exposing (blockColourConfig, build) 2 | 3 | {-| This module contains functions which allow tests to define some sort of block data (i.e. shapes or boards) in plain 4 | ascii text. For example this would be how to represent the straight-line shape: 5 | 6 | -- Create a multi-line string literal like this: 7 | """ 8 | ---- 9 | xxxx 10 | ---- 11 | ---- 12 | """ 13 | 14 | A lower-case `x` represents a cell which has a block in it it; any other character (hyphens generally used) means the 15 | cell is empty. 16 | 17 | -} 18 | 19 | import Coord exposing (Coord) 20 | import Dict exposing (Dict) 21 | import Shape 22 | 23 | 24 | {-| Parses the passed in textual representation of a grid of blocks, and returns a list of the blocks which are 25 | occupied. How it knows which blocks are occupied is by the character in each location: if this character appears in the 26 | `config` dictionary, it means it's populated, otherwise it's empty (by convention a hyphen is used for empty blocks). 27 | Each item in the returned list is a tuple whose first value is the coordinate of the block, and the second its value. 28 | The value is specified in the `config` dictionary, by matching it to its corresponding character. 29 | 30 | Note that the returned list of coordinates is sorted by the coordinate, as that allows tests to more easily compare the 31 | returned list to some expected list. 32 | 33 | -} 34 | build : String -> Dict Char a -> List ( Coord, a ) 35 | build asciiGrid config = 36 | let 37 | lineCoords : Int -> String -> List ( Coord, a ) 38 | lineCoords y lineText = 39 | String.toList lineText 40 | |> List.indexedMap 41 | (\x char -> 42 | case Dict.get char config of 43 | Just a -> 44 | [ ( ( x, y ), a ) ] 45 | 46 | Nothing -> 47 | [] 48 | ) 49 | |> List.concat 50 | 51 | trimStartNewline s = 52 | if String.startsWith "\n" s then 53 | String.dropLeft 1 s 54 | 55 | else 56 | s 57 | 58 | trimEndNewline s = 59 | if String.endsWith "\n" s then 60 | String.dropRight 1 s 61 | 62 | else 63 | s 64 | in 65 | -- TODO: this doesn't do any validation that all rows are the same length, etc: should it? Would using a parser be better? 66 | asciiGrid 67 | |> trimStartNewline 68 | |> trimEndNewline 69 | |> String.lines 70 | |> List.reverse 71 | |> List.indexedMap lineCoords 72 | |> List.concat 73 | |> List.sortBy Tuple.first 74 | 75 | 76 | {-| The configuration dictionary to supply to `AsciiGrid.Build` which maps each character to its corresponding colour. 77 | -} 78 | blockColourConfig : Dict Char Shape.BlockColour 79 | blockColourConfig = 80 | Dict.fromList 81 | [ ( 'b', Shape.Blue ) 82 | , ( 'r', Shape.Red ) 83 | , ( 'o', Shape.Orange ) 84 | , ( 'y', Shape.Yellow ) 85 | , ( 'p', Shape.Purple ) 86 | , ( 'g', Shape.Green ) 87 | ] 88 | -------------------------------------------------------------------------------- /tests/ShapeTests.elm: -------------------------------------------------------------------------------- 1 | module ShapeTests exposing (suite) 2 | 3 | import Coord exposing (Coord) 4 | import Expect 5 | import Shape exposing (Shape) 6 | import ShapeUtils 7 | import Test exposing (..) 8 | 9 | 10 | suite : Test 11 | suite = 12 | describe "Shape" 13 | [ describe "rotate" <| 14 | List.concat 15 | [ allRotationTests "L-shape" ShapeUtils.LShape 16 | , allRotationTests "L-mirror-shape" ShapeUtils.LMirrorShape 17 | , allRotationTests "Z-shape" ShapeUtils.ZShape 18 | , allRotationTests "S-shape" ShapeUtils.SShape 19 | , allRotationTests "T-shape" ShapeUtils.TShape 20 | , allRotationTests "Line" ShapeUtils.Line 21 | , allRotationTests "Square" ShapeUtils.Square 22 | ] 23 | , describe "clippedBlocks" <| 24 | [ clippedBlocksTest "Straight-line" 25 | (ShapeUtils.getShape ShapeUtils.Line) 26 | [ ( 0, 0 ), ( 1, 0 ), ( 2, 0 ), ( 3, 0 ) ] 27 | , clippedBlocksTest "Straight-line (rotated clockwise once)" 28 | (ShapeUtils.getShape ShapeUtils.Line |> rotateXTimes Shape.Clockwise 1) 29 | [ ( 0, 0 ), ( 0, 1 ), ( 0, 2 ), ( 0, 3 ) ] 30 | , clippedBlocksTest "L-shape" 31 | (ShapeUtils.getShape ShapeUtils.LShape) 32 | [ ( 0, 0 ), ( 1, 0 ), ( 2, 0 ), ( 2, 1 ) ] 33 | , clippedBlocksTest "Square" 34 | (ShapeUtils.getShape ShapeUtils.Square) 35 | [ ( 0, 0 ), ( 1, 0 ), ( 0, 1 ), ( 1, 1 ) ] 36 | ] 37 | ] 38 | 39 | 40 | allRotationTests : String -> ShapeUtils.ShapeType -> List Test 41 | allRotationTests shapeDescr shapeType = 42 | [ rotationTest (shapeDescr ++ " clockwise turn once") shapeType Shape.Clockwise 1 ShapeUtils.ClockwiseOrientation 43 | , rotationTest (shapeDescr ++ " clockwise turn twice") shapeType Shape.Clockwise 2 ShapeUtils.OneEightyOrientation 44 | , rotationTest (shapeDescr ++ " clockwise turn three times") shapeType Shape.Clockwise 3 ShapeUtils.AnticlockwiseOrientation 45 | , rotationTest (shapeDescr ++ " clockwise turn four times") shapeType Shape.Clockwise 4 ShapeUtils.InitialOrientation 46 | , rotationTest (shapeDescr ++ " anticlockwise turn once") shapeType Shape.Anticlockwise 1 ShapeUtils.AnticlockwiseOrientation 47 | , rotationTest (shapeDescr ++ " anticlockwise turn twice") shapeType Shape.Anticlockwise 2 ShapeUtils.OneEightyOrientation 48 | , rotationTest (shapeDescr ++ " anticlockwise turn three times") shapeType Shape.Anticlockwise 3 ShapeUtils.ClockwiseOrientation 49 | , rotationTest (shapeDescr ++ " anticlockwise turn four times") shapeType Shape.Anticlockwise 4 ShapeUtils.InitialOrientation 50 | ] 51 | 52 | 53 | rotationTest : String -> ShapeUtils.ShapeType -> Shape.RotationDirection -> Int -> ShapeUtils.Orientation -> Test 54 | rotationTest testDescr shapeType direction turns expectedOrientation = 55 | test testDescr <| 56 | \_ -> 57 | let 58 | expectedShape = 59 | ShapeUtils.getExpectedShape expectedOrientation shapeType 60 | in 61 | ShapeUtils.getShape shapeType 62 | |> rotateXTimes direction turns 63 | |> ShapeUtils.expectEquals expectedShape 64 | 65 | 66 | rotateXTimes : Shape.RotationDirection -> Int -> Shape -> Shape 67 | rotateXTimes direction turns shape = 68 | List.range 1 turns |> List.foldl (\_ shape_ -> Shape.rotate direction shape_) shape 69 | 70 | 71 | clippedBlocksTest : String -> Shape -> List Coord -> Test 72 | clippedBlocksTest testDescr shape expectedBlocks = 73 | test testDescr <| 74 | \_ -> 75 | shape 76 | |> Shape.clippedBlocks 77 | |> List.sort 78 | |> Expect.equal (List.sort expectedBlocks) 79 | -------------------------------------------------------------------------------- /tests/BoardTests.elm: -------------------------------------------------------------------------------- 1 | module BoardTests exposing (suite) 2 | 3 | {-| Tests for the Board module. Board is an opaque type so we can't construct it ourselves here, pre-populated in some 4 | way. Instead, we start off with an empty board, then build it up by appending cells to it. 5 | -} 6 | 7 | import AsciiGrid 8 | import Coord exposing (Coord) 9 | import Expect 10 | import GameBoard exposing (GameBoard) 11 | import Shape 12 | import Test exposing (Test, describe, test) 13 | 14 | 15 | suite : Test 16 | suite = 17 | describe "Board" 18 | [ describe "occupiedCells" <| 19 | [ occupiedCellsTest "Empty board" "" [] 20 | , occupiedCellsTest "Populated board" 21 | """ 22 | y----pp-yg- 23 | b---g-ro-b- 24 | """ 25 | [ -- First row 26 | ( ( 0, 0 ), Shape.Blue ) 27 | , ( ( 4, 0 ), Shape.Green ) 28 | , ( ( 6, 0 ), Shape.Red ) 29 | , ( ( 7, 0 ), Shape.Orange ) 30 | , ( ( 9, 0 ), Shape.Blue ) 31 | 32 | -- Second row 33 | , ( ( 0, 1 ), Shape.Yellow ) 34 | , ( ( 5, 1 ), Shape.Purple ) 35 | , ( ( 6, 1 ), Shape.Purple ) 36 | , ( ( 8, 1 ), Shape.Yellow ) 37 | , ( ( 9, 1 ), Shape.Green ) 38 | ] 39 | ] 40 | , describe "append" <| 41 | [ appendTest "Append straight line at bottom left of empty board" "" "yyyy" "yyyy" 42 | , appendTest "Append Z on bottom row of board with cells" """ 43 | r----oo-yg- 44 | r---b-pp-y- 45 | """ """ 46 | ---rr------ 47 | --rr------- 48 | """ """ 49 | r--rroo-yg- 50 | r-rrb-pp-y- 51 | """ 52 | ] 53 | , describe "areCellsAvailable" 54 | [ areCellsAvailableTest "Empty board" "" "xxxx" True 55 | , areCellsAvailableTest "Straight line into available space on bottom row" """ 56 | b----bb-yy- 57 | b----bbb-y- 58 | """ "-rrrr-----" True 59 | , areCellsAvailableTest "Straight line into unavailable space on bottom row" """ 60 | b----bb-yy- 61 | b-r--bbb-y- 62 | """ "-yyyy-----" False 63 | , areCellsAvailableTest "Straight line into available space on third row" """ 64 | y----y--bb- 65 | r----oo-pp- 66 | b-oorry-pp- 67 | r-oy-bbb-p- 68 | """ """ 69 | -rrrr----- 70 | ---------- 71 | ---------- 72 | """ True 73 | , areCellsAvailableTest "Straight line into unavailable space on third row" """ 74 | y----y--bb- 75 | r--r-oo-pp- 76 | b-oorry-pp- 77 | r-oy-bbb-p- 78 | """ """ 79 | -rrrr----- 80 | ---------- 81 | ---------- 82 | """ False 83 | ] 84 | ] 85 | 86 | 87 | occupiedCellsTest : String -> String -> List ( Coord, Shape.BlockColour ) -> Test 88 | occupiedCellsTest testDescr asciiBoard expectedOccupiedCells = 89 | test testDescr <| 90 | \_ -> 91 | buildBoard asciiBoard 92 | |> GameBoard.occupiedCells 93 | |> List.sortBy Tuple.first 94 | |> Expect.equal (expectedOccupiedCells |> List.sortBy Tuple.first) 95 | 96 | 97 | areCellsAvailableTest : String -> String -> String -> Bool -> Test 98 | areCellsAvailableTest testDescr asciiBoard asciiShape expectedAvailable = 99 | test testDescr <| 100 | \_ -> 101 | let 102 | shapeCoords = 103 | AsciiGrid.build asciiShape AsciiGrid.blockColourConfig |> List.map Tuple.first 104 | in 105 | buildBoard asciiBoard 106 | |> (\board -> GameBoard.areCellsAvailable board shapeCoords) 107 | |> Expect.equal expectedAvailable 108 | 109 | 110 | appendTest : String -> String -> String -> String -> Test 111 | appendTest testDescr orgBoard newBlocks expectedBoard = 112 | test testDescr <| 113 | \_ -> 114 | AsciiGrid.build newBlocks AsciiGrid.blockColourConfig 115 | |> List.foldl (\( coord, colour ) board -> GameBoard.append board colour [ coord ]) (buildBoard orgBoard) 116 | |> GameBoard.occupiedCells 117 | |> List.sortBy Tuple.first 118 | |> Expect.equal (buildBoard expectedBoard |> GameBoard.occupiedCells |> List.sortBy Tuple.first) 119 | 120 | 121 | {-| Builds a board from the supplied ASCII grid. The supplied grid doesn't need to be the full 10x20: just whatever 122 | portion contains occupied cells. 123 | -} 124 | buildBoard : String -> GameBoard 125 | buildBoard asciiBoard = 126 | AsciiGrid.build asciiBoard AsciiGrid.blockColourConfig 127 | |> List.foldl (\( coord, colour ) board -> GameBoard.append board colour [ coord ]) GameBoard.emptyBoard 128 | -------------------------------------------------------------------------------- /src/GameBoard.elm: -------------------------------------------------------------------------------- 1 | module GameBoard exposing 2 | ( GameBoard 3 | , append 4 | , areCellsAvailable 5 | , colCount 6 | , completedRows 7 | , emptyBoard 8 | , occupiedCells 9 | , removeRows 10 | , rowCount 11 | ) 12 | 13 | {-| This module contains functionality related to representing a board during gameplay. This is a 10x20 grid with cells, 14 | which can either be empty or have a block in them. Importantly, the board represents only _landed_ blocks: the shape 15 | which is currently dropping (and which is rendered onto the grid represented by the board), is _not_ part of the data in 16 | the board. 17 | -} 18 | 19 | import Array exposing (Array) 20 | import Coord exposing (Coord) 21 | import Shape 22 | 23 | 24 | {-| Represents the board. This is a 10x20 grid with cells, which can either be empty or have a block in them. 25 | Importantly, the board represents only _landed_ blocks: the shape which is currently dropping (and which is rendered 26 | onto the grid represented by the board), is _not_ part of the data in the board. 27 | -} 28 | type GameBoard 29 | = GameBoard (Array Row) 30 | 31 | 32 | {-| A cell in the board: either `Empty` or `Occupied`, in which case it has a colour associated with it. 33 | -} 34 | type Cell 35 | = Empty 36 | | Occupied Shape.BlockColour 37 | 38 | 39 | {-| A row in the grid. An alias for an array of `Cell`s. 40 | -} 41 | type alias Row = 42 | Array Cell 43 | 44 | 45 | emptyRow : Row 46 | emptyRow = 47 | Array.repeat colCount Empty 48 | 49 | 50 | {-| Gets the empty board to use at the start of the game. 51 | -} 52 | emptyBoard : GameBoard 53 | emptyBoard = 54 | GameBoard <| Array.repeat rowCount emptyRow 55 | 56 | 57 | {-| Gets a list of all the occupied cells in the supplied board. 58 | 59 | Returns a list of tuples, where the first value in the tuple is the block's coordinates, and the second value is its 60 | colour. 61 | 62 | -} 63 | occupiedCells : GameBoard -> List ( Coord, Shape.BlockColour ) 64 | occupiedCells (GameBoard board) = 65 | let 66 | rowPopulatedCells : Int -> Row -> List ( Coord, Shape.BlockColour ) 67 | rowPopulatedCells y row = 68 | row 69 | |> Array.indexedMap 70 | (\x cell -> 71 | case cell of 72 | Empty -> 73 | [] 74 | 75 | Occupied colour -> 76 | [ ( ( x, y ), colour ) ] 77 | ) 78 | |> Array.toList 79 | |> List.concat 80 | in 81 | board 82 | |> Array.indexedMap rowPopulatedCells 83 | |> Array.toList 84 | |> List.concat 85 | 86 | 87 | isEmptyCell : Cell -> Bool 88 | isEmptyCell cell = 89 | case cell of 90 | Empty -> 91 | True 92 | 93 | Occupied _ -> 94 | False 95 | 96 | 97 | isOccupiedCell : Cell -> Bool 98 | isOccupiedCell = 99 | isEmptyCell >> not 100 | 101 | 102 | {-| Checks whether all the supplied coordinates are free on the supplied board (and within its legal coordinates). 103 | -} 104 | areCellsAvailable : GameBoard -> List Coord -> Bool 105 | areCellsAvailable (GameBoard board) coords = 106 | let 107 | isCellFree : Coord -> Bool 108 | isCellFree ( x, y ) = 109 | Array.get y board 110 | |> Maybe.andThen (Array.get x) 111 | |> Maybe.map isEmptyCell 112 | |> Maybe.withDefault False 113 | in 114 | -- TODO: If there are multiple cells in the same row, this will get that row from the board's array multiple times: 115 | -- this could be optimised. Might increase code complexity, and optimisation will probably be negligible. Investigate. 116 | List.all (\( x, y ) -> x >= 0 && x < colCount && y >= 0 && y < rowCount && isCellFree ( x, y )) coords 117 | 118 | 119 | {-| Gets a list of the indexes of the completed rows, if any. 120 | -} 121 | completedRows : GameBoard -> List Int 122 | completedRows (GameBoard rows) = 123 | rows 124 | |> Array.indexedMap (\index row -> ( index, Array.toList row |> List.all isOccupiedCell )) 125 | |> Array.filter (\( _, isCompleted ) -> isCompleted) 126 | |> Array.map Tuple.first 127 | |> Array.toList 128 | 129 | 130 | {-| Removes the lines at the supplied indexes (adding new empty 131 | -} 132 | removeRows : GameBoard -> List Int -> GameBoard 133 | removeRows (GameBoard rows) indexes = 134 | let 135 | keptRows = 136 | Array.toIndexedList rows 137 | |> List.filterMap 138 | (\( index, row ) -> 139 | if not <| List.member index indexes then 140 | Just row 141 | 142 | else 143 | Nothing 144 | ) 145 | |> Array.fromList 146 | 147 | newEmptyRows = 148 | Array.repeat (List.length indexes) emptyRow 149 | in 150 | GameBoard <| Array.append keptRows newEmptyRows 151 | 152 | 153 | {-| Appends the supplied coordinates as occupied cells onto the supplied board. Note that this doesn't automatically 154 | removed any newly completed lines. 155 | -} 156 | append : GameBoard -> Shape.BlockColour -> List Coord -> GameBoard 157 | append (GameBoard board) colour coords = 158 | let 159 | appendCell : Coord -> Array Row -> Array Row 160 | appendCell ( x, y ) rows = 161 | -- Get the row 162 | Array.get y rows 163 | -- Set the cell in the row (and get back the updated row) 164 | |> Maybe.map (Array.set x (Occupied colour)) 165 | -- Set this new row in the board (an array of arrays) 166 | |> Maybe.map (\row -> Array.set y row rows) 167 | -- If any of the actions above failed, just return the originally supplied board. 168 | |> Maybe.withDefault rows 169 | in 170 | List.foldl appendCell board coords |> GameBoard 171 | 172 | 173 | {-| The number of rows in the board. 174 | -} 175 | rowCount : Int 176 | rowCount = 177 | 20 178 | 179 | 180 | {-| The number of columns in the board. 181 | -} 182 | colCount : Int 183 | colCount = 184 | 10 185 | -------------------------------------------------------------------------------- /src/Button.elm: -------------------------------------------------------------------------------- 1 | module Button exposing (Config, State(..), Style(..), button) 2 | 3 | {-| This module exposes functionality for showing buttons on the UI in a consistent way. elm-ui doesn't provide a built-in 4 | way to disable controls (without resorting to the HTML "escape-hatch") so instead this module provides buttons which, 5 | when disabled (or inaccessible, e.g. because they're under a modal dialog overlay) renders them not as buttons but as 6 | simple divs. This prevents "disabled" buttons having focus. It also removes any styling that should be inapplicable to 7 | such buttons, e.g. glow effects on hover. 8 | -} 9 | 10 | import Element exposing (Element) 11 | import Element.Background 12 | import Element.Border 13 | import Element.Font 14 | import Element.Input 15 | import UIHelpers 16 | 17 | 18 | {-| Defines the different styles of button shown in this game: 19 | 20 | - `MainScreen`: A button shown in one of the main screens (currently only the Welcome screen). Rounded, black 21 | background with grey text. 22 | - `ModalDialog`: A button shown on a modal dialog (e.g. the Save and Cancel buttons). 23 | 24 | -} 25 | type Style 26 | = MainScreen 27 | | ModalDialog 28 | 29 | 30 | {-| Describes the state of a button: 31 | 32 | - `Enabled`: The button is enabled and in a normal state. It can have effects like glowing when hovered over, etc. The 33 | data associated with this variant is the message to invoke when the button is clicked. 34 | - `Disabled`: The button is explicitly disabled, e.g. a modal dialog in an invalid state which has a Submit button 35 | which the user cannot click yet. This will have a lower opacity than an eanbled button, has no hover effects, and 36 | cannot be clicked by the user. 37 | - `Inaccessible`: The button isn't disabled, but cannot be clicked by the user for another reason, e.g. because there's 38 | a modal dialog overlaid above it. It looks the same as an enabled button, but cannot be clicked or have focus, and 39 | has no hover effects. 40 | 41 | -} 42 | type State msg 43 | = Enabled msg 44 | | Disabled 45 | | Inaccessible 46 | 47 | 48 | {-| The information required to configure a button so it can be rendered on the screen. 49 | -} 50 | type alias Config msg = 51 | { style : Style, caption : String, state : State msg } 52 | 53 | 54 | {-| Returns an elm-ui `Element` representing a button configured in the given way. 55 | -} 56 | button : Config msg -> Element msg 57 | button ({ style, caption, state } as config) = 58 | Element.el (commonAttrs style ++ stateBasedAttrs state style) <| buttonElement config 59 | 60 | 61 | {-| The element representing the button itself. Typically an actual elm-ui `Element.Input.button`, unless the button isn't 62 | enabled: in such cases a normal element is used instead (so it can't have focus or be clicked). 63 | -} 64 | buttonElement : Config msg -> Element msg 65 | buttonElement { style, caption, state } = 66 | let 67 | label = 68 | Element.el (labelAttrs style) <| Element.text caption 69 | in 70 | case state of 71 | Enabled msg -> 72 | Element.Input.button [] { onPress = Just msg, label = label } 73 | 74 | _ -> 75 | label 76 | 77 | 78 | {-| Attributes to apply to the label of the button. 79 | -} 80 | labelAttrs : Style -> List (Element.Attribute msg) 81 | labelAttrs style = 82 | case style of 83 | MainScreen -> 84 | [ Element.paddingEach { top = 5, right = 7, bottom = 7, left = 7 } ] 85 | 86 | ModalDialog -> 87 | [ Element.paddingXY 5 3 ] 88 | 89 | 90 | {-| Attributes to apply to the button regardless of its state. 91 | -} 92 | commonAttrs : Style -> List (Element.Attribute msg) 93 | commonAttrs style = 94 | case style of 95 | MainScreen -> 96 | [ Element.Font.color UIHelpers.mainForegroundColour 97 | , Element.Border.color UIHelpers.mainForegroundColour 98 | , Element.Border.width 2 99 | , Element.Border.rounded 20 100 | , Element.mouseOver [ Element.Border.glow (Element.rgb255 198 195 195) 2 ] 101 | ] 102 | 103 | ModalDialog -> 104 | [ Element.Font.color UIHelpers.mainBackgroundColour 105 | , Element.Border.width 1 106 | , Element.Border.rounded 8 107 | , Element.Font.size 14 108 | , Element.Font.semiBold 109 | , Element.paddingXY 2 1 110 | ] 111 | 112 | 113 | {-| Attributes to apply to the button, which depend on the state. 114 | -} 115 | stateBasedAttrs : State msg -> Style -> List (Element.Attribute msg) 116 | stateBasedAttrs state style = 117 | case ( style, state ) of 118 | ( MainScreen, Enabled _ ) -> 119 | [ Element.Background.color UIHelpers.mainBackgroundColour 120 | , Element.mouseOver [ Element.Border.glow mainScreenButtonGlowColour 2 ] 121 | ] 122 | 123 | ( MainScreen, Inaccessible ) -> 124 | [ Element.Background.color UIHelpers.mainBackgroundColour ] 125 | 126 | ( MainScreen, Disabled ) -> 127 | [ Element.Background.color <| withOpacity 0.3 UIHelpers.mainBackgroundColour ] 128 | 129 | ( ModalDialog, Enabled _ ) -> 130 | [ Element.Background.color modalButtonColour 131 | , Element.mouseOver [ Element.Border.glow mainScreenButtonGlowColour 1 ] 132 | ] 133 | 134 | ( ModalDialog, Inaccessible ) -> 135 | [ Element.Background.color modalButtonColour ] 136 | 137 | ( ModalDialog, Disabled ) -> 138 | [ Element.Background.color <| withOpacity 0.3 modalButtonColour ] 139 | 140 | 141 | {-| Returns a copy of the supplied colour, with the given opacity. 142 | -} 143 | withOpacity : Float -> Element.Color -> Element.Color 144 | withOpacity opacity colour = 145 | colour |> Element.toRgb |> (\rgb -> { rgb | alpha = opacity }) |> Element.fromRgb 146 | 147 | 148 | {-| The background colour of a button on a modal dialog (grey). 149 | -} 150 | modalButtonColour : Element.Color 151 | modalButtonColour = 152 | Element.rgb255 180 180 180 153 | 154 | 155 | {-| The colour which a button on the main screen glows when hovered over. 156 | -} 157 | mainScreenButtonGlowColour : Element.Color 158 | mainScreenButtonGlowColour = 159 | Element.rgb255 198 195 195 160 | -------------------------------------------------------------------------------- /tests/ShapeUtils.elm: -------------------------------------------------------------------------------- 1 | module ShapeUtils exposing (ExpectedShape, Orientation(..), ShapeType(..), expectEquals, getExpectedShape, getShape) 2 | 3 | import AsciiGrid 4 | import Coord exposing (Coord) 5 | import Dict 6 | import Expect exposing (Expectation) 7 | import Shape exposing (Shape) 8 | 9 | 10 | {-| The different shapes that can appear in the game. 11 | -} 12 | type ShapeType 13 | = LShape 14 | | LMirrorShape 15 | | ZShape 16 | | SShape 17 | | TShape 18 | | Square 19 | | Line 20 | 21 | 22 | {-| The four orientations a shape can be in when rotated. 23 | -} 24 | type Orientation 25 | = InitialOrientation 26 | | ClockwiseOrientation 27 | | AnticlockwiseOrientation 28 | | OneEightyOrientation 29 | 30 | 31 | {-| Defines a shape that we can test against, namely the coordinates of the blocks in the shape. 32 | -} 33 | type ExpectedShape 34 | = ExpectedShape (List Coord) 35 | 36 | 37 | {-| Gets a shape of the given type, when the given colour, in the initial orientation in which it will be shown in the 38 | game. 39 | -} 40 | getShape : ShapeType -> Shape 41 | getShape shapeType = 42 | -- Shape is an opaque type so we can't construct shapes ourselves here. Instead, we use the `allShapes` function 43 | -- and ask it to create all the shapes for us, then we look for the one that has the same blocks as those which we're 44 | -- trying to create. 45 | let 46 | blockCoords : List Coord 47 | blockCoords = 48 | shapeCoords InitialOrientation shapeType 49 | in 50 | Shape.allShapes 51 | |> (\( first, rest ) -> first :: rest) 52 | |> List.filter (\shape_ -> (Shape.data shape_ |> .blocks |> List.sort) == blockCoords) 53 | |> List.head 54 | -- Crash the test if shape not found - means a bug in the test code somewhere. 55 | |> (\maybeHead -> 56 | case maybeHead of 57 | Just head -> 58 | head 59 | 60 | Nothing -> 61 | Debug.todo "Invalid shape" 62 | ) 63 | 64 | 65 | {-| Gets an expected shape (shape data to test actual Shape values against), of the given type, colour and orientation. 66 | -} 67 | getExpectedShape : Orientation -> ShapeType -> ExpectedShape 68 | getExpectedShape orientation shapeType = 69 | ExpectedShape (shapeCoords orientation shapeType) 70 | 71 | 72 | {-| Gets a list of the coordinates of a shape of the given type, when at the given orientation. 73 | -} 74 | shapeCoords : Orientation -> ShapeType -> List Coord 75 | shapeCoords orientation shapeType = 76 | let 77 | asciiShape = 78 | toAsciiShapeTemplate shapeType 79 | |> toAsciiShape orientation 80 | in 81 | AsciiGrid.build asciiShape (Dict.fromList [ ( 'x', () ) ]) 82 | |> List.map Tuple.first 83 | 84 | 85 | {-| An expectation to be used in tests, which will ensure that the actual shape matches the expected shape. 86 | -} 87 | expectEquals : ExpectedShape -> Shape -> Expectation 88 | expectEquals (ExpectedShape expectedBlocks) actual = 89 | Shape.data actual |> .blocks |> List.sort |> Expect.equal expectedBlocks 90 | 91 | 92 | toAsciiShape : Orientation -> AsciiShapeTemplate -> String 93 | toAsciiShape orientation = 94 | case orientation of 95 | InitialOrientation -> 96 | .initial 97 | 98 | ClockwiseOrientation -> 99 | .clockwise 100 | 101 | AnticlockwiseOrientation -> 102 | .anticlockwise 103 | 104 | OneEightyOrientation -> 105 | .oneEighty 106 | 107 | 108 | toAsciiShapeTemplate : ShapeType -> AsciiShapeTemplate 109 | toAsciiShapeTemplate shapeType = 110 | case shapeType of 111 | LShape -> 112 | lShape 113 | 114 | LMirrorShape -> 115 | lMirrorShape 116 | 117 | ZShape -> 118 | zShape 119 | 120 | SShape -> 121 | sShape 122 | 123 | TShape -> 124 | tShape 125 | 126 | Square -> 127 | square 128 | 129 | Line -> 130 | line 131 | 132 | 133 | {-| A record containing ascii representations of a shape at its four possible orientations. 134 | -} 135 | type alias AsciiShapeTemplate = 136 | { initial : String, clockwise : String, anticlockwise : String, oneEighty : String } 137 | 138 | 139 | lShape : AsciiShapeTemplate 140 | lShape = 141 | { initial = """ 142 | --x 143 | xxx 144 | --- 145 | """ 146 | , clockwise = """ 147 | -x- 148 | -x- 149 | -xx 150 | """ 151 | , anticlockwise = """ 152 | xx- 153 | -x- 154 | -x- 155 | """ 156 | , oneEighty = """ 157 | --- 158 | xxx 159 | x-- 160 | """ 161 | } 162 | 163 | 164 | lMirrorShape : AsciiShapeTemplate 165 | lMirrorShape = 166 | { initial = """ 167 | x-- 168 | xxx 169 | --- 170 | """ 171 | , clockwise = """ 172 | -xx 173 | -x- 174 | -x- 175 | """ 176 | , anticlockwise = """ 177 | -x- 178 | -x- 179 | xx- 180 | """ 181 | , oneEighty = """ 182 | --- 183 | xxx 184 | --x 185 | """ 186 | } 187 | 188 | 189 | zShape : AsciiShapeTemplate 190 | zShape = 191 | { initial = """ 192 | xx- 193 | -xx 194 | --- 195 | """ 196 | , clockwise = """ 197 | --x 198 | -xx 199 | -x- 200 | """ 201 | , anticlockwise = """ 202 | -x- 203 | xx- 204 | x-- 205 | """ 206 | , oneEighty = """ 207 | --- 208 | xx- 209 | -xx 210 | """ 211 | } 212 | 213 | 214 | sShape : AsciiShapeTemplate 215 | sShape = 216 | { initial = """ 217 | -xx 218 | xx- 219 | --- 220 | """ 221 | , clockwise = """ 222 | -x- 223 | -xx 224 | --x 225 | """ 226 | , anticlockwise = """ 227 | x-- 228 | xx- 229 | -x- 230 | """ 231 | , oneEighty = """ 232 | --- 233 | -xx 234 | xx- 235 | """ 236 | } 237 | 238 | 239 | tShape : AsciiShapeTemplate 240 | tShape = 241 | { initial = """ 242 | -x- 243 | xxx 244 | --- 245 | """ 246 | , clockwise = """ 247 | -x- 248 | -xx 249 | -x- 250 | """ 251 | , anticlockwise = """ 252 | -x- 253 | xx- 254 | -x- 255 | """ 256 | , oneEighty = """ 257 | --- 258 | xxx 259 | -x- 260 | """ 261 | } 262 | 263 | 264 | square : AsciiShapeTemplate 265 | square = 266 | let 267 | squareBlocks = 268 | """ 269 | xx 270 | xx 271 | """ 272 | in 273 | { initial = squareBlocks 274 | , clockwise = squareBlocks 275 | , anticlockwise = squareBlocks 276 | , oneEighty = squareBlocks 277 | } 278 | 279 | 280 | line : AsciiShapeTemplate 281 | line = 282 | { initial = """ 283 | ---- 284 | xxxx 285 | ---- 286 | ---- 287 | """ 288 | , clockwise = """ 289 | --x- 290 | --x- 291 | --x- 292 | --x- 293 | """ 294 | , anticlockwise = """ 295 | -x-- 296 | -x-- 297 | -x-- 298 | -x-- 299 | """ 300 | , oneEighty = """ 301 | ---- 302 | ---- 303 | xxxx 304 | ---- 305 | """ 306 | } 307 | -------------------------------------------------------------------------------- /src/Modal.elm: -------------------------------------------------------------------------------- 1 | module Modal exposing (CloseButton(..), Config, CustomButton, SubmitButton(..), defaultConfig, dialog, subscriptions, withCustomButton) 2 | 3 | {-| This module provides the ability to show modal dialogs overlaid over the page. 4 | -} 5 | 6 | import Browser.Events 7 | import Button 8 | import Element exposing (Element) 9 | import Element.Background 10 | import Element.Border 11 | import Json.Decode as JD 12 | import UIHelpers 13 | 14 | 15 | {-| Defines the type of button used to dismiss the dialog. Currently the only difference between the two variants is the 16 | caption they result in. In future more differences in behaviour could be added (e.g. Cancel could prompt the user to see 17 | if they want to save their changes or not). 18 | -} 19 | type CloseButton msg 20 | = Cancel { onPress : msg } 21 | | Close { onPress : msg } 22 | 23 | 24 | {-| Defines the button the user should have to "submit" (i.e. save) the dialog, if applicable: 25 | 26 | - `None`: No such button should be shown. Typically used on dialogs that only show data, rather than let the user edit 27 | some data. 28 | - `Save`: A button with a "Save" caption should be shown. The `onPress` value defines the message to invoke when this 29 | button is pressed. If the value is `Nothing` then the button is "disabled" (see `Button` module for more info on this). 30 | 31 | -} 32 | type SubmitButton msg 33 | = None 34 | | Save { onPress : Maybe msg } 35 | 36 | 37 | {-| Defines a custom button to show, along with the Close/Cancel/Submit button. 38 | -} 39 | type alias CustomButton msg = 40 | { caption : String, onPress : Maybe msg } 41 | 42 | 43 | {-| Defines the information required to render a modal dialog, e.g. whether to show a Submit button, any custom buttons 44 | to show, etc. 45 | -} 46 | type alias Config msg = 47 | { closeButton : CloseButton msg, submitButton : SubmitButton msg, customButtons : List (CustomButton msg) } 48 | 49 | 50 | {-| The default configuration for modal dialogs. Defines that they should have a Cancel button with the given message, 51 | and a Save button with the given message (which might be Nothing if the button is currently disabled). Has no custom 52 | buttons. This can be used as a starting point for a config which can then be amended using some of the builder functions 53 | such as `withCustomButton`. 54 | -} 55 | defaultConfig : msg -> Maybe msg -> Config msg 56 | defaultConfig onCancel onSave = 57 | { closeButton = Cancel { onPress = onCancel }, submitButton = Save { onPress = onSave }, customButtons = [] } 58 | 59 | 60 | {-| Adds a custom button with the given details to the supplied config. 61 | -} 62 | withCustomButton : String -> Maybe msg -> Config msg -> Config msg 63 | withCustomButton caption onPress config = 64 | { config | customButtons = config.customButtons ++ [ { caption = caption, onPress = onPress } ] } 65 | 66 | 67 | {-| Renders a modal dialog based on the given config, and inside it puts the given `contents`. 68 | -} 69 | dialog : Config msg -> Element msg -> Element msg 70 | dialog { closeButton, submitButton, customButtons } contents = 71 | let 72 | customButtonElements = 73 | customButtons |> List.map (\{ caption, onPress } -> modalButton caption onPress) 74 | 75 | submitButtonElement = 76 | case submitButton of 77 | None -> 78 | [] 79 | 80 | Save { onPress } -> 81 | [ modalButton "OK" onPress ] 82 | 83 | cancelButtonElement = 84 | case closeButton of 85 | Cancel { onPress } -> 86 | [ modalButton "Cancel" (Just onPress) ] 87 | 88 | Close { onPress } -> 89 | [ modalButton "Close" (Just onPress) ] 90 | in 91 | Element.column 92 | [ Element.Background.color UIHelpers.mainBackgroundColour 93 | , Element.Border.color UIHelpers.mainForegroundColour 94 | , Element.Border.width 2 95 | , Element.centerX 96 | , Element.centerY 97 | , Element.padding 10 98 | , Element.spacingXY 0 20 99 | , Element.Border.rounded 10 100 | ] 101 | [ contents 102 | , Element.row [ Element.spacingXY 10 0, Element.centerX ] <| 103 | List.concat [ customButtonElements, submitButtonElement, cancelButtonElement ] 104 | ] 105 | |> modalMask 106 | 107 | 108 | modalButton : String -> Maybe msg -> Element msg 109 | modalButton caption onPress = 110 | let 111 | buttonState = 112 | case onPress of 113 | Just msg -> 114 | Button.Enabled msg 115 | 116 | Nothing -> 117 | Button.Disabled 118 | in 119 | Button.button { style = Button.ModalDialog, caption = caption, state = buttonState } 120 | 121 | 122 | {-| The full-screen semi-opaque "mask" overlaid on the page, on top of which the actual modal dialog is shown. 123 | -} 124 | modalMask : Element msg -> Element msg 125 | modalMask contents = 126 | Element.el 127 | [ Element.width Element.fill 128 | , Element.height Element.fill 129 | , Element.Background.color <| Element.rgba255 20 20 20 0.7 130 | , Element.Border.width 0 131 | , Element.inFront contents 132 | ] 133 | Element.none 134 | 135 | 136 | {-| The subscriptions to use for the modal dialog. Handles the user pressing the Enter or Escape keys to submit or cancel 137 | a modal dialog. 138 | -} 139 | subscriptions : Config msg -> Sub msg 140 | subscriptions { closeButton, submitButton } = 141 | -- TODO: there's a known issue that when the user presses the Enter key when a button has focus this can result in 142 | -- confusing behaviour. 143 | let 144 | onClose = 145 | case closeButton of 146 | Cancel { onPress } -> 147 | onPress 148 | 149 | Close { onPress } -> 150 | onPress 151 | 152 | onSubmit = 153 | case submitButton of 154 | None -> 155 | Nothing 156 | 157 | Save { onPress } -> 158 | onPress 159 | in 160 | escapeAndEnterKeyDecoder onClose onSubmit |> Browser.Events.onKeyDown 161 | 162 | 163 | escapeAndEnterKeyDecoder : msg -> Maybe msg -> JD.Decoder msg 164 | escapeAndEnterKeyDecoder onClose onSubmit = 165 | JD.field "key" JD.string 166 | |> JD.andThen 167 | (\key -> 168 | case ( key, onSubmit ) of 169 | ( "Escape", _ ) -> 170 | JD.succeed onClose 171 | 172 | ( "Enter", Just submit ) -> 173 | JD.succeed submit 174 | 175 | _ -> 176 | JD.fail "" 177 | ) 178 | -------------------------------------------------------------------------------- /src/HighlightAnimation.elm: -------------------------------------------------------------------------------- 1 | module HighlightAnimation exposing 2 | ( Id 3 | , Model 4 | , Msg 5 | , Type(..) 6 | , UpdateResult(..) 7 | , animatedBlocks 8 | , animatedColour 9 | , animatedOpacity 10 | , highlightAnimationType 11 | , initialId 12 | , isRowRemoval 13 | , nextAnimationId 14 | , startNewAnimation 15 | , subscriptions 16 | , update 17 | , withBlocks 18 | ) 19 | 20 | {-| This module controls animation of blocks, used when a dropping shape is about to land (which is animated by fading 21 | it out then back in) and when one or more rows are about to disappear (which is animated by "flashing" the row(s) 22 | briefly. 23 | -} 24 | 25 | import Browser.Events 26 | import Color exposing (Color) 27 | import Coord exposing (Coord) 28 | import Shape 29 | 30 | 31 | 32 | -- ANIMATION ID 33 | 34 | 35 | {-| A unique identifier of a given animation process. The animation model contains its current ID, and any messages also 36 | have this ID in their data. Then, when the (timer) event fires and is handled, we can check that the ID in the message 37 | matches what's in the model: if it doesn't it means that since the timer event was requested the model has been updated 38 | and either there's no longer any animation required, or there's a new animation, so the message can be ignored. 39 | 40 | This is an opaque type, and internally is managed as an incrementing integer. (It's highly unlikely that the upper 41 | limits of an Int will ever be hit, but if that does occur we can just go back to 0 at a certain point.) 42 | 43 | -} 44 | type Id 45 | = Id Int 46 | 47 | 48 | {-| The initial ID to use for the next animation. 49 | -} 50 | initialId : Id 51 | initialId = 52 | Id 0 53 | 54 | 55 | {-| The next animation ID to use after the supplied one. 56 | -} 57 | nextAnimationId : Id -> Id 58 | nextAnimationId (Id id) = 59 | Id <| id + 1 60 | 61 | 62 | 63 | -- MODEL TYPES 64 | 65 | 66 | {-| The type of animation: 67 | 68 | - `ShapeLanding`: a shape is about to land so is animated by fading it out then back in. 69 | - `RowRemoval`: one or more rows are about to be removed, so are animated by "flashing" them briefly. 70 | 71 | -} 72 | type Type 73 | = ShapeLanding 74 | | RowRemoval 75 | 76 | 77 | {-| The model containing the information about an animation: 78 | 79 | - `id`: The unique ID of this animation (see the `Id` type for more info). 80 | - `animationType`: The type of animation being executed (see the `Type` type for more info). 81 | - `totalTimeMs`: The total time, in milliseconds, which the animation should run for. 82 | - `blocks`: The blocks to be animated. 83 | - `progress`: The progress of the animation (see the `Progress` type for more info). 84 | 85 | -} 86 | type Model 87 | = Model 88 | { id : Id 89 | , animationType : Type 90 | , totalTimeMs : Float 91 | , blocks : List ( Coord, Shape.BlockColour ) 92 | , elapsedTimeMs : Float 93 | } 94 | 95 | 96 | 97 | -- UPDATE 98 | 99 | 100 | {-| The messages handled by this module: 101 | 102 | - `Frame`: An animation frame time has elapsed (i.e. the animation can increment its `percentComplete` then be re-rendered). 103 | 104 | -} 105 | type Msg 106 | = Frame { id : Id, timeSinceLastFrameMs : Float } 107 | 108 | 109 | {-| The result of the `update` function: 110 | 111 | - `IgnoreMsg`: The message was ignored. Typically this is because a message has arrived for an animation which is no 112 | longer the current one. 113 | - `Continue`: The animation has progressed but is still in progress. The updated model is returned in this variant's data. 114 | - `Complete`: The animation is now complete. The main module can now discard this animation. 115 | 116 | -} 117 | type UpdateResult 118 | = IgnoreMsg 119 | | Continue Model 120 | | Complete 121 | 122 | 123 | {-| Checks if the message relates to the animation in the supplied model and, if so, updates the model, and returns the 124 | relevant result (see `UpdateResult` for more info). 125 | -} 126 | update : Msg -> Model -> UpdateResult 127 | update (Frame { id, timeSinceLastFrameMs }) ((Model modelData) as model) = 128 | if id == modelData.id then 129 | handleAnimationFrame timeSinceLastFrameMs model 130 | 131 | else 132 | IgnoreMsg 133 | 134 | 135 | {-| Handles an animation frame time having elapsed. Calculates the new progress and either increments the `percentComplete` 136 | or, if this is now 100%, reports that this animation is now complete. 137 | -} 138 | handleAnimationFrame : Float -> Model -> UpdateResult 139 | handleAnimationFrame timeSinceLastFrameMs (Model modelData) = 140 | let 141 | newElapsedTimeMs = 142 | modelData.elapsedTimeMs + timeSinceLastFrameMs 143 | in 144 | if newElapsedTimeMs < modelData.totalTimeMs then 145 | Continue <| Model { modelData | elapsedTimeMs = newElapsedTimeMs } 146 | 147 | else 148 | Complete 149 | 150 | 151 | {-| Starts a new animation with the supplied data. 152 | -} 153 | startNewAnimation : Id -> Type -> Int -> List ( Coord, Shape.BlockColour ) -> Model 154 | startNewAnimation id animationType totalTimeMs blocks = 155 | Model 156 | { id = id 157 | , animationType = animationType 158 | , totalTimeMs = toFloat totalTimeMs 159 | , blocks = blocks 160 | , elapsedTimeMs = 0 161 | } 162 | 163 | 164 | {-| Returns an updated copy of the supplied model, with the supplied blocks in it. 165 | -} 166 | withBlocks : List ( Coord, Shape.BlockColour ) -> Model -> Model 167 | withBlocks blocks (Model model) = 168 | Model { model | blocks = blocks } 169 | 170 | 171 | 172 | -- INFORMATION ABOUT THE MODEL 173 | 174 | 175 | {-| Gets the type of animation which the supplied model has. 176 | -} 177 | highlightAnimationType : Model -> Type 178 | highlightAnimationType (Model { animationType }) = 179 | animationType 180 | 181 | 182 | {-| Gets a boolean indicating whether the type of the supplied animation is `RowRemoval`. 183 | -} 184 | isRowRemoval : Model -> Bool 185 | isRowRemoval (Model { animationType }) = 186 | case animationType of 187 | ShapeLanding -> 188 | False 189 | 190 | RowRemoval -> 191 | True 192 | 193 | 194 | {-| Gets the blocks contained in the supplied model. 195 | -} 196 | animatedBlocks : Model -> List ( Coord, Shape.BlockColour ) 197 | animatedBlocks (Model { blocks }) = 198 | blocks 199 | 200 | 201 | {-| Calculates the opacity to use when rendering a highlighted cell with the given animation model. 202 | -} 203 | animatedOpacity : Model -> Float 204 | animatedOpacity (Model { animationType, elapsedTimeMs, totalTimeMs }) = 205 | case animationType of 206 | ShapeLanding -> 207 | let 208 | percentComplete = 209 | 100 * elapsedTimeMs / totalTimeMs 210 | in 211 | if percentComplete < 50 then 212 | -- Reduce the opacity to nearly (but not quite) 0 213 | 1 - (0.9 * percentComplete / 50) 214 | 215 | else 216 | -- Increase the opacity back towards 1 217 | 1 - (0.9 * ((100 - percentComplete) / 50)) 218 | 219 | RowRemoval -> 220 | -- We don't change the opacity in this animation type 221 | 1 222 | 223 | 224 | {-| Calculates the colour to use when rendering the supplied colour using the supplied animation. Returns a lighter or 225 | darker version of that colour based on the type and progress of the animation. 226 | -} 227 | animatedColour : Model -> Color -> Color 228 | animatedColour (Model { animationType, elapsedTimeMs, totalTimeMs }) colour = 229 | case animationType of 230 | ShapeLanding -> 231 | -- We don't change the colour in this animation type 232 | colour 233 | 234 | RowRemoval -> 235 | -- Brighten towards one for the full length of the animation, to make it "flash" 236 | let 237 | calcColourPart part = 238 | part + ((1 - part) * elapsedTimeMs / totalTimeMs) 239 | in 240 | Color.toRgba colour 241 | |> (\{ red, green, blue, alpha } -> 242 | { red = calcColourPart red 243 | , green = calcColourPart green 244 | , blue = calcColourPart blue 245 | , alpha = alpha 246 | } 247 | ) 248 | |> Color.fromRgba 249 | 250 | 251 | 252 | -- SUBSCRIPTIONS 253 | 254 | 255 | {-| Gets the subscriptions required for the animation to run. 256 | -} 257 | subscriptions : Model -> Sub Msg 258 | subscriptions (Model { id }) = 259 | Browser.Events.onAnimationFrameDelta 260 | (\timeSinceLastFrameMs -> Frame { id = id, timeSinceLastFrameMs = timeSinceLastFrameMs }) 261 | -------------------------------------------------------------------------------- /src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (main) 2 | 3 | {-| This is the main module of the application. It delegates control to a number of submodules and handles transitioning 4 | between them. The main modules are: 5 | 6 | - `WelcomeScreen`: used when the value of this module's model is `Welcome`. Shows the Welcome screen to the user. 7 | - `UserGame`: used when the value of this module's model is `Playing`. Shows the actual game. 8 | - `GameOver`: used when the value of this module's model is `GameOver`. Shows the "Game Over" message to the user for 9 | a few seconds then moves back to the Welcome screen. 10 | 11 | -} 12 | 13 | import Browser 14 | import Element exposing (Element) 15 | import Element.Background 16 | import GameOver 17 | import HighScores exposing (HighScores) 18 | import Html exposing (Html) 19 | import Json.Encode as JE 20 | import Settings exposing (Settings) 21 | import UIHelpers exposing (edges) 22 | import UserGame 23 | import WelcomeScreen 24 | 25 | 26 | 27 | -- MAIN 28 | 29 | 30 | main = 31 | Browser.element 32 | { init = init 33 | , view = view 34 | , update = update 35 | , subscriptions = subscriptions 36 | } 37 | 38 | 39 | {-| The flags passed into the application from the hosting JS. Contains the `settings` (which define such things as the 40 | key bindings, and the stored high scores). 41 | -} 42 | type alias Flags = 43 | { settings : JE.Value, highScores : JE.Value } 44 | 45 | 46 | init : Flags -> ( Model, Cmd Msg ) 47 | init { settings, highScores } = 48 | initAtWelcomeScreen (Settings.fromJson settings) (HighScores.fromJson highScores) Cmd.none 49 | 50 | 51 | {-| Initialises the model at the welcome screen. Used when the site is first loaded, and at the end of a game (after the 52 | "Game Over" animation. 53 | -} 54 | initAtWelcomeScreen : Settings -> HighScores -> Cmd Msg -> ( Model, Cmd Msg ) 55 | initAtWelcomeScreen settings highScores cmd = 56 | let 57 | ( subModel, subCmd ) = 58 | WelcomeScreen.init settings highScores 59 | in 60 | ( Welcome { model = subModel } 61 | , Cmd.batch [ cmd, Cmd.map GotWelcomeScreenMsg subCmd ] 62 | ) 63 | 64 | 65 | 66 | -- MODEL 67 | 68 | 69 | {-| The model for this app. There is some state which is persisted in local storage (namely the high scores and settings). 70 | This is read in at the start of the app, then retained in memory thereafter for the duration of the app. In order to retain 71 | it, we keep that data against every variant below as a separate field (and don't pass it into the models of the variants 72 | that don't need that data). For variants whose associated model _does_ need access to that data, the variant's model 73 | (e.g. `WelcomeScreen.Model`) stores it, and we then don't store it as a separate field. 74 | -} 75 | type Model 76 | = Welcome { model : WelcomeScreen.Model } -- No game being played - showing the user some welcome/introductory info. 77 | | Playing { model : UserGame.Model, highScores : HighScores } -- Game is currently being played 78 | | GameOver { model : GameOver.Model, settings : Settings } -- Game has ended 79 | 80 | 81 | type Msg 82 | = GotWelcomeScreenMsg WelcomeScreen.Msg 83 | | GotPlayingGameMsg UserGame.Msg 84 | | GotGameOverMsg GameOver.Msg 85 | 86 | 87 | 88 | -- UPDATE 89 | 90 | 91 | update : Msg -> Model -> ( Model, Cmd Msg ) 92 | update msg model = 93 | case ( model, msg ) of 94 | ( Welcome welcome, GotWelcomeScreenMsg welcomeMsg ) -> 95 | handleWelcomeScreenMsg welcomeMsg welcome 96 | 97 | ( _, GotWelcomeScreenMsg _ ) -> 98 | ( model, Cmd.none ) 99 | 100 | ( Playing playing, GotPlayingGameMsg playingMsg ) -> 101 | handlePlayingGameMsg playingMsg playing 102 | 103 | ( _, GotPlayingGameMsg _ ) -> 104 | ( model, Cmd.none ) 105 | 106 | ( GameOver gameOver, GotGameOverMsg gameOverMsg ) -> 107 | handleGameOverMsg gameOverMsg gameOver 108 | 109 | ( _, GotGameOverMsg _ ) -> 110 | ( model, Cmd.none ) 111 | 112 | 113 | handleWelcomeScreenMsg : WelcomeScreen.Msg -> { model : WelcomeScreen.Model } -> ( Model, Cmd Msg ) 114 | handleWelcomeScreenMsg welcomeMsg welcome = 115 | let 116 | ( welcomeModel, welcomeCmd, welcomeUpdateResult ) = 117 | WelcomeScreen.update welcomeMsg welcome.model 118 | in 119 | case welcomeUpdateResult of 120 | WelcomeScreen.Stay -> 121 | ( Welcome { welcome | model = welcomeModel } 122 | , Cmd.map GotWelcomeScreenMsg welcomeCmd 123 | ) 124 | 125 | WelcomeScreen.StartGame -> 126 | WelcomeScreen.getSettings welcomeModel 127 | |> UserGame.init 128 | |> (\( gameModel, gameCmd ) -> 129 | ( Playing { model = gameModel, highScores = WelcomeScreen.getHighScores welcomeModel } 130 | , Cmd.map GotPlayingGameMsg gameCmd 131 | ) 132 | ) 133 | 134 | 135 | handlePlayingGameMsg : UserGame.Msg -> { model : UserGame.Model, highScores : HighScores } -> ( Model, Cmd Msg ) 136 | handlePlayingGameMsg gameMsg playing = 137 | case UserGame.update gameMsg playing.model of 138 | UserGame.Continue ( subModel, subCmd ) -> 139 | ( Playing { playing | model = subModel } 140 | , Cmd.map GotPlayingGameMsg subCmd 141 | ) 142 | 143 | UserGame.GameOver game -> 144 | ( GameOver { model = GameOver.init playing.highScores game, settings = UserGame.getSettings playing.model } 145 | , Cmd.none 146 | ) 147 | 148 | 149 | handleGameOverMsg : GameOver.Msg -> { model : GameOver.Model, settings : Settings } -> ( Model, Cmd Msg ) 150 | handleGameOverMsg gameOverMsg gameOver = 151 | case GameOver.update gameOverMsg gameOver.model of 152 | GameOver.Continue ( subModel, subCmd ) -> 153 | ( GameOver { gameOver | model = subModel }, Cmd.map GotGameOverMsg subCmd ) 154 | 155 | GameOver.Done ( subModel, subCmd ) -> 156 | initAtWelcomeScreen gameOver.settings (GameOver.getHighScores subModel) <| Cmd.map GotGameOverMsg subCmd 157 | 158 | 159 | 160 | -- VIEW 161 | 162 | 163 | view : Model -> Html Msg 164 | view model = 165 | let 166 | contents : Element Msg 167 | contents = 168 | case model of 169 | Welcome welcome -> 170 | WelcomeScreen.view welcome.model |> Element.map GotWelcomeScreenMsg 171 | 172 | Playing playing -> 173 | UserGame.view playing.model |> Element.map GotPlayingGameMsg |> wrapBoardView 174 | 175 | GameOver gameOver -> 176 | -- TODO: the below assumes there are no highlighted blocks when the game ends, but the type system doesn't 177 | -- currently guarantee that (Game.handleDroppingShapeLanded can result in GameOver even when its state is 178 | -- RowRemovalGameState, even though it's not currently ever called like that). Revisit maybe. 179 | GameOver.view gameOver.model |> Element.map GotGameOverMsg |> wrapBoardView 180 | in 181 | Element.layoutWith 182 | { options = 183 | [ Element.focusStyle 184 | { borderColor = Just UIHelpers.mainForegroundColour 185 | , backgroundColor = Nothing 186 | , shadow = 187 | Just 188 | { color = Element.rgba255 198 195 195 0.6 189 | , offset = ( 0, 0 ) 190 | , blur = 3 191 | , size = 2 192 | } 193 | } 194 | ] 195 | } 196 | [ Element.width Element.fill 197 | , Element.height Element.fill 198 | , Element.Background.color UIHelpers.mainBackgroundColour 199 | , Element.scrollbarY 200 | , Element.inFront <| 201 | Element.link [ Element.alignBottom, Element.alignRight, Element.padding 20 ] 202 | { url = "https://github.com/yonigibbs/yaet" 203 | , label = 204 | Element.image [] 205 | { src = "./github.png", description = "Source code on GitHub" } 206 | } 207 | ] 208 | contents 209 | 210 | 211 | wrapBoardView : Element msg -> Element msg 212 | wrapBoardView boardView = 213 | Element.el 214 | [ Element.centerX 215 | , Element.paddingEach { edges | top = 25 } 216 | , Element.height Element.fill 217 | , Element.width Element.fill 218 | ] 219 | boardView 220 | 221 | 222 | subscriptions : Model -> Sub Msg 223 | subscriptions model = 224 | case model of 225 | Welcome welcome -> 226 | WelcomeScreen.subscriptions welcome.model |> Sub.map GotWelcomeScreenMsg 227 | 228 | Playing playing -> 229 | UserGame.subscriptions playing.model |> Sub.map GotPlayingGameMsg 230 | 231 | GameOver gameOver -> 232 | GameOver.subscriptions gameOver.model |> Sub.map GotGameOverMsg 233 | -------------------------------------------------------------------------------- /src/UserGameControl.elm: -------------------------------------------------------------------------------- 1 | module UserGameControl exposing (Model, Msg, init, subscriptions, update) 2 | 3 | {-| This module is responsible for handling user-initiated actions. Its model stores which keys are currently being 4 | held down, and it calculates, based on that, which actions to run. For example if a user holds down the left arrow and the 5 | down arrow, this is responsible for deciding that the dropping shape should be moved left and down. BUt if the user then 6 | additionally presses the right arrow, this module decides that the (newer) right arrow press should override the left 7 | arrow one, and move the shape right instead. 8 | 9 | It's also responsible for handling how quickly to respond to key presses. An initial keypress is responded to immediately, 10 | and if the key is held down then it should be executed repeatedly at a given interval till the key is released. However 11 | there should be an initial delay after the key is first held down, before it's then acted on again (after which there 12 | should be no further delay). In order to handle this, we use the concept of a "keyboard frame". This is similar to an 13 | animation frame: it's a repeated timer event that occurs while a key is being pressed, at a regular interval, which, 14 | every time it occurs, means that the keyboard press should be processed again. 15 | 16 | -} 17 | 18 | import Browser.Events 19 | import Game 20 | import Json.Decode as JD 21 | import Settings exposing (Settings) 22 | import Shape 23 | import Time 24 | 25 | 26 | 27 | -- MODEL 28 | 29 | 30 | {-| A request for an action to be executed. Created when a user holds down a keyboard key, for example. 31 | 32 | - `action`: The action being requested (e.g. move shape left). 33 | - `delayTillRepeat`: Defines how many "keyboard frames" (see comments on this module) the system should wait before 34 | repeating this action. When a new `ActionRequest` is created (e.g. when a user initially presses down a key) this 35 | is set to some value (e.g. 4), and the action is executed immediately. The system then uses `Time.every` to initiate 36 | a message every so often (e.g. 50ms): every time one of these messages fires, if the key is still being held down, 37 | we decrease the value in `delayTillRepeat`. Once it's at zero, we stop decreasing it, and instead start repeatedly 38 | executing the action. This means that when the user holds down a key the action is executed immediately, then there's 39 | a short pause, before it starts being executed repeatedly (i.e. it's debounced). 40 | 41 | -} 42 | type alias ActionRequest = 43 | { action : Game.UserAction, delayTillRepeat : Int } 44 | 45 | 46 | {-| The data associated with the model, which is exposed as an opaque type 47 | 48 | - `settings`: The settings, which provide access to things like the key bindings. 49 | - `requests`: A list of requests for actions to be executed, generally corresponding to all the keys currently being 50 | held down. This list is in order, with the most recent presses first, so that they override older presses (e.g. if 51 | user holds down left arrow then right arrow, we ignore the left arrow and move the shape right). 52 | 53 | -} 54 | type alias ModelData = 55 | { settings : Settings, requests : List ActionRequest } 56 | 57 | 58 | type Model 59 | = Model ModelData 60 | 61 | 62 | init : Settings -> Model 63 | init settings = 64 | Model { settings = settings, requests = [] } 65 | 66 | 67 | 68 | -- UPDATE 69 | 70 | 71 | type Msg 72 | = ActionRequestStarted Game.UserAction -- An action is being requested, e.g. the user has just pressed a key. 73 | | ActionRequestStopped Game.UserAction -- An action is no longer being requested, e.g. the user has released a key. 74 | | KeyboardFrame -- See comments on this module. 75 | 76 | 77 | {-| Handles a message in this module. Returns an updated `Model`, along with a list of the actions that should be executed. 78 | -} 79 | update : Model -> Msg -> ( Model, List Game.UserAction ) 80 | update ((Model modelData) as model) msg = 81 | case msg of 82 | ActionRequestStarted action -> 83 | if List.any (\request -> request.action == action) modelData.requests then 84 | -- This action was already requested (e.g. key already pressed) - ignore this request 85 | ( model, [] ) 86 | 87 | else 88 | -- Append the new request at the _beginning_ of the list, and request that this action be executed immediately. 89 | ( model |> addNewRequest action, [ action ] ) 90 | 91 | ActionRequestStopped action -> 92 | -- Remove this request from the list, and don't request that any action be run immediately. 93 | ( model |> removeRequest action, [] ) 94 | 95 | KeyboardFrame -> 96 | handleKeyboardFrame model 97 | 98 | 99 | addNewRequest : Game.UserAction -> Model -> Model 100 | addNewRequest action (Model modelData) = 101 | -- By default we set `delayTillRepeat` till 4 to ensure that if the user holds this key down we don't immediately 102 | -- start executing it every keyboard frame. However, say the user is holding down the down arrow and a piece is 103 | -- moving down the board. And say on that journey down there's a single gap on the right. If the user then also 104 | -- presses the right arrow he means for the piece to slide into that gap when possible. If that happens to be while 105 | -- waiting for the 4 keyboard frames to elapse, he'll miss that gap. So in that case we don't apply this delay. 106 | let 107 | delayTillRepeat = 108 | if 109 | (isMoveAction Game.Left action || isMoveAction Game.Right action) 110 | && List.any (.action >> isMoveAction Game.Down) modelData.requests 111 | then 112 | 0 113 | 114 | else 115 | 4 116 | in 117 | Model { modelData | requests = { action = action, delayTillRepeat = delayTillRepeat } :: modelData.requests } 118 | 119 | 120 | isMoveAction : Game.MoveDirection -> Game.UserAction -> Bool 121 | isMoveAction direction action = 122 | case action of 123 | Game.Move direction_ -> 124 | direction_ == direction 125 | 126 | _ -> 127 | False 128 | 129 | 130 | removeRequest : Game.UserAction -> Model -> Model 131 | removeRequest action (Model modelData) = 132 | let 133 | requests = 134 | modelData.requests |> List.filter (\listItem -> listItem.action /= action) 135 | in 136 | Model { modelData | requests = requests } 137 | 138 | 139 | {-| Handles a keyboard frame (see comments on this module). For every action currently being requested, this checks if the 140 | action is still quite new (e.g. the user only recently pressed the key): if it is (i.e. if its `delayTillRepeat` value is 141 | greater than zero), it decrements that value, otherwise it treats it as an action ready to run. It then calculates which 142 | actions to run (e.g. handling conflicting actions like if the user presses both the left and right keys) and returns this 143 | in the second value in the returned tuple. 144 | -} 145 | handleKeyboardFrame : Model -> ( Model, List Game.UserAction ) 146 | handleKeyboardFrame (Model modelData) = 147 | let 148 | requests : List ActionRequest 149 | requests = 150 | modelData.requests 151 | |> List.map 152 | (\action -> 153 | if action.delayTillRepeat > 0 then 154 | { action | delayTillRepeat = action.delayTillRepeat - 1 } 155 | 156 | else 157 | action 158 | ) 159 | 160 | actionsToExecute : List Game.UserAction 161 | actionsToExecute = 162 | requests |> removeNonRepeatableActions |> removeConflicts |> removeInactive |> List.map .action 163 | in 164 | ( Model { modelData | requests = requests }, actionsToExecute ) 165 | 166 | 167 | {-| Some actions are "repeatable" (e.g. if the user holds down the left arrow we want to repeatedly move the shape left). 168 | Others, e.g. rotating a shape, aren't. This function removes the non-repeatable ones. 169 | -} 170 | removeNonRepeatableActions : List ActionRequest -> List ActionRequest 171 | removeNonRepeatableActions = 172 | List.filter 173 | (\{ action } -> 174 | case action of 175 | Game.HardDrop -> 176 | False 177 | 178 | Game.Rotate _ -> 179 | False 180 | 181 | Game.Hold -> 182 | False 183 | 184 | Game.TogglePause -> 185 | False 186 | 187 | Game.Move _ -> 188 | True 189 | ) 190 | 191 | 192 | removeInactive : List ActionRequest -> List ActionRequest 193 | removeInactive = 194 | List.filter (\request -> request.delayTillRepeat == 0) 195 | 196 | 197 | removeConflicts : List ActionRequest -> List ActionRequest 198 | removeConflicts requests = 199 | requests 200 | |> List.foldl 201 | (\request { exclude, keep } -> 202 | if List.member request.action exclude then 203 | { exclude = exclude, keep = keep } 204 | 205 | else 206 | { exclude = exclude ++ conflictsOf request.action, keep = request :: keep } 207 | ) 208 | { exclude = [], keep = [] } 209 | |> (\{ exclude, keep } -> keep) 210 | 211 | 212 | {-| Gets all possible actions that conflict with the supplied `action`, e.g. right and left keys conflict. 213 | -} 214 | conflictsOf : Game.UserAction -> List Game.UserAction 215 | conflictsOf action = 216 | case action of 217 | Game.Move Game.Left -> 218 | [ Game.Move Game.Right ] 219 | 220 | Game.Move Game.Right -> 221 | [ Game.Move Game.Left ] 222 | 223 | Game.Move Game.Down -> 224 | [] 225 | 226 | Game.HardDrop -> 227 | [ Game.Move Game.Left 228 | , Game.Move Game.Right 229 | , Game.Move Game.Down 230 | , Game.Rotate Shape.Clockwise 231 | , Game.Rotate Shape.Anticlockwise 232 | ] 233 | 234 | Game.Rotate Shape.Clockwise -> 235 | [ Game.Rotate Shape.Anticlockwise ] 236 | 237 | Game.Rotate Shape.Anticlockwise -> 238 | [ Game.Rotate Shape.Clockwise ] 239 | 240 | Game.Hold -> 241 | [ Game.Move Game.Left 242 | , Game.Move Game.Right 243 | , Game.Move Game.Down 244 | , Game.Rotate Shape.Clockwise 245 | , Game.Rotate Shape.Anticlockwise 246 | , Game.HardDrop 247 | ] 248 | 249 | Game.TogglePause -> 250 | [ Game.Move Game.Left 251 | , Game.Move Game.Right 252 | , Game.Move Game.Down 253 | , Game.Rotate Shape.Clockwise 254 | , Game.Rotate Shape.Anticlockwise 255 | , Game.HardDrop 256 | , Game.Hold 257 | ] 258 | 259 | 260 | 261 | -- SUBSCRIPTIONS 262 | 263 | 264 | subscriptions : Model -> Sub Msg 265 | subscriptions (Model { settings, requests }) = 266 | let 267 | keyboardFrameSub = 268 | case requests of 269 | [] -> 270 | Sub.none 271 | 272 | _ -> 273 | -- TODO: is this delay the right value here? 274 | Time.every 50 <| always KeyboardFrame 275 | in 276 | Sub.batch 277 | [ Settings.keyboardDecoder settings |> JD.map ActionRequestStarted |> Browser.Events.onKeyDown 278 | , Settings.keyboardDecoder settings |> JD.map ActionRequestStopped |> Browser.Events.onKeyUp 279 | , keyboardFrameSub 280 | ] 281 | -------------------------------------------------------------------------------- /src/Shape.elm: -------------------------------------------------------------------------------- 1 | module Shape exposing 2 | ( Bag 3 | , BlockColour(..) 4 | , RotationDirection(..) 5 | , Shape 6 | , allColours 7 | , allShapes 8 | , clippedBlocks 9 | , createShapeBag 10 | , data 11 | , next 12 | , rotate 13 | , withOrgRotation 14 | ) 15 | 16 | {-| A shape represents a set of four contiguous blocks currently falling from the top of the board to the bottom. Once 17 | it lands, the blocks that make up that shape become part of the board itself, and are no longer represented by a shape. 18 | 19 | A shape is conceptually defined as a grid of some size (whatever size is required to fit the shape in fully, in every 20 | possible rotation), containing the coordinates of 4 contiguous blocks within that grid, placed roughly around the middle 21 | (as close as possible). The shapes can be rotated: this is done by conceptually turning the whole grid on its side 22 | around its centre point. 23 | 24 | For example, the straight line shape requires a 4x4 grid, and would initially be defined as follows: 25 | 26 | +---+---+---+---+ 27 | | | | | | 28 | +---+---+---+---+ 29 | | X | X | X | X | 30 | +---+---+---+---+ 31 | | | | | | 32 | +---+---+---+---+ 33 | | | | | | 34 | +---+---+---+---+ 35 | 36 | When rotated clockwise, this would become: 37 | 38 | +---+---+---+---+ 39 | | | | X | | 40 | +---+---+---+---+ 41 | | | | X | | 42 | +---+---+---+---+ 43 | | | | X | | 44 | +---+---+---+---+ 45 | | | | X | | 46 | +---+---+---+---+ 47 | 48 | In the example of the T-shape, it only requires a 3x3 grid: 49 | 50 | +---+---+---+ 51 | | | X | | 52 | +---+---+---+ 53 | | X | X | X | 54 | +---+---+---+ 55 | | | | | 56 | +---+---+---+ 57 | 58 | When this is rotated clockwise it becomes the following: 59 | 60 | +---+---+---+ 61 | | | X | | 62 | +---+---+---+ 63 | | | X | X | 64 | +---+---+---+ 65 | | | X | | 66 | +---+---+---+ 67 | 68 | The data in the shape is simply the coordinates of the 4 cells which are filled. The x- and y-axes run along the bottom 69 | and up the left of the grid, and coordinates indexes are 0-based. The way the shapes are initially generated, is such 70 | that the top of the shape's grid should be at the top of board when that shape is first added to the game. 71 | 72 | -} 73 | 74 | import Coord exposing (Coord) 75 | import Random 76 | import Random.List 77 | 78 | 79 | {-| The colour of a block which forms part of a shape and eventually part of the board, when it lands. 80 | -} 81 | type BlockColour 82 | = Cyan 83 | | Blue 84 | | Orange 85 | | Yellow 86 | | Green 87 | | Purple 88 | | Red 89 | 90 | 91 | {-| All colours used in the shapes. 92 | -} 93 | allColours : List BlockColour 94 | allColours = 95 | [ Cyan, Blue, Orange, Yellow, Green, Purple, Red ] 96 | 97 | 98 | {-| A shape currently in the process of dropping down the board. 99 | -} 100 | type Shape 101 | = Shape ShapeData 102 | 103 | 104 | {-| The data associated with a `Shape`. 105 | -} 106 | type alias ShapeData = 107 | { gridSize : Int, blocks : List Coord, colour : BlockColour, orgBlocks : List Coord } 108 | 109 | 110 | {-| The direction in which a shape can be rotated. 111 | -} 112 | type RotationDirection 113 | = Clockwise 114 | | Anticlockwise 115 | 116 | 117 | {-| Gets the data associated with the passed in shape. 118 | -} 119 | data : Shape -> { gridSize : Int, blocks : List Coord, colour : BlockColour } 120 | data (Shape { gridSize, blocks, colour }) = 121 | { gridSize = gridSize, blocks = blocks, colour = colour } 122 | 123 | 124 | {-| All the shapes used in the game. Returned as a tuple to represent a "non-empty list" rather than just a normal list, 125 | as this is required in a few places. 126 | -} 127 | allShapes : ( Shape, List Shape ) 128 | allShapes = 129 | -- Straight line (initially horizontal) 130 | ( createShape { gridSize = 4, blocks = [ ( 0, 2 ), ( 1, 2 ), ( 2, 2 ), ( 3, 2 ) ], colour = Cyan } 131 | , List.map 132 | createShape 133 | [ -- L-shape on its back: 134 | -- x 135 | -- x x x 136 | { gridSize = 3, blocks = [ ( 0, 1 ), ( 1, 1 ), ( 2, 1 ), ( 2, 2 ) ], colour = Orange } 137 | , -- Mirror image of the above: 138 | -- x 139 | -- x x x 140 | { gridSize = 3, blocks = [ ( 0, 2 ), ( 0, 1 ), ( 1, 1 ), ( 2, 1 ) ], colour = Blue } 141 | , -- T-shape: 142 | -- x 143 | -- x x x 144 | { gridSize = 3, blocks = [ ( 0, 1 ), ( 1, 1 ), ( 1, 2 ), ( 2, 1 ) ], colour = Purple } 145 | , -- Z-shape: 146 | -- x x 147 | -- x x 148 | { gridSize = 3, blocks = [ ( 0, 2 ), ( 1, 2 ), ( 1, 1 ), ( 2, 1 ) ], colour = Red } 149 | , -- S-shape (mirror image of the above): 150 | -- x x 151 | -- x x 152 | { gridSize = 3, blocks = [ ( 0, 1 ), ( 1, 1 ), ( 1, 2 ), ( 2, 2 ) ], colour = Green } 153 | , -- Square: 154 | -- x x 155 | -- x x 156 | { gridSize = 2, blocks = [ ( 0, 0 ), ( 0, 1 ), ( 1, 0 ), ( 1, 1 ) ], colour = Yellow } 157 | ] 158 | ) 159 | 160 | 161 | createShape : { gridSize : Int, blocks : List Coord, colour : BlockColour } -> Shape 162 | createShape { gridSize, blocks, colour } = 163 | Shape { gridSize = gridSize, blocks = blocks, colour = colour, orgBlocks = blocks } 164 | 165 | 166 | {-| Rotates the supplied shape in the given direction. 167 | -} 168 | rotate : RotationDirection -> Shape -> Shape 169 | rotate direction (Shape shapeData) = 170 | let 171 | calcCoords : Coord -> Coord 172 | calcCoords = 173 | case direction of 174 | Clockwise -> 175 | -- Take this shape: 176 | -- +---+---+---+ 177 | -- | | X | | 178 | -- +---+---+---+ 179 | -- | X | X | X | 180 | -- +---+---+---+ 181 | -- | | | | 182 | -- +---+---+---+ 183 | -- When rotated clockwise this becomes: 184 | -- +---+---+---+ 185 | -- | | X | | 186 | -- +---+---+---+ 187 | -- | | X | X | 188 | -- +---+---+---+ 189 | -- | | X | | 190 | -- +---+---+---+ 191 | -- The coordinates change as follows: 192 | -- (0,1) -> (1,2) 193 | -- (1,1) -> (1,1) 194 | -- (1,2) -> (2,1) 195 | -- (2,1) -> (1,0) 196 | -- So as can be seen, the new y-coordinate is the original x-coordinate subtracted from 2, 197 | -- and the new x-coordinate is the original y-coordinate. 198 | -- 199 | -- Now take this shape: 200 | -- +---+---+---+---+ 201 | -- | | | | | 202 | -- +---+---+---+---+ 203 | -- | X | X | X | X | 204 | -- +---+---+---+---+ 205 | -- | | | | | 206 | -- +---+---+---+---+ 207 | -- | | | | | 208 | -- +---+---+---+---+ 209 | -- Becomes this when rotated clockwise: 210 | -- +---+---+---+---+ 211 | -- | | | X | | 212 | -- +---+---+---+---+ 213 | -- | | | X | | 214 | -- +---+---+---+---+ 215 | -- | | | X | | 216 | -- +---+---+---+---+ 217 | -- | | | X | | 218 | -- +---+---+---+---+ 219 | -- The coordinates change as follows: 220 | -- (0,2) -> (2,3) 221 | -- (1,2) -> (2,2) 222 | -- (2,2) -> (2,1) 223 | -- (3,2) -> (2,0) 224 | -- So as can be seen, the new y-coordinate is the original x-coordinate subtracted from 3, 225 | -- and the new x-coordinate is the original y-coordinate. 226 | -- 227 | -- So given the grid size, we can rotate the shape clockwise using this formula: 228 | \( x, y ) -> ( y, shapeData.gridSize - 1 - x ) 229 | 230 | Anticlockwise -> 231 | -- The opposite of the above: the new y-coordinate is the original x-coordinate, and he new 232 | -- x-coordinate is the original y-coordinate subtracted from (gridSize - 1). 233 | \( x, y ) -> ( shapeData.gridSize - 1 - y, x ) 234 | in 235 | Shape { shapeData | blocks = List.map calcCoords shapeData.blocks } 236 | 237 | 238 | {-| Gets a "clipped" version of the supplied shape, i.e. the blocks of the shape, with all empty space around them 239 | removed. For example the straight line shape is normally horizontal on the 3rd line of a 4x4 grid: this would return a 240 | 4x1 grid with just the line itself. This is used in situations where the shape needs to be rendered without a surrounding 241 | grid, e.g. in the preview of the upcoming shape. 242 | -} 243 | clippedBlocks : Shape -> List Coord 244 | clippedBlocks (Shape { blocks }) = 245 | let 246 | calcMin current new = 247 | if current == -1 then 248 | new 249 | 250 | else 251 | min current new 252 | 253 | ( minX, minY ) = 254 | blocks 255 | |> List.foldl 256 | (\( blockX, blockY ) ( accMinX, accMinY ) -> ( calcMin accMinX blockX, calcMin accMinY blockY )) 257 | ( -1, -1 ) 258 | in 259 | blocks |> List.map (\( x, y ) -> ( x - minX, y - minY )) 260 | 261 | 262 | {-| Gets a copy of the supplied shape, with the rotation as it was when the shape was originally created (i.e. before it 263 | was rotated any number of times by the user). 264 | -} 265 | withOrgRotation : Shape -> Shape 266 | withOrgRotation (Shape shapeData) = 267 | Shape { shapeData | blocks = shapeData.orgBlocks } 268 | 269 | 270 | 271 | -- SHAPE BAG 272 | 273 | 274 | {-| Represents a "bag of shape". This starts off as full of all 7 shapes in the game (in a random order), and can have 275 | one shape at a time removed from it till eventually it's empty, at which point the 7 shapes are used to re-fill it, in a 276 | new random order. 277 | -} 278 | type Bag 279 | = Bag { seed : Random.Seed, shapes : List Shape } 280 | 281 | 282 | {-| Creates a newly filly shape bag, using the passed in seed to provide pseudo-randomness. 283 | -} 284 | createShapeBag : Random.Seed -> Bag 285 | createShapeBag seed = 286 | let 287 | ( firstShape, restShape ) = 288 | allShapes 289 | in 290 | Bag { seed = seed, shapes = firstShape :: restShape } 291 | 292 | 293 | {-| Retrieves the next shape from the bag (refilling if it required). Returns that shape, along with a new bag to use in 294 | subsequent calls. 295 | -} 296 | next : Bag -> ( Shape, Bag ) 297 | next (Bag { seed, shapes }) = 298 | let 299 | ( ( maybeShape, remainingShapes ), newSeed ) = 300 | Random.step (Random.List.choose shapes) seed 301 | in 302 | case maybeShape of 303 | Just shape -> 304 | ( shape, Bag { seed = newSeed, shapes = remainingShapes } ) 305 | 306 | Nothing -> 307 | -- Bag is empty - just create a new full bag and use that instead. 308 | createShapeBag seed |> next 309 | -------------------------------------------------------------------------------- /src/GameOver.elm: -------------------------------------------------------------------------------- 1 | module GameOver exposing (Model, Msg, UpdateResult(..), getHighScores, init, subscriptions, update, view) 2 | 3 | {-| This module handles all functionality related to when a game is over. Shows the board as it was when the game ended, 4 | animating a "Game Over" message on top of it, then fading the game out. 5 | 6 | Also responsible for asking the user to fill in their high scores, if a new high score was achieved. 7 | 8 | -} 9 | 10 | import BoardView 11 | import Browser.Events 12 | import Coord exposing (Coord) 13 | import Element exposing (Element) 14 | import Element.Background 15 | import Element.Border 16 | import Element.Font 17 | import Game exposing (Game) 18 | import HighScores exposing (HighScores) 19 | import Scoring 20 | import Shape 21 | import UIHelpers 22 | import UserGame 23 | 24 | 25 | 26 | -- MODEL 27 | 28 | 29 | {-| The model of the current animation (there are three stages to the animation: see `Model`). 30 | -} 31 | type alias AnimationModel = 32 | { totalTimeMs : Float, elapsedTimeMs : Float } 33 | 34 | 35 | {-| Describes the current stage of the animation. 36 | -} 37 | type Animation 38 | = EnteringGameOverMessage AnimationModel 39 | | ShowingGameOverMessage AnimationModel 40 | | FadingOut AnimationModel 41 | 42 | 43 | {-| The state that the screen is currently at: 44 | 45 | - `Animating`: The "Game Over" animation is in progress. 46 | - `HandlingNewHighScore`: The user achieved a new high score and is being prompted for a name to store against when 47 | saving the high scores. 48 | 49 | -} 50 | type ScreenState 51 | = Animating Animation 52 | | HandlingNewHighScore HighScores.NewHighScoreModel 53 | 54 | 55 | {-| The data associated with the model (which is an opaque type). 56 | -} 57 | type alias ModelData = 58 | { blocks : List ( Coord, Shape.BlockColour ), state : ScreenState, score : Int, highScores : HighScores } 59 | 60 | 61 | type Model 62 | = Model ModelData 63 | 64 | 65 | init : HighScores -> Game shapeBuffer -> Model 66 | init highScores game = 67 | Model 68 | { blocks = (Game.blocks game).normal 69 | , state = Animating <| EnteringGameOverMessage { totalTimeMs = 1000, elapsedTimeMs = 0 } 70 | , score = game |> Game.getScoring |> Scoring.getPoints 71 | , highScores = highScores 72 | } 73 | 74 | 75 | 76 | -- UPDATE 77 | 78 | 79 | type Msg 80 | = AnimationFrame Float 81 | | GotNewHighScoreDialogMsg HighScores.NewHighScoreMsg 82 | 83 | 84 | {-| The value returned from the `update` function. Either `Continue`, meaning the game over animation is still in action 85 | (or the user is entering the name for a new high score), or `Done`, meaning it's finished and the calling module should 86 | now return the user to the welcome screen. 87 | -} 88 | type UpdateResult 89 | = Continue ( Model, Cmd Msg ) 90 | | Done ( Model, Cmd Msg ) 91 | 92 | 93 | {-| Updates this module's model based on the supplied message. Returns an `UpdateResult` which informs the calling module 94 | of how to proceed (see `UpdateResult` for more info). 95 | -} 96 | update : Msg -> Model -> UpdateResult 97 | update msg ((Model modelData) as model) = 98 | let 99 | ignore = 100 | Continue ( model, Cmd.none ) 101 | in 102 | case ( msg, modelData.state ) of 103 | ( AnimationFrame timeSinceLastFrameMs, Animating (EnteringGameOverMessage animationModel) ) -> 104 | progressAnimation model 105 | timeSinceLastFrameMs 106 | animationModel 107 | EnteringGameOverMessage 108 | (Just ( Animating <| ShowingGameOverMessage { totalTimeMs = 1000, elapsedTimeMs = 0 }, Cmd.none )) 109 | 110 | ( AnimationFrame timeSinceLastFrameMs, Animating (ShowingGameOverMessage animationModel) ) -> 111 | let 112 | ifAnimationOver = 113 | case HighScores.initNewHighScoreDialog modelData.score modelData.highScores of 114 | Just ( subModel, subCmd ) -> 115 | -- The user achieved a new high score - show the New High Score dialog. 116 | Just ( HandlingNewHighScore subModel, Cmd.map GotNewHighScoreDialogMsg subCmd ) 117 | 118 | Nothing -> 119 | -- Score wasn't high enough to be a new high score - when animation ends just fade out then 120 | -- return to Welcome screen 121 | Just ( Animating <| FadingOut { totalTimeMs = 500, elapsedTimeMs = 0 }, Cmd.none ) 122 | in 123 | progressAnimation model timeSinceLastFrameMs animationModel ShowingGameOverMessage ifAnimationOver 124 | 125 | ( AnimationFrame timeSinceLastFrameMs, Animating (FadingOut animationModel) ) -> 126 | progressAnimation model timeSinceLastFrameMs animationModel FadingOut Nothing 127 | 128 | ( AnimationFrame _, HandlingNewHighScore _ ) -> 129 | ignore 130 | 131 | ( GotNewHighScoreDialogMsg subMsg, _ ) -> 132 | handleNewHighScoreDialogMsg subMsg model 133 | 134 | 135 | {-| Handles a message from the New High Score dialog. Delegates its handling to that module, and responds to the result 136 | of that `update...` call accordingly (e.g. by closing that dialog if finished). 137 | -} 138 | handleNewHighScoreDialogMsg : HighScores.NewHighScoreMsg -> Model -> UpdateResult 139 | handleNewHighScoreDialogMsg msg ((Model modelData) as model) = 140 | case modelData.state of 141 | Animating _ -> 142 | Continue ( model, Cmd.none ) 143 | 144 | HandlingNewHighScore newHighScoreModel -> 145 | case HighScores.updateNewHighScoreDialog msg newHighScoreModel of 146 | HighScores.KeepOpen nextNewHighScoreModel -> 147 | Continue <| ( Model { modelData | state = HandlingNewHighScore nextNewHighScoreModel }, Cmd.none ) 148 | 149 | HighScores.Close (Just ( newHighScores, subCmd )) -> 150 | Done 151 | ( Model { modelData | highScores = newHighScores } 152 | , Cmd.map GotNewHighScoreDialogMsg subCmd 153 | ) 154 | 155 | HighScores.Close Nothing -> 156 | Done ( model, Cmd.none ) 157 | 158 | 159 | {-| Progresses the animation after an animation frame. Each animation knows the total time it should run for so this will 160 | either continue the current animation if not enough time has elapsed yet (using `ifAnimationContinuing`) or will use 161 | `ifAnimationOver` to decide how to proceed. If that parameter is a `Nothing` then `Done` is returned, meaning this 162 | whole module is now finished and the user should be returned to the Welcome screen. Otherwise (i.e. if `ifAnimationOver` 163 | is `Just` some `ScreenState`) then that `ScreenState` is used (e.g. the next stage in the overall animation might proceed). 164 | -} 165 | progressAnimation : Model -> Float -> AnimationModel -> (AnimationModel -> Animation) -> Maybe ( ScreenState, Cmd Msg ) -> UpdateResult 166 | progressAnimation ((Model modelData) as model) timeSinceLastFrameMs animationModel ifAnimationContinuing ifAnimationOver = 167 | let 168 | newElapsedTimeMs = 169 | animationModel.elapsedTimeMs + timeSinceLastFrameMs 170 | in 171 | if newElapsedTimeMs < animationModel.totalTimeMs then 172 | { animationModel | elapsedTimeMs = newElapsedTimeMs } 173 | |> ifAnimationContinuing 174 | |> (\continuingAnimation -> Continue ( Model { modelData | state = Animating continuingAnimation }, Cmd.none )) 175 | 176 | else 177 | ifAnimationOver 178 | |> Maybe.map (\( nextState, nextCmd ) -> Continue ( Model { modelData | state = nextState }, nextCmd )) 179 | |> Maybe.withDefault (Done ( model, Cmd.none )) 180 | 181 | 182 | 183 | -- VIEW 184 | 185 | 186 | view : Model -> Element Msg 187 | view (Model modelData) = 188 | let 189 | boardView = 190 | BoardView.view UserGame.boardViewConfig False (modelData.blocks |> BoardView.withOpacity 1) [] Nothing 191 | 192 | ( overlay, opacity ) = 193 | case modelData.state of 194 | Animating animation -> 195 | gameOverOverlay animation 196 | 197 | HandlingNewHighScore newHighScoreModel -> 198 | ( HighScores.newHighScoreView newHighScoreModel |> Element.map GotNewHighScoreDialogMsg, 1.0 ) 199 | in 200 | Element.el [ Element.inFront overlay, Element.alpha opacity, Element.centerX ] boardView 201 | 202 | 203 | {-| The "Game Over" message overlaid on top of the game board. 204 | -} 205 | gameOverOverlay : Animation -> ( Element msg, Float ) 206 | gameOverOverlay animation = 207 | let 208 | { messageOpacity, messageGlow, entireOpacity } = 209 | calcGameOverMsgViewInfo animation 210 | in 211 | ( Element.row 212 | [ Element.centerX 213 | , Element.centerY 214 | , Element.Border.width 2 215 | , Element.Background.color UIHelpers.mainForegroundColour 216 | , Element.padding 20 217 | , Element.Border.rounded 20 218 | , Element.Border.glow (Element.rgb255 200 200 200) messageGlow 219 | , Element.Font.size 32 220 | , Element.Font.extraBold 221 | , Element.Font.color UIHelpers.mainBackgroundColour 222 | , Element.Font.family [ Element.Font.typeface "Courier New" ] 223 | , Element.alpha messageOpacity 224 | ] 225 | [ Element.text "Game Over" ] 226 | , entireOpacity 227 | ) 228 | 229 | 230 | calcGameOverMsgViewInfo : Animation -> { messageOpacity : Float, messageGlow : Float, entireOpacity : Float } 231 | calcGameOverMsgViewInfo animation = 232 | let 233 | defaultMessageGlow = 234 | 5 235 | 236 | calcPercentComplete { totalTimeMs, elapsedTimeMs } = 237 | 100 * elapsedTimeMs / totalTimeMs 238 | in 239 | case animation of 240 | EnteringGameOverMessage animationModel -> 241 | let 242 | percentComplete = 243 | calcPercentComplete animationModel 244 | in 245 | { messageOpacity = percentComplete / 100 246 | , messageGlow = defaultMessageGlow * percentComplete / 100 247 | , entireOpacity = 1 248 | } 249 | 250 | ShowingGameOverMessage animationModel -> 251 | let 252 | percentComplete = 253 | calcPercentComplete animationModel 254 | 255 | extraMessageGlow = 256 | if percentComplete < 50 then 257 | percentComplete / 50 * defaultMessageGlow 258 | 259 | else 260 | ((100 - percentComplete) / 50) * defaultMessageGlow 261 | in 262 | { messageOpacity = 1 263 | , messageGlow = defaultMessageGlow + extraMessageGlow 264 | , entireOpacity = 1 265 | } 266 | 267 | FadingOut animationModel -> 268 | let 269 | percentComplete = 270 | calcPercentComplete animationModel 271 | in 272 | { messageOpacity = 1 273 | , messageGlow = defaultMessageGlow - (defaultMessageGlow * percentComplete / 100) 274 | , entireOpacity = 1 - (percentComplete / 100) 275 | } 276 | 277 | 278 | 279 | -- HIGH SCORES 280 | 281 | 282 | getHighScores : Model -> HighScores 283 | getHighScores (Model { highScores }) = 284 | highScores 285 | 286 | 287 | 288 | -- SUBSCRIPTIONS 289 | 290 | 291 | subscriptions : Model -> Sub Msg 292 | subscriptions (Model { state }) = 293 | case state of 294 | Animating _ -> 295 | Browser.Events.onAnimationFrameDelta AnimationFrame 296 | 297 | HandlingNewHighScore newHighScoreModel -> 298 | HighScores.newHighScoreDialogSubscriptions newHighScoreModel |> Sub.map GotNewHighScoreDialogMsg 299 | -------------------------------------------------------------------------------- /src/Settings.elm: -------------------------------------------------------------------------------- 1 | module Settings exposing 2 | ( EditableSettings 3 | , Settings 4 | , allEditableKeyBindings 5 | , allKeyBindings 6 | , default 7 | , editableKeyBinding 8 | , fromEditable 9 | , fromJson 10 | , keyboardDecoder 11 | , toEditable 12 | , toJson 13 | , withKeyBinding 14 | ) 15 | 16 | {-| Contains all functionality to defining the settings (i.e. user preferences) such as keyboard bindings. Contains 17 | the JSON de/encoders and the types. 18 | -} 19 | 20 | import AssocList 21 | import Dict exposing (Dict) 22 | import Game 23 | import Json.Decode as JD 24 | import Json.Encode as JE 25 | import Shape 26 | 27 | 28 | {-| The main type exposed from this module. Defines all settings required to run the game (currently just the keyboard 29 | bindings). 30 | 31 | This type is exposed as an opaque type. Internally we store keyBindings as a dictionary keyed on the key, as during 32 | gameplay, when performance is most important, we need to most quickly get from a key which the user has pressed to the 33 | corresponding action. This also ensures that no key can be bound to two different actions. When we persist this to JSON, 34 | however, we swap these about: the JSON field name is the action (e.g. "moveLeft"), and the JSON field value is the key 35 | (e.g. "LeftArrow"). 36 | 37 | -} 38 | type Settings 39 | = Settings { keyBindings : Dict String Game.UserAction } 40 | 41 | 42 | {-| Gets a list of the the actions (in the order they're shown to the user, e.g. on the Settings screen), along with the 43 | key bound to each one. 44 | -} 45 | allKeyBindings : Settings -> List ( Game.UserAction, String ) 46 | allKeyBindings settings = 47 | let 48 | (EditableSettings { keyBindings }) = 49 | toEditable settings 50 | in 51 | allActionsOrdered |> List.map (\action -> ( action, keyBindings |> AssocList.get action |> Maybe.withDefault "" )) 52 | 53 | 54 | 55 | -- JSON 56 | 57 | 58 | {-| Decodes the supplied JSON value into a `Settings` value, falling back to the `default` value on any decoding errors. 59 | -} 60 | fromJson : JE.Value -> Settings 61 | fromJson json = 62 | JD.decodeValue settingsDecoder json |> Result.withDefault default 63 | 64 | 65 | {-| Encodes the supplied `Settings` to a JSON value (e.g. to persist in local storage). 66 | -} 67 | toJson : Settings -> JE.Value 68 | toJson (Settings { keyBindings }) = 69 | keyBindings 70 | |> Dict.toList 71 | |> List.map (\( key, action ) -> ( actionToJsonFieldName action, JE.string key )) 72 | |> JE.object 73 | |> (\keyBindingsJson -> JE.object [ ( keyBindingsJsonFieldName, keyBindingsJson ) ]) 74 | 75 | 76 | keyBindingsJsonFieldName = 77 | "keyBindings" 78 | 79 | 80 | settingsDecoder : JD.Decoder Settings 81 | settingsDecoder = 82 | JD.field keyBindingsJsonFieldName keyBindingsDecoder 83 | |> JD.map (\keyBindings -> Settings { keyBindings = keyBindings }) 84 | 85 | 86 | {-| Decodes a JSON value to the internal representation of key bindings, namely a dictionary keyed on a string (the key, 87 | e.g. "LeftArrow"), where the value is the action this key corresponds to. 88 | -} 89 | keyBindingsDecoder : JD.Decoder (Dict String Game.UserAction) 90 | keyBindingsDecoder = 91 | -- Decode to a list of name/value pairs, where the name is the action (e.g. "moveLeft") and the value is the key (e.g. "LeftArrow") 92 | JD.keyValuePairs JD.string 93 | -- Convert this list of name/value pairs to a dictionary keyed on key (notice this was previously the value). 94 | |> JD.map jsonNameValuePairsToKeyBindingsDict 95 | |> JD.andThen 96 | (\dict -> 97 | -- Now check we have the right number of entries. 98 | if Dict.size dict == List.length allActionsOrdered then 99 | JD.succeed dict 100 | 101 | else 102 | JD.fail "Incorrect number of entries in dictionary" 103 | ) 104 | 105 | 106 | {-| Converts a list of name/value pairs from a JSON value (where the name is the action, e.g. "moveLeft", and the value 107 | is the key, e.g. "LeftArrow") to a dictionary keyed on the key (e.g. "LeftArrow") where the value is the proper 108 | `Game.UserAction` value. 109 | -} 110 | jsonNameValuePairsToKeyBindingsDict : List ( String, String ) -> Dict String Game.UserAction 111 | jsonNameValuePairsToKeyBindingsDict = 112 | List.foldl 113 | (\( actionString, key ) dict -> 114 | case jsonFieldNameToAction actionString of 115 | Just action -> 116 | Dict.insert key action dict 117 | 118 | Nothing -> 119 | dict 120 | ) 121 | Dict.empty 122 | 123 | 124 | actionToJsonFieldName : Game.UserAction -> String 125 | actionToJsonFieldName action = 126 | case action of 127 | Game.Move Game.Left -> 128 | "moveLeft" 129 | 130 | Game.Move Game.Right -> 131 | "moveRight" 132 | 133 | Game.Move Game.Down -> 134 | "softDrop" 135 | 136 | Game.HardDrop -> 137 | "hardDrop" 138 | 139 | Game.Rotate Shape.Clockwise -> 140 | "rotateClockwise" 141 | 142 | Game.Rotate Shape.Anticlockwise -> 143 | "rotateAnticlockwise" 144 | 145 | Game.Hold -> 146 | "hold" 147 | 148 | Game.TogglePause -> 149 | "togglePause" 150 | 151 | 152 | jsonFieldNameToAction : String -> Maybe Game.UserAction 153 | jsonFieldNameToAction fieldName = 154 | case fieldName of 155 | "moveLeft" -> 156 | Just <| Game.Move Game.Left 157 | 158 | "moveRight" -> 159 | Just <| Game.Move Game.Right 160 | 161 | "softDrop" -> 162 | Just <| Game.Move Game.Down 163 | 164 | "hardDrop" -> 165 | Just <| Game.HardDrop 166 | 167 | "rotateClockwise" -> 168 | Just <| Game.Rotate Shape.Clockwise 169 | 170 | "rotateAnticlockwise" -> 171 | Just <| Game.Rotate Shape.Anticlockwise 172 | 173 | "hold" -> 174 | Just <| Game.Hold 175 | 176 | "togglePause" -> 177 | Just <| Game.TogglePause 178 | 179 | _ -> 180 | Nothing 181 | 182 | 183 | {-| The default key bindings. 184 | -} 185 | default : Settings 186 | default = 187 | Settings 188 | { keyBindings = 189 | buildKeyBindings 190 | { moveLeft = "ArrowLeft" 191 | , moveRight = "ArrowRight" 192 | , softDrop = "ArrowDown" 193 | , hardDrop = " " 194 | , rotateClockwise = "x" 195 | , rotateAnticlockwise = "z" 196 | , hold = "c" 197 | , togglePause = "p" 198 | } 199 | } 200 | 201 | 202 | 203 | -- KEY BINDINGS 204 | 205 | 206 | {-| Builds a `KeyBindings` value from the supplied values. 207 | -} 208 | buildKeyBindings : 209 | { moveLeft : String 210 | , moveRight : String 211 | , softDrop : String 212 | , hardDrop : String 213 | , rotateClockwise : String 214 | , rotateAnticlockwise : String 215 | , hold : String 216 | , togglePause : String 217 | } 218 | -> Dict String Game.UserAction 219 | buildKeyBindings { moveLeft, moveRight, softDrop, hardDrop, rotateClockwise, rotateAnticlockwise, hold, togglePause } = 220 | Dict.fromList 221 | [ ( String.toLower moveLeft, Game.Move Game.Left ) 222 | , ( String.toLower moveRight, Game.Move Game.Right ) 223 | , ( String.toLower softDrop, Game.Move Game.Down ) 224 | , ( String.toLower hardDrop, Game.HardDrop ) 225 | , ( String.toLower rotateClockwise, Game.Rotate Shape.Clockwise ) 226 | , ( String.toLower rotateAnticlockwise, Game.Rotate Shape.Anticlockwise ) 227 | , ( String.toLower hold, Game.Hold ) 228 | , ( String.toLower togglePause, Game.TogglePause ) 229 | ] 230 | 231 | 232 | {-| Decodes a key event, succeeding if it's one of the special keys we handle (as defined in the supplied `config`), 233 | otherwise failing. 234 | -} 235 | keyboardDecoder : Settings -> JD.Decoder Game.UserAction 236 | keyboardDecoder (Settings { keyBindings }) = 237 | JD.field "key" JD.string 238 | |> JD.andThen 239 | (\key -> 240 | case Dict.get (String.toLower key) keyBindings of 241 | Just action -> 242 | JD.succeed action 243 | 244 | Nothing -> 245 | JD.fail "Not a mapped key - ignoring" 246 | ) 247 | 248 | 249 | 250 | -- EDITABLE SETTINGS 251 | 252 | 253 | {-| Defines the settings when they're in a state of being edited. Similar to the actual `Settings` type, except that the 254 | dictionary is keyed on the action rather than the keyboard key. Also this is allowed to be in an invalid state, e.g. 255 | where some actions don't have a key binding. This is required in case a user changes an action to use a key which is 256 | currently used by another action. In that case, the new binding is used, and the previous action is left temporarily 257 | "unbound", till the user assigns a new binding. 258 | -} 259 | type EditableSettings 260 | = EditableSettings { keyBindings : AssocList.Dict Game.UserAction String } 261 | 262 | 263 | {-| All the actions in the game, in the order in which they are shown to the user in the settings screen. 264 | -} 265 | allActionsOrdered : List Game.UserAction 266 | allActionsOrdered = 267 | [ Game.Move Game.Left 268 | , Game.Move Game.Right 269 | , Game.Rotate Shape.Clockwise 270 | , Game.Rotate Shape.Anticlockwise 271 | , Game.Move Game.Down 272 | , Game.HardDrop 273 | , Game.Hold 274 | , Game.TogglePause 275 | ] 276 | 277 | 278 | {-| Converts the supplied `Settings` to an `EditableSettings` value, for use on the Settings screen. 279 | -} 280 | toEditable : Settings -> EditableSettings 281 | toEditable (Settings { keyBindings }) = 282 | EditableSettings 283 | { keyBindings = 284 | keyBindings 285 | |> Dict.foldl 286 | (\key action acc -> AssocList.insert action key acc) 287 | AssocList.empty 288 | } 289 | 290 | 291 | {-| Converts the supplied `EditableSettings` to a `Settings` value, if valid (i.e. if all actions have bindings). 292 | -} 293 | fromEditable : EditableSettings -> Maybe Settings 294 | fromEditable (EditableSettings { keyBindings }) = 295 | keyBindings 296 | |> AssocList.foldl (\action key acc -> Dict.insert key action acc) Dict.empty 297 | |> (\newKeyBindings -> 298 | if Dict.size newKeyBindings == List.length allActionsOrdered then 299 | Just <| Settings { keyBindings = newKeyBindings } 300 | 301 | else 302 | Nothing 303 | ) 304 | 305 | 306 | {-| Gets a list of all the current bindings in the supplied `EditableSettings`. 307 | -} 308 | allEditableKeyBindings : EditableSettings -> List { action : Game.UserAction, key : Maybe String } 309 | allEditableKeyBindings (EditableSettings { keyBindings }) = 310 | allActionsOrdered 311 | |> List.map (\action -> { action = action, key = AssocList.get action keyBindings }) 312 | 313 | 314 | {-| Gets the current bindings in the supplied `EditableSettings` for the given `action`. 315 | -} 316 | editableKeyBinding : Game.UserAction -> EditableSettings -> Maybe String 317 | editableKeyBinding action (EditableSettings { keyBindings }) = 318 | AssocList.get action keyBindings 319 | 320 | 321 | {-| Updates the supplied `EditableSettings` with the supplied binding. 322 | -} 323 | withKeyBinding : Game.UserAction -> String -> EditableSettings -> EditableSettings 324 | withKeyBinding action key (EditableSettings { keyBindings }) = 325 | let 326 | lowerKey = 327 | String.toLower key 328 | 329 | -- Remove any other actions associated with this key. 330 | newKeyBindings : AssocList.Dict Game.UserAction String 331 | newKeyBindings = 332 | keyBindings 333 | |> AssocList.foldl 334 | (\currentAction currentKey acc -> 335 | if currentKey == lowerKey then 336 | acc 337 | 338 | else 339 | AssocList.insert currentAction currentKey acc 340 | ) 341 | AssocList.empty 342 | in 343 | EditableSettings { keyBindings = AssocList.insert action lowerKey newKeyBindings } 344 | -------------------------------------------------------------------------------- /src/SettingsScreen.elm: -------------------------------------------------------------------------------- 1 | module SettingsScreen exposing (Model, Msg, UpdateResult(..), init, keyDescription, subscriptions, update, view) 2 | 3 | {-| Contains all functionality related to the Settings screen. Both the screen that shows the settings, and the screen 4 | launched from it, which the user uses to assign a key binding. 5 | -} 6 | 7 | import Browser.Events 8 | import Element exposing (Element) 9 | import Element.Border 10 | import Element.Font 11 | import Element.Input 12 | import Game 13 | import Json.Decode as JD 14 | import Modal 15 | import Ports 16 | import Settings exposing (EditableSettings, Settings) 17 | import UIHelpers exposing (edges) 18 | 19 | 20 | 21 | -- MODEL 22 | 23 | 24 | type Model 25 | = Model ModelData 26 | 27 | 28 | {-| The screen currently being shown: 29 | 30 | - `SettingsScreen`: The screen showing all key bindings. 31 | - `KeySelectionScreen`: The screen where the user can assign a different key binding to an action. 32 | 33 | -} 34 | type Screen 35 | = SettingsScreen 36 | | KeySelectionScreen { action : Game.UserAction, key : Maybe String } 37 | 38 | 39 | {-| The data associated with the main `Model`: 40 | 41 | - `editableSettings`: The settings currently being edited. Might be in an invalid state temporarily (i.e. with some 42 | action not having a key binding yet). 43 | - `screen`: The screen currently being shown. 44 | - `settingsToPersist`: The `Settings` value to persist if the user submits the settings screen as things stand. If the 45 | `editableSettings` are valid, this will have a value, otherwise it will be `Nothing`. This is used to define whether 46 | the dialog can be submitted or not. This value _could_ be calculated on demand from the `editableSettings`, but to 47 | avoid this being done in multiple places the data is instead stored in the model and kept in-sync with the editable 48 | copy of the settings. 49 | 50 | -} 51 | type alias ModelData = 52 | { editableSettings : EditableSettings, screen : Screen, settingsToPersist : Maybe Settings } 53 | 54 | 55 | init : Settings -> Model 56 | init settings = 57 | Model { editableSettings = Settings.toEditable settings, screen = SettingsScreen, settingsToPersist = Just settings } 58 | 59 | 60 | 61 | -- UPDATE 62 | 63 | 64 | type Msg 65 | = RestoreDefaultSettingsRequested -- The user has clicked the Restore Default Settings button on the Settings screen. 66 | | SaveRequested -- The user has clicked the Save button (on either of the screens). 67 | | CancelRequested -- The user has clicked the Cancel button (on either of the screens). 68 | | KeySelectionScreenRequested Game.UserAction -- The user has clicked a key binding, requesting to change it 69 | | KeySelected String -- The user has chosen a key to associate with a given action. 70 | 71 | 72 | {-| The result of the `update` call, telling the calling module whether to keep the Settings screen open or not. If 73 | closing, this also optionally supplies a new copy of the `Settings` to persist to local storage. 74 | -} 75 | type UpdateResult 76 | = KeepOpen 77 | | Close (Maybe Settings) 78 | 79 | 80 | 81 | -- TODO: should UpdateResult contain the model and cmd returned from update? (Like for high scores.) 82 | 83 | 84 | {-| Updates the model based on the supplied message, and returns a new model and command, along with an `UpdateResult` 85 | value (see that type for more info). 86 | -} 87 | update : Msg -> Model -> ( Model, Cmd Msg, UpdateResult ) 88 | update msg ((Model ({ editableSettings, screen, settingsToPersist } as modelData)) as model) = 89 | let 90 | ignore = 91 | ( model, Cmd.none, KeepOpen ) 92 | in 93 | case ( msg, screen ) of 94 | ( RestoreDefaultSettingsRequested, SettingsScreen ) -> 95 | ( Model 96 | { modelData 97 | | editableSettings = Settings.toEditable Settings.default 98 | , settingsToPersist = Just Settings.default 99 | } 100 | , Cmd.none 101 | , KeepOpen 102 | ) 103 | 104 | ( RestoreDefaultSettingsRequested, KeySelectionScreen _ ) -> 105 | ignore 106 | 107 | ( SaveRequested, SettingsScreen ) -> 108 | case settingsToPersist of 109 | Just validSettings -> 110 | ( model, Settings.toJson validSettings |> Ports.persistSettings, Close <| Just validSettings ) 111 | 112 | Nothing -> 113 | -- Should never happen - UI shouldn't let user submit the dialog if it's not valid (e.g. some key 114 | -- bindings not yet set). 115 | ignore 116 | 117 | ( SaveRequested, KeySelectionScreen { action, key } ) -> 118 | let 119 | ( newEditableSettings, newSettingsToPersist ) = 120 | case key of 121 | Just key_ -> 122 | Settings.withKeyBinding action key_ editableSettings 123 | |> (\newEditableSettings_ -> ( newEditableSettings_, Settings.fromEditable newEditableSettings_ )) 124 | 125 | Nothing -> 126 | ( modelData.editableSettings, modelData.settingsToPersist ) 127 | in 128 | ( Model 129 | { modelData 130 | | editableSettings = newEditableSettings 131 | , screen = SettingsScreen 132 | , settingsToPersist = newSettingsToPersist 133 | } 134 | , Cmd.none 135 | , KeepOpen 136 | ) 137 | 138 | ( CancelRequested, SettingsScreen ) -> 139 | ( model, Cmd.none, Close Nothing ) 140 | 141 | ( CancelRequested, KeySelectionScreen _ ) -> 142 | ( Model { modelData | screen = SettingsScreen }, Cmd.none, KeepOpen ) 143 | 144 | ( KeySelectionScreenRequested action, SettingsScreen ) -> 145 | ( Model { modelData | screen = KeySelectionScreen { action = action, key = Settings.editableKeyBinding action editableSettings } } 146 | , Cmd.none 147 | , KeepOpen 148 | ) 149 | 150 | ( KeySelectionScreenRequested _, KeySelectionScreen _ ) -> 151 | ignore 152 | 153 | ( KeySelected key, KeySelectionScreen keySelectionScreen ) -> 154 | ( Model { modelData | screen = KeySelectionScreen { keySelectionScreen | key = Just key } } 155 | , Cmd.none 156 | , KeepOpen 157 | ) 158 | 159 | ( KeySelected _, _ ) -> 160 | ignore 161 | 162 | 163 | 164 | -- VIEW 165 | 166 | 167 | view : Model -> Element Msg 168 | view (Model modelData) = 169 | case modelData.screen of 170 | SettingsScreen -> 171 | settingsView modelData 172 | 173 | KeySelectionScreen { action, key } -> 174 | keySelectionView action key 175 | 176 | 177 | {-| The view when the Settings screen is being shown. 178 | -} 179 | settingsView : ModelData -> Element Msg 180 | settingsView ({ editableSettings, settingsToPersist } as modelData) = 181 | Element.column [ Element.Font.color UIHelpers.mainForegroundColour, Element.width Element.fill ] 182 | [ Element.el 183 | [ Element.centerX, Element.Font.bold, Element.Font.size 24, Element.paddingEach { edges | bottom = 15 } ] 184 | <| 185 | Element.text "Settings" 186 | , keyBindingsTable editableSettings 187 | ] 188 | |> Modal.dialog (settingsScreenModalConfig modelData) 189 | 190 | 191 | {-| The config to use for the modal dialog when it's showing the Settings screen. 192 | -} 193 | settingsScreenModalConfig : { a | settingsToPersist : Maybe Settings } -> Modal.Config Msg 194 | settingsScreenModalConfig { settingsToPersist } = 195 | Modal.defaultConfig CancelRequested (Maybe.map (always SaveRequested) settingsToPersist) 196 | |> Modal.withCustomButton "Restore Defaults" (Just RestoreDefaultSettingsRequested) 197 | 198 | 199 | {-| The view when the screen where the user can assign a key binding is being shown. 200 | -} 201 | keySelectionView : Game.UserAction -> Maybe String -> Element Msg 202 | keySelectionView action key = 203 | let 204 | caption = 205 | "Press the key to use to " ++ (Game.userActionDescription action |> String.toLower) 206 | 207 | ( keyDescr, colour ) = 208 | keyDescriptionAndColour key 209 | in 210 | Element.column [ Element.Font.color UIHelpers.mainForegroundColour ] 211 | [ Element.el [ Element.centerX, Element.paddingEach { edges | bottom = 15 }, Element.Font.semiBold, Element.Font.size 16 ] <| 212 | Element.text caption 213 | , Element.el [ Element.centerX, Element.Font.bold, Element.Font.size 24, Element.Font.color colour ] <| Element.text keyDescr 214 | ] 215 | |> Element.el [] 216 | |> Modal.dialog (keySelectionScreenModalConfig key) 217 | 218 | 219 | {-| The config to use for the modal dialog when it's showing the key selection screen. 220 | -} 221 | keySelectionScreenModalConfig : Maybe String -> Modal.Config Msg 222 | keySelectionScreenModalConfig key = 223 | Modal.defaultConfig CancelRequested (Maybe.map (always SaveRequested) key) 224 | 225 | 226 | {-| A table of all the key bindings (actions to their corresponding keys). 227 | -} 228 | keyBindingsTable : EditableSettings -> Element Msg 229 | keyBindingsTable settings = 230 | let 231 | keyBindings = 232 | Settings.allEditableKeyBindings settings 233 | 234 | column caption contents = 235 | { header = Element.el [ Element.Font.size 16, Element.Font.bold, Element.paddingXY 0 4 ] <| Element.text caption 236 | , width = Element.shrink 237 | , view = \record -> Element.el [ Element.Font.size 14, Element.Font.semiBold ] <| contents record 238 | } 239 | in 240 | Element.table [ Element.spacingXY 25 5 ] 241 | { data = keyBindings 242 | , columns = 243 | [ column "Action" <| 244 | \{ action } -> Game.userActionDescription action |> Element.text 245 | , column "Key" <| 246 | \{ action, key } -> 247 | let 248 | ( caption, colour ) = 249 | keyDescriptionAndColour key 250 | in 251 | Element.Input.button 252 | [ Element.Border.widthEach { bottom = 1, left = 0, right = 0, top = 0 } 253 | , Element.Border.color UIHelpers.mainBackgroundColour 254 | , Element.mouseOver [ Element.Border.color UIHelpers.mainForegroundColour ] 255 | , Element.Font.color colour 256 | ] 257 | { onPress = Just <| KeySelectionScreenRequested action, label = Element.text caption } 258 | ] 259 | } 260 | 261 | 262 | keyDescriptionAndColour : Maybe String -> ( String, Element.Color ) 263 | keyDescriptionAndColour maybeKey = 264 | case maybeKey of 265 | Just key -> 266 | ( keyDescription key, UIHelpers.mainForegroundColour ) 267 | 268 | Nothing -> 269 | ( "", Element.rgb255 200 0 0 ) 270 | 271 | 272 | keyDescription : String -> String 273 | keyDescription key = 274 | case String.toUpper key of 275 | " " -> 276 | "Space" 277 | 278 | "ARROWLEFT" -> 279 | "Left arrow" 280 | 281 | "ARROWRIGHT" -> 282 | "Right arrow" 283 | 284 | "ARROWDOWN" -> 285 | "Down arrow" 286 | 287 | "ARROWUP" -> 288 | "Up arrow" 289 | 290 | upperKey -> 291 | upperKey 292 | 293 | 294 | {-| All the keys that it's valid to assign as a key binding. 295 | -} 296 | allowedKeys : List String 297 | allowedKeys = 298 | -- ASCII 33 (exclamation mark) up to 126 (~) are all valid keys, as are the four arrows. 299 | (List.range 33 126 |> List.map (Char.fromCode >> String.fromChar)) 300 | ++ [ " ", "ArrowLeft", "ArrowRight", "ArrowDown", "ArrowUp" ] 301 | 302 | 303 | 304 | -- SUBSCRIPTIONS 305 | 306 | 307 | subscriptions : Model -> Sub Msg 308 | subscriptions (Model modelData) = 309 | case modelData.screen of 310 | SettingsScreen -> 311 | settingsScreenModalConfig modelData |> Modal.subscriptions 312 | 313 | KeySelectionScreen { key } -> 314 | Sub.batch 315 | [ Browser.Events.onKeyDown keyBindingDecoder 316 | , keySelectionScreenModalConfig key |> Modal.subscriptions 317 | ] 318 | 319 | 320 | keyBindingDecoder : JD.Decoder Msg 321 | keyBindingDecoder = 322 | JD.field "key" JD.string 323 | |> JD.andThen 324 | (\key -> 325 | if List.member key allowedKeys then 326 | JD.succeed <| KeySelected key 327 | 328 | else 329 | JD.fail "" 330 | ) 331 | -------------------------------------------------------------------------------- /src/BoardView.elm: -------------------------------------------------------------------------------- 1 | module BoardView exposing (BlockViewInfo, BorderStyle(..), Config, view, withColour, withOpacity) 2 | 3 | {-| This module is responsible for rendering a board (typically during a game, but also used in the welcome screen). 4 | 5 | Uses SVG but exposes no SVG information so that a different rendering technology can be swapped in later if required. 6 | 7 | -} 8 | 9 | import Color exposing (Color) 10 | import Coord exposing (Coord) 11 | import Element exposing (Element) 12 | import Element.Border 13 | import HighlightAnimation 14 | import Shape 15 | import TypedSvg as Svg exposing (svg) 16 | import TypedSvg.Attributes as SvgA 17 | import TypedSvg.Core exposing (Svg) 18 | import TypedSvg.Types as SvgT 19 | 20 | 21 | {-| Defines the configuration information required to render the board. 22 | 23 | - `cellSize`: The width and height of each cell, in pixels. 24 | - `rowCount`: The number of rows in the board. 25 | - `colCount`: The number of columns in the board. 26 | - `borderStyle`: The type of border to put around the board. 27 | - `showGridLines`: Whether to show grid lines or not. Generally true (e.g. for a game), but false when for example 28 | showing a preview of the upcoming shape next to the actual game board. 29 | 30 | -} 31 | type alias Config = 32 | { cellSize : Int, rowCount : Int, colCount : Int, borderStyle : BorderStyle, showGridLines : Bool } 33 | 34 | 35 | {-| Defines the style of the border to be applied to the board: 36 | 37 | - `Solid`: renders a solid line around the board. Used for a normal game. 38 | - `Fade`: fades the edges of the board out into the supplied colour. Used in the welcome screen. 39 | - `None`: no border is shown (e.g. when showing a preview of the upcoming shape next to the actual game board). 40 | 41 | -} 42 | type BorderStyle 43 | = Solid 44 | | Fade Element.Color 45 | | None 46 | 47 | 48 | {-| Describes a normal block to be rendered, namely its coordinates on the board, its colour, and its opacity. 49 | -} 50 | type alias BlockViewInfo = 51 | { coord : Coord, colour : Shape.BlockColour, opacity : Float } 52 | 53 | 54 | {-| Describes how a block should be filled in. 55 | 56 | - `Filled`: a normal block, filled in in a given colour, with the opacity supplied here. 57 | - `Unfilled`: a block used to show a preview of where a landing should would eventually land, shown unfilled. 58 | 59 | -} 60 | type BlockFillType 61 | = Filled Float 62 | | Unfilled 63 | 64 | 65 | {-| Renders the current state of the board into an HTML element, using SVG. Parameters: 66 | 67 | - `config`: configuration information required to render the board (e.g. the sizes, etc). 68 | - `showPauseOverlay`: whether to overlay the board with a "Pause" image (used when the game is paused). 69 | - `normalBlocks`: the normal blocks (e.g. the landed blocks, but the blocks of the currently dropping shape, if it's 70 | not to be animated at the moment). 71 | - `previewLandingBlocks`: the coordinates and colour of the blocks of the currently dropping shape in the position 72 | where it would land if it were not to be moved left or right. These are shown as not-filled-in. 73 | - `highlightAnimation`: if an animation is currently ongoing (e.g. for a shape which has just landed, or for rows 74 | being removed) this should describe the animation (e.g. the type of animation, its current progress, and the blocks 75 | in it). 76 | 77 | -} 78 | view : Config -> Bool -> List BlockViewInfo -> List ( Coord, Shape.BlockColour ) -> Maybe HighlightAnimation.Model -> Element msg 79 | view ({ borderStyle, showGridLines } as config) showPauseOverlay normalBlocks previewLandingBlocks highlightAnimation = 80 | let 81 | ( overlay, borderAttrs ) = 82 | case borderStyle of 83 | Solid -> 84 | ( [] 85 | , [ Element.Border.width 3 86 | , Element.Border.color <| Element.rgb255 100 100 100 87 | , Element.Border.glow (Element.rgb255 200 200 200) 1 88 | ] 89 | ) 90 | 91 | Fade colourToFadeTo -> 92 | ( fadeEdgesOverlay <| elmUIColourToColour colourToFadeTo, [] ) 93 | 94 | None -> 95 | ( [], [] ) 96 | 97 | background = 98 | Svg.rect 99 | [ SvgA.width <| SvgT.percent 100 100 | , SvgA.height <| SvgT.percent 100 101 | , SvgA.rx <| SvgT.px 5 102 | , SvgA.ry <| SvgT.px 5 103 | , SvgA.fill <| SvgT.Paint Color.black 104 | ] 105 | [] 106 | 107 | highlightedBlocks = 108 | case highlightAnimation of 109 | Just animation -> 110 | HighlightAnimation.animatedBlocks animation 111 | |> withOpacity (HighlightAnimation.animatedOpacity animation) 112 | |> asFilled 113 | |> drawBlocks config (HighlightAnimation.animatedColour animation) 114 | 115 | Nothing -> 116 | [] 117 | 118 | gridSvg = 119 | if showGridLines then 120 | grid config 121 | 122 | else 123 | [] 124 | 125 | pauseOverlaySvg = 126 | if showPauseOverlay then 127 | pauseOverlay 128 | 129 | else 130 | [] 131 | in 132 | Element.el borderAttrs 133 | (Element.html <| 134 | svg 135 | [ SvgA.width <| boardSizeX config, SvgA.height <| boardSizeY config ] 136 | ([ blockSvgDefs config.cellSize, background ] 137 | ++ gridSvg 138 | ++ drawBlocks config identity (asUnfilled previewLandingBlocks) 139 | ++ drawBlocks config identity (asFilled normalBlocks) 140 | ++ highlightedBlocks 141 | ++ overlay 142 | ++ pauseOverlaySvg 143 | ) 144 | ) 145 | 146 | 147 | {-| Gets a rectangle with 60% opacity to overlay the full board rectangle (to fade its original contents out a bit), with 148 | a "Pause" image on it. Used when the game is paused. 149 | -} 150 | pauseOverlay : List (Svg msg) 151 | pauseOverlay = 152 | let 153 | bar x = 154 | Svg.rect 155 | [ SvgA.width <| SvgT.percent 10 156 | , SvgA.height <| SvgT.percent 20 157 | , SvgA.x <| SvgT.percent x 158 | , SvgA.y <| SvgT.percent 40 159 | , SvgA.rx <| SvgT.px 3 160 | , SvgA.ry <| SvgT.px 3 161 | , SvgA.fill <| SvgT.Paint Color.white 162 | ] 163 | [] 164 | in 165 | [ Svg.rect 166 | [ SvgA.width <| SvgT.percent 100 167 | , SvgA.height <| SvgT.percent 100 168 | , SvgA.fill <| SvgT.Paint <| Color.rgb255 50 50 50 169 | , SvgA.opacity <| SvgT.Opacity 0.6 170 | ] 171 | [] 172 | , bar 35 173 | , bar 55 174 | ] 175 | 176 | 177 | {-| Converts a list of tuples containing coordinates and colour into a list of `BlockViewInfo`, by setting the specified 178 | opacity on each one (and converting the tuples to records). 179 | -} 180 | withOpacity : Float -> List ( Coord, Shape.BlockColour ) -> List BlockViewInfo 181 | withOpacity opacity blocks = 182 | blocks |> List.map (\( coord, colour ) -> { coord = coord, colour = colour, opacity = opacity }) 183 | 184 | 185 | {-| Converts the passed in list of `BlockViewInfo` records to a list of records in the format required by the 186 | `drawBlocks` function, setting their `fillType` to `Filled`, with the given opacity. 187 | -} 188 | asFilled : List BlockViewInfo -> List { coord : Coord, colour : Shape.BlockColour, fillType : BlockFillType } 189 | asFilled blocks = 190 | blocks |> List.map (\{ coord, colour, opacity } -> { coord = coord, colour = colour, fillType = Filled opacity }) 191 | 192 | 193 | {-| Converts the passed in list of `BlockViewInfo` records to a list of records in the format required by the 194 | `drawBlocks` function, setting their `fillType` to `Unfilled`. 195 | -} 196 | asUnfilled : List ( Coord, Shape.BlockColour ) -> List { coord : Coord, colour : Shape.BlockColour, fillType : BlockFillType } 197 | asUnfilled blocks = 198 | blocks |> List.map (\( coord, colour ) -> { coord = coord, colour = colour, fillType = Unfilled }) 199 | 200 | 201 | {-| Converts a list of coordinates to a tuple containing the coordinates and the given colour. 202 | -} 203 | withColour : Shape.BlockColour -> List Coord -> List ( Coord, Shape.BlockColour ) 204 | withColour colour coords = 205 | coords |> List.map (\coord -> ( coord, colour )) 206 | 207 | 208 | {-| Renders an overlay of the given colour which is transparent in the middle but gradually increases its opacity, which 209 | provides the effect of the edges of the board "fading out". 210 | -} 211 | fadeEdgesOverlay : Color -> List (Svg msg) 212 | fadeEdgesOverlay colourToFadeTo = 213 | let 214 | fadeOutOverlayId = 215 | "fade-out-overlay" 216 | in 217 | [ Svg.defs [] 218 | [ Svg.radialGradient [ SvgA.id fadeOutOverlayId ] 219 | [ Svg.stop [ SvgA.offset "50%", SvgA.stopOpacity <| SvgT.Opacity 0, SvgA.stopColor <| Color.toCssString colourToFadeTo ] [] 220 | , Svg.stop [ SvgA.offset "100%", SvgA.stopOpacity <| SvgT.Opacity 100, SvgA.stopColor <| Color.toCssString colourToFadeTo ] [] 221 | ] 222 | ] 223 | , Svg.rect 224 | [ SvgA.width <| SvgT.percent 100 225 | , SvgA.height <| SvgT.percent 100 226 | , SvgA.rx <| SvgT.px 5 227 | , SvgA.ry <| SvgT.px 5 228 | , SvgA.fill <| SvgT.Reference fadeOutOverlayId 229 | ] 230 | [] 231 | ] 232 | 233 | 234 | {-| Draws the supplied blocks using the given functions to get the actual colours to apply to each one. `colourConverter` 235 | is a function which is used to take the block's default colour and transform it (e.g. during an animation). 236 | -} 237 | drawBlocks : Config -> (Color -> Color) -> List { coord : Coord, colour : Shape.BlockColour, fillType : BlockFillType } -> List (Svg msg) 238 | drawBlocks config colourConverter blocks = 239 | blocks 240 | |> List.map 241 | (\{ coord, colour, fillType } -> drawBlock config coord fillType (blockColour colour |> colourConverter)) 242 | 243 | 244 | {-| Draws a block at the given coordinate, and of the given colour. 245 | -} 246 | drawBlock : Config -> Coord -> BlockFillType -> Color -> Svg msg 247 | drawBlock config coord fillType colour = 248 | let 249 | ( x1, y1 ) = 250 | coordToGridPos config coord 251 | |> Tuple.mapBoth ((+) 1) ((+) 1) 252 | |> Tuple.mapBoth toFloat toFloat 253 | 254 | fillTypeAttrs = 255 | case fillType of 256 | Filled opacity -> 257 | [ SvgA.fill <| SvgT.Paint colour, SvgA.opacity <| SvgT.Opacity opacity ] 258 | 259 | Unfilled -> 260 | [ SvgA.stroke <| SvgT.Paint colour, SvgA.opacity <| SvgT.Opacity 0.6 ] 261 | in 262 | Svg.use ([ SvgA.xlinkHref "#block", SvgA.x <| SvgT.px x1, SvgA.y <| SvgT.px y1 ] ++ fillTypeAttrs) [] 263 | 264 | 265 | {-| Gets the SVG `defs` which is referred to by every block. Defines the way that a block is rendered. 266 | 267 | Taken from 268 | 269 | -} 270 | blockSvgDefs : Int -> Svg msg 271 | blockSvgDefs cellSize = 272 | let 273 | blockSize = 274 | cellSize - 2 |> toFloat 275 | 276 | edgeSize = 277 | blockSize / 8 278 | 279 | raisedInnerSize = 280 | blockSize - (2 * edgeSize) 281 | 282 | numberPair : Float -> Float -> String 283 | numberPair f1 f2 = 284 | String.join " " [ String.fromFloat f1, String.fromFloat f2 ] 285 | in 286 | Svg.defs [] 287 | [ Svg.g [ SvgA.id "block" ] 288 | [ Svg.rect [ SvgA.height <| SvgT.px blockSize, SvgA.width <| SvgT.px blockSize ] [] 289 | 290 | -- TODO: use folkertdev/svg-path-dsl instead of strings here? 291 | , Svg.path 292 | [ SvgA.fill <| SvgT.Paint <| Color.rgb255 230 230 230 293 | , SvgA.opacity <| SvgT.Opacity 0.7 294 | , SvgA.d <| 295 | String.join "," 296 | [ "m0" 297 | , numberPair 0 edgeSize 298 | , numberPair edgeSize raisedInnerSize 299 | , numberPair 0 edgeSize 300 | , String.fromFloat -edgeSize 301 | ] 302 | ] 303 | [] 304 | , Svg.path 305 | [ SvgA.fill <| SvgT.Paint Color.black 306 | , SvgA.opacity <| SvgT.Opacity 0.1 307 | , SvgA.d <| 308 | String.join "," 309 | [ "m0" 310 | , numberPair 0 edgeSize 311 | , numberPair edgeSize 0 312 | , numberPair raisedInnerSize -edgeSize 313 | , String.fromFloat edgeSize ++ " m" ++ String.fromFloat blockSize 314 | , numberPair -blockSize -edgeSize 315 | , numberPair edgeSize 0 316 | , numberPair raisedInnerSize edgeSize 317 | , String.fromFloat edgeSize 318 | ] 319 | ] 320 | [] 321 | , Svg.path 322 | [ SvgA.fill <| SvgT.Paint Color.black 323 | , SvgA.opacity <| SvgT.Opacity 0.5 324 | , SvgA.d <| 325 | String.join "," 326 | [ "m0" 327 | , numberPair blockSize edgeSize 328 | , numberPair -edgeSize raisedInnerSize 329 | , numberPair 0 edgeSize 330 | , String.fromFloat edgeSize 331 | ] 332 | ] 333 | [] 334 | ] 335 | ] 336 | 337 | 338 | {-| Draws the vertical and horizontal lines on the board that make it look like a grid. 339 | -} 340 | grid : Config -> List (Svg msg) 341 | grid ({ cellSize, colCount, rowCount } as config) = 342 | let 343 | drawLines : Int -> LineDirection -> List (Svg msg) 344 | drawLines cellCount direction = 345 | List.range 1 (cellCount - 1) 346 | |> List.map (gridLine config direction) 347 | in 348 | drawLines colCount Vertical ++ drawLines rowCount Horizontal 349 | 350 | 351 | type LineDirection 352 | = Horizontal 353 | | Vertical 354 | 355 | 356 | {-| Draws a line in the grid, in the given direction (top-to-bottom or left-to-right) at the given cell index. 357 | -} 358 | gridLine : Config -> LineDirection -> Int -> Svg msg 359 | gridLine ({ cellSize } as config) direction index = 360 | let 361 | offset = 362 | index * cellSize |> toFloat |> SvgT.px 363 | 364 | { x1, y1, x2, y2 } = 365 | case direction of 366 | Horizontal -> 367 | { x1 = SvgT.px 0, x2 = boardSizeX config, y1 = offset, y2 = offset } 368 | 369 | Vertical -> 370 | { x1 = offset, x2 = offset, y1 = SvgT.px 0, y2 = boardSizeY config } 371 | in 372 | Svg.line 373 | [ SvgA.x1 x1 374 | , SvgA.y1 y1 375 | , SvgA.x2 x2 376 | , SvgA.y2 y2 377 | , SvgA.stroke <| SvgT.Paint <| Color.rgb255 30 30 30 378 | , SvgA.strokeWidth <| SvgT.px 1 379 | ] 380 | [] 381 | 382 | 383 | {-| Gets the position on the grid of the bottom left hand corner of a cell with the supplied coordinates. 384 | -} 385 | coordToGridPos : Config -> Coord -> ( Int, Int ) 386 | coordToGridPos { cellSize, rowCount } ( x, y ) = 387 | ( x * cellSize, (rowCount - y - 1) * cellSize ) 388 | 389 | 390 | {-| The horizontal size of the board, in pixels. 391 | -} 392 | boardSizeX : Config -> SvgT.Length 393 | boardSizeX { cellSize, colCount } = 394 | cellSize * colCount |> toFloat |> SvgT.px 395 | 396 | 397 | {-| The vertical size of the board, in pixels. 398 | -} 399 | boardSizeY : Config -> SvgT.Length 400 | boardSizeY { cellSize, rowCount } = 401 | cellSize * rowCount |> toFloat |> SvgT.px 402 | 403 | 404 | elmUIColourToColour : Element.Color -> Color 405 | elmUIColourToColour = 406 | Element.toRgb >> Color.fromRgba 407 | 408 | 409 | blockColour : Shape.BlockColour -> Color 410 | blockColour colour = 411 | case colour of 412 | Shape.Cyan -> 413 | Color.rgb255 0 240 240 414 | 415 | Shape.Blue -> 416 | Color.rgb255 0 0 240 417 | 418 | Shape.Orange -> 419 | Color.rgb255 240 160 0 420 | 421 | Shape.Yellow -> 422 | Color.rgb255 240 240 0 423 | 424 | Shape.Green -> 425 | Color.rgb255 0 240 0 426 | 427 | Shape.Purple -> 428 | Color.rgb255 160 0 240 429 | 430 | Shape.Red -> 431 | Color.rgb255 240 0 0 432 | -------------------------------------------------------------------------------- /src/HighScores.elm: -------------------------------------------------------------------------------- 1 | module HighScores exposing 2 | ( HighScores 3 | , HighScoresModel 4 | , HighScoresMsg 5 | , HighScoresUpdateResult(..) 6 | , NewHighScoreModel 7 | , NewHighScoreMsg 8 | , NewHighScoreUpdateResult(..) 9 | , fromJson 10 | , highScoresDialogSubscriptions 11 | , highScoresView 12 | , initHighScoresDialog 13 | , initNewHighScoreDialog 14 | , newHighScoreDialogSubscriptions 15 | , newHighScoreView 16 | , updateHighScoresDialog 17 | , updateNewHighScoreDialog 18 | ) 19 | 20 | {-| This module contains all functionality related to high scores. Includes decoding/encoding the JSON representation 21 | stored in local storage, the `HighScores` type which contains those values so they can be shown to the user, and 22 | handling a new high score at the end of a game. 23 | 24 | It also provides the UI for the two ways the high scores are shown to the user: from the Welcome screen (where the user 25 | is shown a read-only copy of the high scores, and can choose to reset them, i.e. delete them all), and at the end of a 26 | game if the new score is high enough to go on the leaderboard, in which case the user is prompted for a name to store 27 | against this high score. 28 | 29 | -} 30 | 31 | import Browser.Dom 32 | import Element exposing (Element) 33 | import Element.Background 34 | import Element.Font 35 | import Element.Input 36 | import Html.Attributes 37 | import Json.Decode as JD 38 | import Json.Encode as JE 39 | import Modal 40 | import Ports 41 | import Task 42 | 43 | 44 | 45 | -- HIGH SCORES 46 | 47 | 48 | {-| The high scores (exposed as an opaque type). Stores the high scores as an ordered list. 49 | -} 50 | type HighScores 51 | = HighScores (List Entry) 52 | 53 | 54 | {-| An entry in the high scores list, i.e. the name of the person who got the high score, and the score itself. 55 | -} 56 | type alias Entry = 57 | { name : String, score : Int } 58 | 59 | 60 | empty : HighScores 61 | empty = 62 | HighScores [] 63 | 64 | 65 | isEmpty : HighScores -> Bool 66 | isEmpty (HighScores entries) = 67 | List.isEmpty entries 68 | 69 | 70 | 71 | -- JSON 72 | 73 | 74 | {-| Decodes the supplied JSON into a `HighScores` value, defaulting to using an empty set of high scores if the decoding 75 | fails. 76 | -} 77 | fromJson : JE.Value -> HighScores 78 | fromJson json = 79 | json |> JD.decodeValue (JD.list entryDecoder) |> Result.map fromEntries |> Result.withDefault empty 80 | 81 | 82 | entryDecoder : JD.Decoder Entry 83 | entryDecoder = 84 | JD.map2 Entry (JD.field "name" JD.string) (JD.field "score" JD.int) 85 | 86 | 87 | {-| Encodes the supplied `HighScores` to JSON. 88 | -} 89 | toJson : HighScores -> JE.Value 90 | toJson (HighScores entries) = 91 | entries |> JE.list encodeEntry 92 | 93 | 94 | encodeEntry : Entry -> JE.Value 95 | encodeEntry { name, score } = 96 | JE.object [ ( "name", JE.string name ), ( "score", JE.int score ) ] 97 | 98 | 99 | {-| From the supplied list, returns a `HighScores` value. This ensures that the data in the returned value is valid, 100 | i.e. has no more than `maxItems` in it, and is sorted (descending by score). 101 | -} 102 | fromEntries : List Entry -> HighScores 103 | fromEntries entries = 104 | entries 105 | |> List.take maxItems 106 | |> List.map (\entry -> { entry | name = String.left maxNameLength entry.name }) 107 | |> List.sortBy .score 108 | |> List.reverse 109 | |> HighScores 110 | 111 | 112 | {-| The maximum number of items to retain in the high scores. 113 | -} 114 | maxItems : Int 115 | maxItems = 116 | 5 117 | 118 | 119 | {-| The maximum number of characters allowed in a name in the high scores. 120 | -} 121 | maxNameLength : Int 122 | maxNameLength = 123 | 8 124 | 125 | 126 | 127 | -- FUNCTIONS SHARED BETWEEN HIGH-SCORES-VIEW AND NEW-HIGH-SCORE-VIEW 128 | 129 | 130 | {-| The common view function which displays the high scores in a modal dialog. Used both when showing the high scores, 131 | and when handling adding a new high score. 132 | -} 133 | view : String -> Modal.Config msg -> List (Element msg) -> Element msg 134 | view caption modalDialogConfig rows = 135 | Element.column 136 | [ Element.spacing 15 137 | , Element.centerX 138 | , Element.width <| Element.px 240 139 | , Element.Font.color <| Element.rgb255 200 200 200 140 | ] 141 | [ Element.el [ Element.centerX, Element.Font.bold, Element.Font.size 24 ] <| Element.text caption 142 | , Element.column [ Element.spacingXY 0 5, Element.Font.size 18, Element.width Element.fill ] rows 143 | ] 144 | |> Modal.dialog modalDialogConfig 145 | 146 | 147 | {-| A row in the list of high scores, where the name and score are displayed based on the supplied `nameElement` and 148 | `valueElement` parameters. 149 | -} 150 | highScoreRow : Int -> Element msg -> Element msg -> Element msg 151 | highScoreRow index nameElement scoreElement = 152 | Element.row [ Element.width Element.fill, Element.spacing 5, Element.height <| Element.px 25 ] 153 | [ index + 1 |> String.fromInt |> Element.text |> Element.el [ Element.alignLeft, Element.width <| Element.px 15 ] 154 | , Element.el [ Element.alignLeft, Element.width <| Element.px 150 ] nameElement 155 | , Element.el [ Element.alignRight ] scoreElement 156 | ] 157 | 158 | 159 | {-| A row in the list of high scores for when there isn't yet an entry at this index. 160 | -} 161 | emptyHighScoreRow : Int -> Element msg 162 | emptyHighScoreRow index = 163 | highScoreRow index Element.none Element.none 164 | 165 | 166 | {-| A row in the list of high scores representing an existing high score. 167 | -} 168 | existingHighScoreRow : Int -> Entry -> Element msg 169 | existingHighScoreRow index { name, score } = 170 | highScoreRow index (Element.text name) (populatedScoreElement score) 171 | 172 | 173 | populatedScoreElement : Int -> Element msg 174 | populatedScoreElement score = 175 | Element.text <| String.fromInt score 176 | 177 | 178 | {-| Appends the required number of empty entries to the supplied list to ensure that it has `maxItems` in it (i.e. 179 | pads the list). 180 | -} 181 | appendEmptyEntries : (Int -> a) -> List a -> List a 182 | appendEmptyEntries emptyEntryMapper list = 183 | List.range (List.length list) (maxItems - 1) 184 | |> List.map emptyEntryMapper 185 | |> (++) list 186 | 187 | 188 | 189 | -- HIGH SCORES VIEW 190 | 191 | 192 | {-| The model of the dialog which shows the high scores in a read-only mode to the user, but lets the user reset (i.e. 193 | delete) all the high scores. This dialog is shown from the High Scores button on the Welcome screen. 194 | -} 195 | type HighScoresModel 196 | = EmptyHighScores -- There are no high scores 197 | | PopulatedHighScores HighScores -- There are some high scores 198 | | ResetHighScores -- There were some high scores but the user chose to reset them - this hasn't been "committed" yet though. 199 | 200 | 201 | {-| The messages in the dialog which shows the high scores in a read-only mode to the user, but lets the user reset (i.e. 202 | delete) all the high scores. 203 | -} 204 | type HighScoresMsg 205 | = HighScoresResetRequested 206 | | HighScoresSubmitted 207 | | HighScoresCancelled 208 | 209 | 210 | {-| Initialises the the dialog which shows the high scores in a read-only mode to the user, but lets the user reset (i.e. 211 | delete) all the high scores. 212 | -} 213 | initHighScoresDialog : HighScores -> HighScoresModel 214 | initHighScoresDialog highScores = 215 | if isEmpty highScores then 216 | EmptyHighScores 217 | 218 | else 219 | PopulatedHighScores highScores 220 | 221 | 222 | {-| The value returned from `updateHighScoresDialog`, informing the caller how to proceed: 223 | 224 | - `KeepOpen_`: The modal should stay open. Its model is the data associated with this variant. 225 | - `Close_`: The modal should be closed. The associated data is a `Maybe` which, if it isn't `Nothing`, contains the 226 | newly updated (i.e. reset) high scores, and a command to run (which will be persisting those new high scores to 227 | local storage via a port). 228 | 229 | -} 230 | type HighScoresUpdateResult 231 | = KeepOpen_ HighScoresModel 232 | | Close_ (Maybe ( HighScores, Cmd HighScoresMsg )) 233 | 234 | 235 | {-| The standard `update` function when the high scores are shown to the user in read-only mode. See 236 | `HighScoresUpdateResult` for more info. 237 | -} 238 | updateHighScoresDialog : HighScoresMsg -> HighScoresModel -> HighScoresUpdateResult 239 | updateHighScoresDialog msg model = 240 | case ( msg, model ) of 241 | ( HighScoresResetRequested, _ ) -> 242 | KeepOpen_ ResetHighScores 243 | 244 | ( HighScoresSubmitted, ResetHighScores ) -> 245 | Close_ <| Just ( empty, empty |> toJson |> Ports.persistHighScores ) 246 | 247 | ( HighScoresSubmitted, _ ) -> 248 | -- UI shouldn't allow user to submit the dialog if the high scores haven't been reset 249 | Close_ Nothing 250 | 251 | ( HighScoresCancelled, _ ) -> 252 | Close_ Nothing 253 | 254 | 255 | {-| The view for when the high scores are shown to the user in read-only mode. 256 | -} 257 | highScoresView : HighScoresModel -> Element HighScoresMsg 258 | highScoresView model = 259 | let 260 | entries = 261 | case model of 262 | PopulatedHighScores (HighScores entries_) -> 263 | entries_ |> List.indexedMap existingHighScoreRow 264 | 265 | _ -> 266 | [] 267 | in 268 | entries 269 | |> appendEmptyEntries emptyHighScoreRow 270 | |> view "High Scores" (highScoresModalConfig model) 271 | 272 | 273 | {-| The config for the modal dialog when showing the high scores in read-only mode. Depending on whether there are any 274 | high scores, and whether the user has chosen to reset them or not, different buttons are shown/enabled. 275 | -} 276 | highScoresModalConfig : HighScoresModel -> Modal.Config HighScoresMsg 277 | highScoresModalConfig model = 278 | case model of 279 | EmptyHighScores -> 280 | { closeButton = Modal.Close { onPress = HighScoresCancelled } 281 | , submitButton = Modal.None 282 | , customButtons = [] 283 | } 284 | 285 | PopulatedHighScores _ -> 286 | { closeButton = Modal.Close { onPress = HighScoresCancelled } 287 | , submitButton = Modal.Save { onPress = Nothing } 288 | , customButtons = [ { caption = "Reset", onPress = Just HighScoresResetRequested } ] 289 | } 290 | 291 | ResetHighScores -> 292 | { closeButton = Modal.Cancel { onPress = HighScoresCancelled } 293 | , submitButton = Modal.Save { onPress = Just HighScoresSubmitted } 294 | , customButtons = [ { caption = "Reset", onPress = Nothing } ] 295 | } 296 | 297 | 298 | 299 | -- NEW HIGH SCORE VIEW 300 | 301 | 302 | {-| The model of the dialog which lets the user add a new high score at the end of a game. 303 | 304 | This acts a bit like a zipper: there is the (ordered) list of entries above the new one, and the same for below, and 305 | a single entry for the new one being added (for which the user is prompted to supply a name). 306 | 307 | -} 308 | type NewHighScoreModel 309 | = NewHighScoreModel { above : List Entry, new : Entry, below : List Entry } 310 | 311 | 312 | toHighScores : NewHighScoreModel -> HighScores 313 | toHighScores (NewHighScoreModel { above, new, below }) = 314 | List.concat [ above, [ new ], below ] |> fromEntries 315 | 316 | 317 | {-| The messages in the dialog which lets the user add a new high score at the end of a game. 318 | -} 319 | type NewHighScoreMsg 320 | = NewHighScoreNameChanged String 321 | | NewHighScoreSubmitted 322 | | NewHighScoreCancelled 323 | | NewHighScoreNameFocused 324 | 325 | 326 | {-| Possibly initialises the the dialog which lets the user add a new high score at the end of a game. This depends on 327 | whether the supplied score is high enough to be a new score. If it isn't, returns `Nothing`. Otherwise returns a tuple 328 | containing the `NewHighScoreModel`, and a command to run (used to set focus to the Name control in the UI). 329 | -} 330 | initNewHighScoreDialog : Int -> HighScores -> Maybe ( NewHighScoreModel, Cmd NewHighScoreMsg ) 331 | initNewHighScoreDialog score highScores = 332 | withPossibleNewHighScore score highScores 333 | |> Maybe.map 334 | (\model -> 335 | ( model 336 | , Browser.Dom.focus newHighScoreNameInputId |> Task.attempt (always NewHighScoreNameFocused) 337 | ) 338 | ) 339 | 340 | 341 | {-| The ID of the input asking the user to enter a name for a new high score. 342 | -} 343 | newHighScoreNameInputId : String 344 | newHighScoreNameInputId = 345 | "high-score-name" 346 | 347 | 348 | {-| The value returned from `updateNewHighScoreDialog`, informing the caller how to proceed: 349 | 350 | - `KeepOpen`: The modal should stay open. Its model is the data associated with this variant. 351 | - `Close`: The modal should be closed open. The associated data is a `Maybe` which, if it isn't `Nothing`, contains 352 | the updated high scores, including the new score just added, and a command to run (which will be persisting those 353 | new high scores to local storage via a port). 354 | 355 | -} 356 | type NewHighScoreUpdateResult 357 | = KeepOpen NewHighScoreModel 358 | | Close (Maybe ( HighScores, Cmd NewHighScoreMsg )) 359 | 360 | 361 | {-| The standard `update` function when a new high score is being added. See `NewHighScoreUpdateResult` for more info. 362 | -} 363 | updateNewHighScoreDialog : NewHighScoreMsg -> NewHighScoreModel -> NewHighScoreUpdateResult 364 | updateNewHighScoreDialog msg model = 365 | case msg of 366 | NewHighScoreNameChanged name -> 367 | KeepOpen <| setName name model 368 | 369 | NewHighScoreSubmitted -> 370 | let 371 | highScores = 372 | toHighScores model 373 | in 374 | Close <| Just ( highScores, highScores |> toJson |> Ports.persistHighScores ) 375 | 376 | NewHighScoreCancelled -> 377 | Close Nothing 378 | 379 | NewHighScoreNameFocused -> 380 | KeepOpen model 381 | 382 | 383 | {-| Checks whether the supplied score is high enough to be added as a new high score. Returns `Nothing` if it isn't. 384 | Otherwise returns a `NewHighScoreModel` used to them show the UI to let the user enter a name against this new score. 385 | -} 386 | withPossibleNewHighScore : Int -> HighScores -> Maybe NewHighScoreModel 387 | withPossibleNewHighScore score (HighScores entries) = 388 | if score == 0 then 389 | Nothing 390 | 391 | else 392 | let 393 | ( above, below ) = 394 | entries |> List.partition (\entry -> entry.score >= score) 395 | 396 | aboveCount = 397 | List.length above 398 | in 399 | if aboveCount >= maxItems then 400 | Nothing 401 | 402 | else 403 | Just <| 404 | NewHighScoreModel 405 | { above = above 406 | , new = { name = "", score = score } 407 | , below = List.take (maxItems - aboveCount - 1) below 408 | } 409 | 410 | 411 | {-| Maps the items in the `NewHighScoreModel`, using a different mapper for existing entries, the new entry, and empty 412 | entries. 413 | -} 414 | map : (Int -> Entry -> a) -> (Int -> Entry -> a) -> (Int -> a) -> NewHighScoreModel -> List a 415 | map existingEntriesMapper newEntryMapper emptyEntryMapper (NewHighScoreModel { above, new, below }) = 416 | List.concat 417 | [ List.indexedMap existingEntriesMapper above 418 | , [ newEntryMapper (List.length above) new ] 419 | , List.indexedMap existingEntriesMapper below 420 | ] 421 | |> appendEmptyEntries emptyEntryMapper 422 | 423 | 424 | isNamePopulated : NewHighScoreModel -> Bool 425 | isNamePopulated (NewHighScoreModel { new }) = 426 | new.name |> String.trim |> String.isEmpty 427 | 428 | 429 | setName : String -> NewHighScoreModel -> NewHighScoreModel 430 | setName newName (NewHighScoreModel data) = 431 | NewHighScoreModel { data | new = data.new |> withName newName } 432 | 433 | 434 | withName : String -> Entry -> Entry 435 | withName name entry = 436 | { entry | name = String.left maxNameLength <| name } 437 | 438 | 439 | {-| The view for when a new high score is being added. 440 | -} 441 | newHighScoreView : NewHighScoreModel -> Element NewHighScoreMsg 442 | newHighScoreView model = 443 | model 444 | |> map existingHighScoreRow newHighScoreRow emptyHighScoreRow 445 | |> view "New High Score" (newHighScoreModalConfig model) 446 | 447 | 448 | {-| The config for the modal dialog when handling a new high score. Depending on whether or not the name is populated, 449 | the Save button will be enabled/disabled. 450 | -} 451 | newHighScoreModalConfig : NewHighScoreModel -> Modal.Config NewHighScoreMsg 452 | newHighScoreModalConfig model = 453 | let 454 | onSubmit = 455 | if isNamePopulated model then 456 | Nothing 457 | 458 | else 459 | Just NewHighScoreSubmitted 460 | in 461 | Modal.defaultConfig NewHighScoreCancelled onSubmit 462 | 463 | 464 | newHighScoreRow : Int -> Entry -> Element NewHighScoreMsg 465 | newHighScoreRow index { name, score } = 466 | let 467 | nameElement = 468 | Element.Input.text 469 | [ Element.Background.color <| Element.rgb255 100 100 100 470 | , Element.padding 6 471 | , Element.Font.semiBold 472 | , Element.Font.size 16 473 | , Element.htmlAttribute <| Html.Attributes.id newHighScoreNameInputId 474 | ] 475 | { text = name 476 | , label = Element.Input.labelHidden "Name" 477 | , onChange = NewHighScoreNameChanged 478 | , placeholder = Nothing 479 | } 480 | in 481 | highScoreRow index nameElement (populatedScoreElement score) 482 | 483 | 484 | 485 | -- SUBSCRIPTIONS 486 | 487 | 488 | highScoresDialogSubscriptions : HighScoresModel -> Sub HighScoresMsg 489 | highScoresDialogSubscriptions model = 490 | Modal.subscriptions <| highScoresModalConfig model 491 | 492 | 493 | newHighScoreDialogSubscriptions : NewHighScoreModel -> Sub NewHighScoreMsg 494 | newHighScoreDialogSubscriptions model = 495 | Modal.subscriptions <| newHighScoreModalConfig model 496 | -------------------------------------------------------------------------------- /tests/GameTests.elm: -------------------------------------------------------------------------------- 1 | module GameTests exposing (suite) 2 | 3 | {-| Tests for the Game module. Game is an opaque type so we can't construct it ourselves here, pre-populated in some 4 | way. Instead, we start off with a new game (supplying a known set of shapes rather than random ones), then progress the 5 | game by simulating user and timer actions. 6 | -} 7 | 8 | import Coord exposing (Coord) 9 | import Dict exposing (Dict) 10 | import Expect exposing (Expectation) 11 | import Game exposing (Game) 12 | import GameBoard 13 | import Shape exposing (Shape) 14 | import ShapeUtils 15 | import Test exposing (Test, describe, test) 16 | 17 | 18 | suite : Test 19 | suite = 20 | describe "Game" 21 | [ test "Drops initial shape two rows after two timer drop events." <| 22 | \_ -> 23 | newGame defaultInitialGameState 24 | |> repeat 2 timerDrop 25 | |> expectGame 26 | (ExpectedGame 27 | { game = buildAsciiGame BottomPadding """ 28 | ---------- 29 | ---------- 30 | -----o---- 31 | ---ooo---- 32 | """ 33 | , rowRemoval = NoRowRemoval 34 | } 35 | ) 36 | , test "Highlights landed shape after moving initial shape to left edge then letting it drop to bottom." <| 37 | \_ -> 38 | newGame defaultInitialGameState 39 | |> repeat 3 (executeUserActions [ Game.Move Game.Left ]) 40 | |> repeat 18 timerDrop 41 | |> expectGame 42 | (ExpectedGame 43 | { game = buildAsciiGame TopPadding """ 44 | --O------- 45 | OOO------- 46 | """ 47 | , rowRemoval = NoRowRemoval 48 | } 49 | ) 50 | , test "Next shape appears after shape drops to bottom (and bottom shape no longer highlighted)." <| 51 | \_ -> 52 | newGame defaultInitialGameState 53 | |> repeat 3 (executeUserActions [ Game.Move Game.Left ]) 54 | |> repeat 19 timerDrop 55 | |> expectGame 56 | (ExpectedGame 57 | { game = buildAsciiGame NoPadding """ 58 | ----yy---- 59 | ----yy---- 60 | ---------- 61 | ---------- 62 | ---------- 63 | ---------- 64 | ---------- 65 | ---------- 66 | ---------- 67 | ---------- 68 | ---------- 69 | ---------- 70 | ---------- 71 | ---------- 72 | ---------- 73 | ---------- 74 | ---------- 75 | ---------- 76 | --o------- 77 | ooo------- 78 | """ 79 | , rowRemoval = NoRowRemoval 80 | } 81 | ) 82 | , test "Completed row highlighted." <| 83 | \_ -> 84 | newGame defaultInitialGameState 85 | -- Move blue L to the left (will first first three columns) 86 | |> repeat 3 (executeUserActions [ Game.Move Game.Left ]) 87 | -- Drop it the 18 rows required to get it to the bottom, then timer drop to make next shape appear. 88 | |> repeat 18 (executeUserActions [ Game.Move Game.Down ]) 89 | |> progressGame timerDrop 90 | -- Red square has now appeared: move it left one, then drop it to fill columns 4 and 5. 91 | |> progressGame (executeUserActions [ Game.Move Game.Left ]) 92 | |> repeat 18 (executeUserActions [ Game.Move Game.Down ]) 93 | |> progressGame timerDrop 94 | -- Yellow line has now appeared: move it right two then drop it to fill columns 6-9 (intersperse 95 | -- some timer drops before the user interactions). 96 | |> repeat 2 timerDrop 97 | |> progressGame (executeUserActions [ Game.Move Game.Right ]) 98 | |> progressGame timerDrop 99 | |> progressGame (executeUserActions [ Game.Move Game.Right ]) 100 | |> repeat 15 (executeUserActions [ Game.Move Game.Down ]) 101 | |> progressGame timerDrop 102 | -- Green T has now appeared: it's on its back so rotate it once anti-clockwise then move it 103 | -- all the way to the right before dropping it. 104 | |> progressGame (executeUserActions [ Game.Rotate Shape.Anticlockwise ]) 105 | |> repeat 5 (executeUserActions [ Game.Move Game.Right ]) 106 | |> repeat 17 (executeUserActions [ Game.Move Game.Down ]) 107 | |> progressGame timerDrop 108 | |> expectGame 109 | (ExpectedGame 110 | { game = buildAsciiGame TopPadding """ 111 | ---------p 112 | --oyy---pp 113 | OOOYYCCCCP 114 | """ 115 | , rowRemoval = RowBeingRemoved 116 | } 117 | ) 118 | , test "New shape added after completed row removed." <| 119 | \_ -> 120 | newGame defaultInitialGameState 121 | -- Repeat same steps as previous test, then update the game to make the completed row disappear, and 122 | -- the next shape appear. 123 | |> repeat 3 (executeUserActions [ Game.Move Game.Left ]) 124 | |> repeat 18 (executeUserActions [ Game.Move Game.Down ]) 125 | |> progressGame timerDrop 126 | |> progressGame (executeUserActions [ Game.Move Game.Left ]) 127 | |> repeat 18 (executeUserActions [ Game.Move Game.Down ]) 128 | |> progressGame timerDrop 129 | |> repeat 2 timerDrop 130 | |> progressGame (executeUserActions [ Game.Move Game.Right ]) 131 | |> progressGame timerDrop 132 | |> progressGame (executeUserActions [ Game.Move Game.Right ]) 133 | |> repeat 15 (executeUserActions [ Game.Move Game.Down ]) 134 | |> progressGame timerDrop 135 | |> progressGame (executeUserActions [ Game.Rotate Shape.Anticlockwise ]) 136 | |> repeat 5 (executeUserActions [ Game.Move Game.Right ]) 137 | |> repeat 17 (executeUserActions [ Game.Move Game.Down ]) 138 | |> progressGame timerDrop 139 | |> simulateRowRemovalAnimationComplete 140 | |> expectGame 141 | (ExpectedGame 142 | { game = buildAsciiGame TopPadding """ 143 | ---rr----- 144 | ----rr---- 145 | ---------- 146 | ---------- 147 | ---------- 148 | ---------- 149 | ---------- 150 | ---------- 151 | ---------- 152 | ---------- 153 | ---------- 154 | ---------- 155 | ---------- 156 | ---------- 157 | ---------- 158 | ---------- 159 | ---------- 160 | ---------- 161 | ---------p 162 | --oyy---pp 163 | """ 164 | , rowRemoval = NoRowRemoval 165 | } 166 | ) 167 | , test "Does not move shape off board if user tries to move it too much." <| 168 | \_ -> 169 | newGame defaultInitialGameState 170 | |> repeat 20 (executeUserActions [ Game.Move Game.Left ]) 171 | |> expectGame 172 | (ExpectedGame 173 | { game = buildAsciiGame BottomPadding """ 174 | --o------- 175 | ooo------- 176 | """ 177 | , rowRemoval = NoRowRemoval 178 | } 179 | ) 180 | , test "Moves L-shape back into play if rotation would cause it to move off the side." <| 181 | \_ -> 182 | -- Start off with the normal L-shape on its back 183 | newGame defaultInitialGameState 184 | -- Rotate it once so it's the right way up 185 | |> progressGame (executeUserActions [ Game.Rotate Shape.Clockwise ]) 186 | -- Move it all the way to the left 187 | |> repeat 5 (executeUserActions [ Game.Move Game.Left ]) 188 | -- Rotate it clockwise again: naturally this will mean the shape is now off the board so this 189 | -- wouldn't be allowed, but we have logic to "shift" it back into place (i.e. go back one cell to 190 | -- the right). 191 | |> progressGame (executeUserActions [ Game.Rotate Shape.Clockwise ]) 192 | |> expectGame 193 | (ExpectedGame 194 | { game = buildAsciiGame BottomPadding """ 195 | ---------- 196 | ooo------- 197 | o--------- 198 | """ 199 | , rowRemoval = NoRowRemoval 200 | } 201 | ) 202 | , test "Moves line shape back into play if rotation would cause it to move off the side." <| 203 | \_ -> 204 | -- Same as previous test but with line: turn it so it's vertical then move it all the way (to the right 205 | -- this time), then rotate it. 206 | defaultInitialGameState 207 | |> withInitialShape (ShapeUtils.getShape ShapeUtils.Line) 208 | |> newGame 209 | |> progressGame (executeUserActions [ Game.Rotate Shape.Clockwise ]) 210 | |> repeat 5 (executeUserActions [ Game.Move Game.Right ]) 211 | |> progressGame (executeUserActions [ Game.Rotate Shape.Clockwise ]) 212 | |> expectGame 213 | (ExpectedGame 214 | { game = buildAsciiGame BottomPadding """ 215 | ---------- 216 | ---------- 217 | ------cccc 218 | """ 219 | , rowRemoval = NoRowRemoval 220 | } 221 | ) 222 | ] 223 | 224 | 225 | {-| Describes whether, at any given point, the game is (or is expected to be) in a state where lines are being removed. 226 | -} 227 | type RowRemoval 228 | = NoRowRemoval 229 | | RowBeingRemoved 230 | 231 | 232 | {-| A string representation of the blocks in the game (corresponding to what we get back from calling `Game.blocks`). 233 | The string is a 10\*20 grid of characters where each cell is either a `-` for empty cells, or a character for occupied 234 | cells, where that character represents the colour. See `occupiedCellChar` for more details. 235 | -} 236 | type AsciiGame 237 | = AsciiGame String 238 | 239 | 240 | {-| Describes the expected state of a game at any given point. 241 | -} 242 | type ExpectedGame 243 | = ExpectedGame { game : AsciiGame, rowRemoval : RowRemoval } 244 | 245 | 246 | {-| Contains the state of a game at a given point. 247 | -} 248 | type alias GameState = 249 | { game : Game (List Shape), rowRemoval : RowRemoval } 250 | 251 | 252 | {-| Creates an expectation that the state of supplied game matches the supplied expected state. 253 | -} 254 | expectGame : ExpectedGame -> GameState -> Expectation 255 | expectGame (ExpectedGame expected) actual = 256 | Expect.equal ( gameAsAscii actual.game, actual.rowRemoval ) ( expected.game, expected.rowRemoval ) 257 | 258 | 259 | {-| Gets a string representation of the the supplied game, so it can be compared to an expected game state. 260 | -} 261 | gameAsAscii : Game (List Shape) -> AsciiGame 262 | gameAsAscii game = 263 | let 264 | { normal, highlighted } = 265 | Game.blocks game 266 | 267 | mapBlocks : Bool -> List ( Coord, Shape.BlockColour ) -> List ( Coord, ( Shape.BlockColour, Bool ) ) 268 | mapBlocks isHighlighted = 269 | List.map (\( coord, colour ) -> ( coord, ( colour, isHighlighted ) )) 270 | 271 | allBlocks : Dict Coord ( Shape.BlockColour, Bool ) 272 | allBlocks = 273 | List.concat [ mapBlocks False normal, mapBlocks True highlighted ] 274 | |> Dict.fromList 275 | 276 | cellAsString : Int -> Int -> String 277 | cellAsString x y = 278 | case Dict.get ( x, y ) allBlocks of 279 | Just ( colour, isHighlighted ) -> 280 | occupiedCellChar colour isHighlighted 281 | 282 | Nothing -> 283 | "-" 284 | 285 | row : Int -> String 286 | row y = 287 | List.range 0 (GameBoard.colCount - 1) 288 | |> List.map (\x -> cellAsString x y) 289 | |> String.concat 290 | in 291 | List.range 0 (GameBoard.rowCount - 1) 292 | |> List.map row 293 | |> List.reverse 294 | |> String.join "\n" 295 | |> AsciiGame 296 | 297 | 298 | {-| Describes whether a string representation of a board should be padded at the bottom or the top. See `padAsciiBoard` 299 | for more info. 300 | -} 301 | type AsciiBoardPadType 302 | = BottomPadding 303 | | TopPadding 304 | | NoPadding 305 | 306 | 307 | {-| Builds an `AsciiGame` from the supplied string representation of it, where that string representation can miss the 308 | bottom or top of the board out by any number of rows - they will be padded with empty rows. Allows the game state to be 309 | represented in tests with fewer lines. 310 | -} 311 | buildAsciiGame : AsciiBoardPadType -> String -> AsciiGame 312 | buildAsciiGame padType board = 313 | let 314 | suppliedLines : List String 315 | suppliedLines = 316 | String.trim board |> String.split "\n" |> List.map String.trim 317 | 318 | emptyRow : String 319 | emptyRow = 320 | List.repeat GameBoard.colCount "-" |> String.concat 321 | 322 | padding : List String 323 | padding = 324 | List.repeat 325 | (GameBoard.rowCount - List.length suppliedLines) 326 | emptyRow 327 | 328 | allLines = 329 | case padType of 330 | BottomPadding -> 331 | suppliedLines ++ padding 332 | 333 | TopPadding -> 334 | padding ++ suppliedLines 335 | 336 | NoPadding -> 337 | suppliedLines 338 | in 339 | allLines 340 | |> String.join "\n" 341 | |> AsciiGame 342 | 343 | 344 | {-| Starts a new game with the supplied initialisation info, and returns a `GameState` record ready to start the tests. 345 | -} 346 | newGame : List Shape -> GameState 347 | newGame shapeBuffer = 348 | { game = Game.new getNextShape shapeBuffer, rowRemoval = NoRowRemoval } 349 | 350 | 351 | getNextShape : List Shape -> ( Shape, List Shape ) 352 | getNextShape shapes = 353 | case shapes of 354 | [] -> 355 | Debug.todo "Not enough shapes in test shape buffer" 356 | 357 | first :: rest -> 358 | ( first, rest ) 359 | 360 | 361 | {-| The default initial state to use when creating a new game. The initial shapes allow a full row to be completed with 362 | the first four shapes. The shapes in order are: 363 | 364 | - L (orange) 365 | - Square (yellow) 366 | - Line (cyan) 367 | - T (purple) 368 | - Z (red) 369 | - S (green) 370 | - L-mirror (blue) 371 | 372 | -} 373 | defaultInitialGameState : List Shape 374 | defaultInitialGameState = 375 | List.map ShapeUtils.getShape 376 | [ ShapeUtils.LShape 377 | , ShapeUtils.Square 378 | , ShapeUtils.Line 379 | , ShapeUtils.TShape 380 | , ShapeUtils.ZShape 381 | , ShapeUtils.SShape 382 | , ShapeUtils.LMirrorShape 383 | ] 384 | 385 | 386 | {-| Returns a copy of the supplied list, with the first entry replaced with the supplied shape. 387 | -} 388 | withInitialShape : Shape -> List Shape -> List Shape 389 | withInitialShape initialShape shapes = 390 | case shapes of 391 | [] -> 392 | [ initialShape ] 393 | 394 | _ :: rest -> 395 | initialShape :: rest 396 | 397 | 398 | timerDrop : Game (List Shape) -> Game.UpdateResult (List Shape) 399 | timerDrop = 400 | Game.timerDrop getNextShape 401 | 402 | 403 | executeUserActions : List Game.UserAction -> Game (List Shape) -> Game.UpdateResult (List Shape) 404 | executeUserActions actions = 405 | Game.executeUserActions getNextShape actions 406 | 407 | 408 | {-| Progresses the game by executing some function that updates the game (e.g. `Game.timerDrop` or `Game.rotateShape`). 409 | This can either be simulating a user action like pressing an arrow, or simulating a timer event. 410 | -} 411 | progressGame : (Game (List Shape) -> Game.UpdateResult (List Shape)) -> GameState -> GameState 412 | progressGame action state = 413 | let 414 | gameUpdateResult = 415 | action state.game 416 | in 417 | case gameUpdateResult of 418 | Game.NoChange -> 419 | state 420 | 421 | Game.Continue { game } -> 422 | { game = game, rowRemoval = NoRowRemoval } 423 | 424 | Game.RowBeingRemoved { game } -> 425 | { game = game, rowRemoval = RowBeingRemoved } 426 | 427 | Game.GameOver _ -> 428 | -- TODO: is this OK to do in tests? 429 | Debug.todo "Unexpected game over" 430 | 431 | Game.Paused _ -> 432 | state 433 | 434 | 435 | {-| Executes the given action the given number of times, starting from the supplied state, and returning the state at the 436 | end of all those actions. 437 | -} 438 | repeat : Int -> (Game (List Shape) -> Game.UpdateResult (List Shape)) -> GameState -> GameState 439 | repeat count action state = 440 | List.range 1 count 441 | |> List.foldl (\_ state_ -> progressGame action state_) state 442 | 443 | 444 | {-| Simulates the animation of a row removal having been completed, and progresses the game accordingly. 445 | -} 446 | simulateRowRemovalAnimationComplete : GameState -> GameState 447 | simulateRowRemovalAnimationComplete { game } = 448 | { game = Game.onRowRemovalAnimationComplete game, rowRemoval = NoRowRemoval } 449 | 450 | 451 | {-| Gets the character to use for a cell which is occupied, for the given colour and whether it's highlighted. The 452 | character is the first letter of the colour in lower-case normally, but upper-cased for highlighted cells. 453 | -} 454 | occupiedCellChar : Shape.BlockColour -> Bool -> String 455 | occupiedCellChar colour isHighlighted = 456 | let 457 | char = 458 | case colour of 459 | Shape.Blue -> 460 | "b" 461 | 462 | Shape.Red -> 463 | "r" 464 | 465 | Shape.Orange -> 466 | "o" 467 | 468 | Shape.Yellow -> 469 | "y" 470 | 471 | Shape.Purple -> 472 | "p" 473 | 474 | Shape.Green -> 475 | "g" 476 | 477 | Shape.Cyan -> 478 | "c" 479 | in 480 | if isHighlighted then 481 | String.toUpper char 482 | 483 | else 484 | char 485 | -------------------------------------------------------------------------------- /src/WelcomeScreen.elm: -------------------------------------------------------------------------------- 1 | module WelcomeScreen exposing (Model, Msg, UpdateResult(..), getHighScores, getSettings, init, subscriptions, update, view) 2 | 3 | {-| This module contains all functionality related to the welcome screen. Manages the animated board and functionality 4 | available from the Welcome screen, e.g. the Settings. 5 | -} 6 | 7 | import Array 8 | import BoardView 9 | import Button 10 | import Coord exposing (Coord) 11 | import DroppingShape exposing (DroppingShape) 12 | import Element exposing (Element) 13 | import HighScores exposing (HighScores) 14 | import HighlightAnimation 15 | import Random 16 | import Random.Array 17 | import Settings exposing (Settings) 18 | import SettingsScreen 19 | import Shape exposing (Shape) 20 | import Task 21 | import Time 22 | import UIHelpers 23 | 24 | 25 | 26 | -- MODEL 27 | 28 | 29 | {-| Represents a letter in the word "TETRIS", as a shape on a board, much like a normal Tetris shape. 30 | -} 31 | type alias Letter = 32 | { blocks : List Coord, colour : Shape.BlockColour, gridCoord : Coord } 33 | 34 | 35 | {-| The data associated with the `DroppingLetters` variant of `AnimatedBoard`. Defines the data required to show the 36 | welcome screen at the stage where the letters of Tetris are dropping onto the board one by one. 37 | 38 | - `landed`: the letters which have already landed. 39 | - `dropping`: the letter which is currently dropping down. 40 | - `next`: the letters which have yet to start dropping. 41 | - `randomSeed`: the seed to use to generate random colours. Also passed through to subsequent stages of the welcome 42 | screen so they have access to a random seed when they need randomness. This is initialised based on the current 43 | system time, using the `Initialised` message. 44 | 45 | -} 46 | type alias DroppingLettersData = 47 | { landed : List Letter 48 | , dropping : Letter 49 | , next : List Letter 50 | , randomSeed : Random.Seed 51 | } 52 | 53 | 54 | {-| The data associated with the `PulsingLetters` variant of `AnimatedBoard`. Defines the data required to show the 55 | welcome screen at the stage where the letters of Tetris have already landed and are now being pulsed (faded out then back 56 | in briefly). This stage doesn't actually use the `randomSeed` value but stores it so it can be passed to the subsequent 57 | stage (`DroppingRandomShapes`) which does need it. 58 | -} 59 | type alias PulsingLettersData = 60 | { letters : List Letter 61 | , animation : HighlightAnimation.Model 62 | , randomSeed : Random.Seed 63 | } 64 | 65 | 66 | {-| The data associated with the `DroppingRandomShapes` variant of `AnimatedBoard`. Defines the data required to show the 67 | welcome screen at the stage where the letters of Tetris have landed and been pulsed, and now random shapes drop down 68 | "behind" those letters. 69 | 70 | - `letters`: the letters of Tetris, which are rendered stationary. 71 | - `droppingShapes`: the shapes currently dropping down. 72 | - `shapeBuffer`: the buffer of shapes used to get a new shape whenever required. 73 | - `randomSeed`: the seed to use to generate random colours and starting positions for the dropping shapes. Also used 74 | to initialise the shape buffer. 75 | 76 | -} 77 | type alias DroppingRandomShapesData = 78 | { letters : List Letter 79 | , droppingShapes : List DroppingShape 80 | , shapeBuffer : Shape.Bag 81 | , randomSeed : Random.Seed 82 | } 83 | 84 | 85 | {-| The model of this module, exposed as an opaque type. 86 | -} 87 | type Model 88 | = Model ModelData 89 | 90 | 91 | type alias ModelData = 92 | { animatedBoard : AnimatedBoard, settings : Settings, highScores : HighScores, modal : ModalDialog } 93 | 94 | 95 | {-| Defines what modal (if any) is currently shown over the welcome screen. 96 | -} 97 | type ModalDialog 98 | = NoModal 99 | | SettingsModal SettingsScreen.Model 100 | | HighScoresModal HighScores.HighScoresModel 101 | 102 | 103 | {-| The state of the animated board on the Welcome screen. Defines the three stages of the animation, along with an 104 | `Initialising` state, used purely to get the current time to use a random seed: 105 | 106 | - `DroppingLetters`: The letters of the word "Tetris" are dropping onto the board, one by one. 107 | - `PulsingLetters`: The letters of the word "Tetris" are being "pulsed" (faded out then back in). 108 | - `DroppingRandomShapes`: Random shapes are dropping from the top of the board down till they disappear, behind the 109 | letters of Tetris. 110 | 111 | -} 112 | type AnimatedBoard 113 | = Initialising 114 | | DroppingLetters DroppingLettersData 115 | | PulsingLetters PulsingLettersData 116 | | DroppingRandomShapes DroppingRandomShapesData 117 | 118 | 119 | init : Settings -> HighScores -> ( Model, Cmd Msg ) 120 | init settings highScores = 121 | ( Model { animatedBoard = Initialising, settings = settings, highScores = highScores, modal = NoModal } 122 | , Time.now |> Task.perform (Time.posixToMillis >> Random.initialSeed >> Initialised) 123 | ) 124 | 125 | 126 | 127 | -- UPDATE 128 | 129 | 130 | type Msg 131 | = Initialised Random.Seed -- Ready to start the board animation (the supplied value is used as a random seed for various aspects) 132 | | LetterDropAnimationFrame -- A letter should be dropped another row (or a new letter added) 133 | | GotHighlightAnimationMsg HighlightAnimation.Msg -- A pulsing animation frame has occurred 134 | | ShapeDropDelayElapsed -- The delay between each time the dropping shapes are lowered a row has elapsed 135 | | StartGameRequested -- The user has clicked the Start Game button 136 | | ShowSettingsRequested -- The user has requested to see the Settings modal 137 | | GotSettingsScreenMsg SettingsScreen.Msg -- A message from Settings modal: handled by it 138 | | ShowHighScoresRequested -- The user has requested to see the High Scores modal 139 | | GotHighScoresScreenMsg HighScores.HighScoresMsg -- A message from High Scores modal: handled by it 140 | 141 | 142 | {-| Returned from the `update` function. Defines whether the calling module should stay on the Welcome screen, or whether 143 | it should start a new game. 144 | -} 145 | type UpdateResult 146 | = Stay 147 | | StartGame 148 | 149 | 150 | update : Msg -> Model -> ( Model, Cmd Msg, UpdateResult ) 151 | update msg ((Model { animatedBoard }) as model) = 152 | let 153 | stay ( nextModel, nextCmd ) = 154 | ( nextModel, nextCmd, Stay ) 155 | in 156 | case ( msg, animatedBoard ) of 157 | ( Initialised randomSeed, Initialising ) -> 158 | stay ( model |> withAnimatedBoard (initDroppingLetters randomSeed |> DroppingLetters), Cmd.none ) 159 | 160 | ( Initialised _, _ ) -> 161 | stay ( model, Cmd.none ) 162 | 163 | ( LetterDropAnimationFrame, DroppingLetters data ) -> 164 | stay ( model |> withAnimatedBoard (onLetterDropAnimationFrame data), Cmd.none ) 165 | 166 | ( LetterDropAnimationFrame, _ ) -> 167 | stay ( model, Cmd.none ) 168 | 169 | ( GotHighlightAnimationMsg highlightAnimationMsg, PulsingLetters data ) -> 170 | stay 171 | ( model |> withAnimatedBoard (onPulsingLettersAnimationFrame animatedBoard highlightAnimationMsg data) 172 | , Cmd.none 173 | ) 174 | 175 | ( GotHighlightAnimationMsg _, _ ) -> 176 | stay ( model, Cmd.none ) 177 | 178 | ( ShapeDropDelayElapsed, DroppingRandomShapes data ) -> 179 | stay ( model |> withAnimatedBoard (handleShapeDropDelayElapsed data |> DroppingRandomShapes), Cmd.none ) 180 | 181 | ( ShapeDropDelayElapsed, _ ) -> 182 | stay ( model, Cmd.none ) 183 | 184 | ( ShowSettingsRequested, _ ) -> 185 | stay ( showSettingsScreen model, Cmd.none ) 186 | 187 | ( GotSettingsScreenMsg subMsg, _ ) -> 188 | stay <| handleSettingsScreenMsg subMsg model 189 | 190 | ( StartGameRequested, _ ) -> 191 | ( model, Cmd.none, StartGame ) 192 | 193 | ( ShowHighScoresRequested, _ ) -> 194 | stay ( showHighScoresScreen model, Cmd.none ) 195 | 196 | ( GotHighScoresScreenMsg subMsg, _ ) -> 197 | stay <| handleHighScoresScreenMsg subMsg model 198 | 199 | 200 | withAnimatedBoard : AnimatedBoard -> Model -> Model 201 | withAnimatedBoard animatedBoard (Model modelData) = 202 | Model { modelData | animatedBoard = animatedBoard } 203 | 204 | 205 | showSettingsScreen : Model -> Model 206 | showSettingsScreen (Model ({ settings } as modelData)) = 207 | Model { modelData | modal = SettingsModal <| SettingsScreen.init settings } 208 | 209 | 210 | handleSettingsScreenMsg : SettingsScreen.Msg -> Model -> ( Model, Cmd Msg ) 211 | handleSettingsScreenMsg msg ((Model modelData) as model) = 212 | case modelData.modal of 213 | SettingsModal settingsScreen -> 214 | let 215 | ( settingsModel, settingsCmd, settingsUpdateResult ) = 216 | SettingsScreen.update msg settingsScreen 217 | 218 | nextModelData = 219 | case settingsUpdateResult of 220 | SettingsScreen.KeepOpen -> 221 | { modelData | modal = SettingsModal settingsModel } 222 | 223 | SettingsScreen.Close maybeNewSettings -> 224 | -- Close settings screen, possibly updating the settings 225 | { modelData | settings = maybeNewSettings |> Maybe.withDefault modelData.settings, modal = NoModal } 226 | in 227 | ( Model nextModelData, Cmd.map GotSettingsScreenMsg settingsCmd ) 228 | 229 | _ -> 230 | ( model, Cmd.none ) 231 | 232 | 233 | showHighScoresScreen : Model -> Model 234 | showHighScoresScreen (Model ({ highScores } as modelData)) = 235 | Model { modelData | modal = HighScoresModal <| HighScores.initHighScoresDialog highScores } 236 | 237 | 238 | handleHighScoresScreenMsg : HighScores.HighScoresMsg -> Model -> ( Model, Cmd Msg ) 239 | handleHighScoresScreenMsg msg ((Model modelData) as model) = 240 | case modelData.modal of 241 | HighScoresModal highScoresModel -> 242 | case HighScores.updateHighScoresDialog msg highScoresModel of 243 | HighScores.KeepOpen_ nextHighScoresModel -> 244 | ( Model { modelData | modal = HighScoresModal nextHighScoresModel }, Cmd.none ) 245 | 246 | HighScores.Close_ (Just ( newHighScores, subCmd )) -> 247 | ( Model { modelData | modal = NoModal, highScores = newHighScores } 248 | , Cmd.map GotHighScoresScreenMsg subCmd 249 | ) 250 | 251 | HighScores.Close_ Nothing -> 252 | ( Model { modelData | modal = NoModal }, Cmd.none ) 253 | 254 | _ -> 255 | ( model, Cmd.none ) 256 | 257 | 258 | {-| Gets the initial state of the `DroppingLetters` state of the screen. Gets all the letters ready to drop, along with 259 | a random colour for each (using the supplied seed). 260 | -} 261 | initDroppingLetters : Random.Seed -> DroppingLettersData 262 | initDroppingLetters randomSeed = 263 | let 264 | -- We use the seed to get the random colours, and then keep a hold of that same seed which is used later for a 265 | -- different purpose (to initialise the shape buffer for the dropping shapes, for example). 266 | randomColours = 267 | Random.step (Shape.allColours |> Array.fromList |> Random.Array.shuffle) randomSeed |> Tuple.first 268 | 269 | -- We know we'll never request an index out of bounds of the array, but to convince the compiler we fall back 270 | -- to a default (blue) which will never be used. 271 | getRandomColour index = 272 | Array.get index randomColours |> Maybe.withDefault Shape.Blue 273 | in 274 | { landed = [] 275 | , dropping = { blocks = tBlocks, colour = getRandomColour 0, gridCoord = ( 11, boardViewConfig.rowCount ) } 276 | , next = 277 | [ { blocks = eBlocks, colour = getRandomColour 1, gridCoord = ( 17, boardViewConfig.rowCount ) } 278 | , { blocks = tBlocks, colour = getRandomColour 2, gridCoord = ( 22, boardViewConfig.rowCount ) } 279 | , { blocks = rBlocks, colour = getRandomColour 3, gridCoord = ( 28, boardViewConfig.rowCount ) } 280 | , { blocks = iBlocks, colour = getRandomColour 4, gridCoord = ( 33, boardViewConfig.rowCount ) } 281 | , { blocks = sBlocks, colour = getRandomColour 5, gridCoord = ( 35, boardViewConfig.rowCount ) } 282 | ] 283 | , randomSeed = randomSeed 284 | } 285 | 286 | 287 | {-| Called when the animation for dropping letters has progressed a frame. Either drops the current letter down one, adds 288 | a new letter to be dropped, or progresses to the next stage once all letters have landed (i.e. to the `PulsingLetters` 289 | stage). 290 | -} 291 | onLetterDropAnimationFrame : DroppingLettersData -> AnimatedBoard 292 | onLetterDropAnimationFrame ({ landed, dropping, next, randomSeed } as data) = 293 | let 294 | ( gridX, gridY ) = 295 | dropping.gridCoord 296 | in 297 | if gridY == 4 then 298 | -- The currently dropping letter has reached the bottom - start the next letter 299 | let 300 | newLandedLetters = 301 | dropping :: landed 302 | in 303 | case next of 304 | nextLetter :: restLetters -> 305 | -- We have more letters to drop 306 | DroppingLetters { data | landed = newLandedLetters, dropping = nextLetter, next = restLetters } 307 | 308 | [] -> 309 | -- All letters now landed 310 | PulsingLetters 311 | { letters = newLandedLetters 312 | , animation = 313 | HighlightAnimation.startNewAnimation HighlightAnimation.initialId 314 | HighlightAnimation.ShapeLanding 315 | 1000 316 | (lettersToBoardBlocks newLandedLetters) 317 | , randomSeed = randomSeed 318 | } 319 | 320 | else 321 | -- The currently dropping letter can drop one more row 322 | DroppingLetters { data | dropping = { dropping | gridCoord = ( gridX, gridY - 1 ) } } 323 | 324 | 325 | {-| Called when the animation for pulsing letters has progressed a frame. Delegates the work to the `HighlightAnimation` 326 | module then, based on its result, either continues the current animation or progresses to the next stage (i.e. the 327 | `DroppingRandomShapes` stage). 328 | -} 329 | onPulsingLettersAnimationFrame : AnimatedBoard -> HighlightAnimation.Msg -> PulsingLettersData -> AnimatedBoard 330 | onPulsingLettersAnimationFrame animatedBoard msg data = 331 | case HighlightAnimation.update msg data.animation of 332 | HighlightAnimation.IgnoreMsg -> 333 | animatedBoard 334 | 335 | HighlightAnimation.Continue animation -> 336 | PulsingLetters { data | animation = animation } 337 | 338 | HighlightAnimation.Complete -> 339 | initDroppingRandomShapes data.randomSeed data.letters |> DroppingRandomShapes 340 | 341 | 342 | {-| Initialises the data required when entering the DroppingRandomShapes state. Generates shape buffer used to get 343 | random shapes, and gets an initial shape from it which is then initialised for dropping. 344 | -} 345 | initDroppingRandomShapes : Random.Seed -> List Letter -> DroppingRandomShapesData 346 | initDroppingRandomShapes randomSeed letters = 347 | let 348 | ( initialShape, shapeBuffer ) = 349 | Shape.createShapeBag randomSeed |> Shape.next 350 | 351 | ( startInfo, shapeStartInfoSeed ) = 352 | Random.step randomShapeStartInfoGenerator randomSeed 353 | in 354 | { letters = letters 355 | , droppingShapes = [ initDroppingShape startInfo initialShape ] 356 | , shapeBuffer = shapeBuffer 357 | , randomSeed = shapeStartInfoSeed 358 | } 359 | 360 | 361 | 362 | -- DROPPING SHAPES 363 | 364 | 365 | {-| Initialises the supplied `Shape` ready to be a `DroppingShape`, using the supplied `xCoord` and `turns`. 366 | -} 367 | initDroppingShape : { xCoord : Int, turns : Int } -> Shape -> DroppingShape 368 | initDroppingShape { xCoord, turns } shape = 369 | { shape = rotateXTimes turns shape, gridCoord = ( xCoord, boardViewConfig.rowCount ) } 370 | 371 | 372 | {-| Handles the case when the dropping shapes should be dropped one row. Moves all shapes down one row, possibly removing 373 | some if they've now dropped off the bottom of the board, and also potentially building a command to generate a new 374 | random shape. 375 | -} 376 | handleShapeDropDelayElapsed : DroppingRandomShapesData -> DroppingRandomShapesData 377 | handleShapeDropDelayElapsed ({ droppingShapes, randomSeed } as data) = 378 | let 379 | -- Decides what to do with this dropping shape - either lowers it by one row (returning it in a `Just`) or 380 | -- returns `Nothing`, indicating this shape should be removed. 381 | processDroppingShape : DroppingShape -> Maybe DroppingShape 382 | processDroppingShape droppingShape = 383 | let 384 | ( x, y ) = 385 | droppingShape.gridCoord 386 | in 387 | if y < (-1 * (Shape.data droppingShape.shape).gridSize) then 388 | -- The shape is now definitely below the grid, so remove it 389 | Nothing 390 | 391 | else 392 | Just { shape = droppingShape.shape, gridCoord = ( x, y - 1 ) } 393 | 394 | newData = 395 | { data | droppingShapes = List.map processDroppingShape droppingShapes |> List.filterMap identity } 396 | in 397 | -- Whenever a shape is on row 9 add a new shape at the top 398 | if droppingShapes |> List.map .gridCoord |> List.map Tuple.second |> List.any ((==) 9) then 399 | withNewRandomDroppingShape newData 400 | 401 | else 402 | newData 403 | 404 | 405 | {-| Gets a new copy of the supplied `DroppingRandomShapesData`, with a new random dropping shape (and an updated shape 406 | buffer and random seed for next time they're used). 407 | -} 408 | withNewRandomDroppingShape : DroppingRandomShapesData -> DroppingRandomShapesData 409 | withNewRandomDroppingShape ({ randomSeed, shapeBuffer, droppingShapes } as data) = 410 | let 411 | ( startInfo, nextRandomSeed ) = 412 | Random.step randomShapeStartInfoGenerator randomSeed 413 | 414 | ( nextShape, nextShapeBuffer ) = 415 | Shape.next shapeBuffer |> Tuple.mapFirst (initDroppingShape startInfo) 416 | in 417 | { data | droppingShapes = nextShape :: droppingShapes, shapeBuffer = nextShapeBuffer, randomSeed = nextRandomSeed } 418 | 419 | 420 | {-| Generates a random position (along the x-axis) and rotation for a new shape about to be dropped down the screen. 421 | -} 422 | randomShapeStartInfoGenerator : Random.Generator { xCoord : Int, turns : Int } 423 | randomShapeStartInfoGenerator = 424 | Random.map2 (\xCoord turns -> { xCoord = xCoord, turns = turns }) 425 | (Random.int 5 45) 426 | (Random.int 0 3) 427 | 428 | 429 | {-| Rotates the given shape the given number of turns. 430 | -} 431 | rotateXTimes : Int -> Shape -> Shape 432 | rotateXTimes turns shape = 433 | List.range 1 turns |> List.foldl (\_ shape_ -> Shape.rotate Shape.Clockwise shape_) shape 434 | 435 | 436 | 437 | -- VIEW: COMMON 438 | 439 | 440 | view : Model -> Element Msg 441 | view (Model { animatedBoard, settings, modal }) = 442 | let 443 | ( letters_, maybeAnimation, droppingShapes_ ) = 444 | case animatedBoard of 445 | Initialising -> 446 | ( [], Nothing, [] ) 447 | 448 | DroppingLetters { landed, dropping } -> 449 | ( dropping :: landed, Nothing, [] ) 450 | 451 | PulsingLetters { animation } -> 452 | ( [], Just animation, [] ) 453 | 454 | DroppingRandomShapes { letters, droppingShapes } -> 455 | ( letters, Nothing, droppingShapes ) 456 | 457 | letterBlocks = 458 | lettersToBoardBlocks letters_ |> BoardView.withOpacity 1 459 | 460 | droppingShapeBlocks = 461 | droppingShapes_ 462 | |> List.concatMap droppingShapeToBoardBlocks 463 | |> BoardView.withOpacity 0.5 464 | 465 | modalAttr = 466 | case modal of 467 | SettingsModal settingsScreenModel -> 468 | [ SettingsScreen.view settingsScreenModel 469 | |> Element.map GotSettingsScreenMsg 470 | |> Element.inFront 471 | ] 472 | 473 | HighScoresModal highScoresModel -> 474 | [ HighScores.highScoresView highScoresModel 475 | |> Element.map GotHighScoresScreenMsg 476 | |> Element.inFront 477 | ] 478 | 479 | NoModal -> 480 | [] 481 | in 482 | Element.column 483 | ([ Element.spacingXY 0 25, Element.height Element.fill, Element.width Element.fill ] ++ modalAttr) 484 | [ Element.el [ Element.centerX ] <| BoardView.view boardViewConfig False (droppingShapeBlocks ++ letterBlocks) [] maybeAnimation 485 | , Element.row [ Element.centerX, Element.spacingXY 20 0 ] 486 | [ button modal "Start Game" StartGameRequested 487 | , button modal "Settings" ShowSettingsRequested 488 | , button modal "High Scores" ShowHighScoresRequested 489 | ] 490 | ] 491 | 492 | 493 | button : ModalDialog -> String -> msg -> Element msg 494 | button modal caption onPress = 495 | let 496 | buttonState = 497 | case modal of 498 | NoModal -> 499 | Button.Enabled onPress 500 | 501 | _ -> 502 | Button.Inaccessible 503 | in 504 | Button.button { style = Button.MainScreen, caption = caption, state = buttonState } 505 | 506 | 507 | 508 | -- VIEW: BOARD 509 | 510 | 511 | {-| The configuration required to render the board in the welcome screen. 512 | -} 513 | boardViewConfig : BoardView.Config 514 | boardViewConfig = 515 | { cellSize = 15 516 | , rowCount = 15 517 | , colCount = 50 518 | , borderStyle = BoardView.Fade UIHelpers.mainBackgroundColour 519 | , showGridLines = True 520 | } 521 | 522 | 523 | {-| Converts the list of letters to the list of blocks to use to render them on the board. 524 | -} 525 | lettersToBoardBlocks : List Letter -> List ( Coord, Shape.BlockColour ) 526 | lettersToBoardBlocks letters = 527 | letters 528 | |> List.concatMap 529 | (\{ blocks, colour, gridCoord } -> 530 | blocks 531 | |> DroppingShape.calcBoardCoords gridCoord 532 | |> BoardView.withColour colour 533 | ) 534 | 535 | 536 | {-| Converts supplied `DroppingShape` to the list of blocks to use to render it on the board. 537 | -} 538 | droppingShapeToBoardBlocks : DroppingShape -> List ( Coord, Shape.BlockColour ) 539 | droppingShapeToBoardBlocks droppingShape = 540 | let 541 | { colour } = 542 | Shape.data droppingShape.shape 543 | in 544 | DroppingShape.calcShapeBlocksBoardCoords droppingShape |> BoardView.withColour colour 545 | 546 | 547 | 548 | -- MODEL INFO 549 | 550 | 551 | getSettings : Model -> Settings 552 | getSettings (Model { settings }) = 553 | settings 554 | 555 | 556 | getHighScores : Model -> HighScores 557 | getHighScores (Model { highScores }) = 558 | highScores 559 | 560 | 561 | 562 | -- SUBSCRIPTIONS 563 | 564 | 565 | subscriptions : Model -> Sub Msg 566 | subscriptions (Model { animatedBoard, modal }) = 567 | let 568 | modalSubscription = 569 | case modal of 570 | NoModal -> 571 | Sub.none 572 | 573 | SettingsModal settingsModel -> 574 | settingsModel |> SettingsScreen.subscriptions |> Sub.map GotSettingsScreenMsg 575 | 576 | HighScoresModal highScoresModel -> 577 | highScoresModel |> HighScores.highScoresDialogSubscriptions |> Sub.map GotHighScoresScreenMsg 578 | in 579 | Sub.batch [ animationSubscriptions animatedBoard, modalSubscription ] 580 | 581 | 582 | animationSubscriptions : AnimatedBoard -> Sub Msg 583 | animationSubscriptions animatedBoard = 584 | case animatedBoard of 585 | Initialising -> 586 | Sub.none 587 | 588 | DroppingLetters _ -> 589 | Time.every 50 <| always LetterDropAnimationFrame 590 | 591 | PulsingLetters { animation } -> 592 | HighlightAnimation.subscriptions animation |> Sub.map GotHighlightAnimationMsg 593 | 594 | DroppingRandomShapes _ -> 595 | Time.every (toFloat 250) <| always ShapeDropDelayElapsed 596 | 597 | 598 | 599 | -- LETTERS 600 | 601 | 602 | tBlocks : List Coord 603 | tBlocks = 604 | [ ( 0, 6 ), ( 1, 6 ), ( 2, 6 ), ( 3, 6 ), ( 4, 6 ), ( 2, 5 ), ( 2, 4 ), ( 2, 3 ), ( 2, 2 ), ( 2, 1 ), ( 2, 0 ) ] 605 | 606 | 607 | eBlocks : List Coord 608 | eBlocks = 609 | [ ( 0, 0 ), ( 0, 1 ), ( 0, 2 ), ( 0, 3 ), ( 0, 4 ), ( 0, 5 ), ( 0, 6 ), ( 1, 6 ), ( 2, 6 ), ( 3, 6 ), ( 1, 3 ), ( 2, 3 ), ( 1, 0 ), ( 2, 0 ), ( 3, 0 ) ] 610 | 611 | 612 | rBlocks : List Coord 613 | rBlocks = 614 | [ ( 0, 0 ), ( 0, 1 ), ( 0, 2 ), ( 0, 3 ), ( 0, 4 ), ( 0, 5 ), ( 0, 6 ), ( 1, 6 ), ( 2, 6 ), ( 3, 5 ), ( 3, 4 ), ( 2, 3 ), ( 1, 3 ), ( 1, 2 ), ( 2, 1 ), ( 3, 0 ) ] 615 | 616 | 617 | iBlocks : List Coord 618 | iBlocks = 619 | [ ( 0, 0 ), ( 0, 1 ), ( 0, 2 ), ( 0, 3 ), ( 0, 4 ), ( 0, 5 ), ( 0, 6 ) ] 620 | 621 | 622 | sBlocks : List Coord 623 | sBlocks = 624 | [ ( 0, 1 ), ( 1, 0 ), ( 2, 0 ), ( 3, 1 ), ( 3, 2 ), ( 2, 3 ), ( 1, 3 ), ( 0, 4 ), ( 0, 5 ), ( 1, 6 ), ( 2, 6 ), ( 3, 5 ) ] 625 | --------------------------------------------------------------------------------