├── .github └── workflows │ ├── deploy.yml │ └── test.yml ├── .gitignore ├── README.md ├── elm.json ├── flake.lock ├── flake.nix ├── index.html ├── public ├── billiard-table.obj.txt ├── font │ ├── Teko-Medium.woff │ ├── Teko-Medium.woff2 │ └── teko-license.txt └── img │ ├── balls │ ├── 1.png │ ├── 10.png │ ├── 11.png │ ├── 12.png │ ├── 13.png │ ├── 14.png │ ├── 15.png │ ├── 2.png │ ├── 3.png │ ├── 4.png │ ├── 5.png │ ├── 6.png │ ├── 7.png │ ├── 8.png │ ├── 9.png │ └── roughness.jpg │ └── table │ ├── color.png │ ├── metallic.png │ └── roughness.png ├── review ├── elm.json └── src │ └── ReviewConfig.elm ├── scripts ├── font │ ├── Rubik-Regular.ttf │ └── SIL Open Font License.txt └── textures.sh ├── src ├── Ball.elm ├── Bodies.elm ├── Camera.elm ├── Cue.elm ├── EightBall.elm ├── Game.elm ├── Main.elm └── Table.elm └── tests └── EightBallTests.elm /.github/workflows/deploy.yml: -------------------------------------------------------------------------------- 1 | name: Deploy to itch.io 2 | 3 | on: 4 | push: 5 | branches: [main] 6 | 7 | jobs: 8 | deploy: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v4 12 | 13 | - uses: actions/setup-node@v4 14 | with: 15 | node-version: "20.x" 16 | 17 | - uses: actions/cache@v3 18 | with: 19 | path: | 20 | ~/.npm 21 | ~/.elm 22 | elm-stuff 23 | key: ${{ runner.os }}-cache 24 | 25 | - run: npm install -g elm@0.19.1-6 elm-test@0.19.1-revision12 elm-review@2.10.3 elm-format@0.8.7 uglify-js@3.4.7 26 | 27 | - run: elm-format --validate src/*.elm 28 | 29 | - run: elm-test 30 | 31 | - run: | 32 | mkdir -p dest 33 | elm make src/Main.elm --output dest/elm-temp.js 34 | uglifyjs dest/elm-temp.js --compress 'pure_funcs="F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9",pure_getters,keep_fargs=false,unsafe_comps,unsafe' | uglifyjs --mangle --output=dest/elm.js 35 | rm dest/elm-temp.js 36 | cp index.html dest 37 | cp -R public dest/public 38 | 39 | - uses: josephbmanley/butler-publish-itchio-action@master 40 | env: 41 | BUTLER_CREDENTIALS: ${{ secrets.BUTLER_CREDENTIALS }} 42 | CHANNEL: html 43 | ITCH_GAME: pool 44 | ITCH_USER: unsoundscapes 45 | PACKAGE: dest 46 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Test 2 | 3 | on: 4 | pull_request: 5 | branches: [main] 6 | 7 | jobs: 8 | test: 9 | runs-on: ubuntu-latest 10 | steps: 11 | - uses: actions/checkout@v4 12 | 13 | - uses: actions/setup-node@v4 14 | with: 15 | node-version: "20.x" 16 | 17 | - uses: actions/cache@v3 18 | with: 19 | path: | 20 | ~/.npm 21 | ~/.elm 22 | elm-stuff 23 | key: ${{ runner.os }}-cache 24 | 25 | - run: npm install -g elm@0.19.1-6 elm-test@0.19.1-revision12 elm-review@2.10.3 elm-format@0.8.7 26 | 27 | - run: elm-format --validate src/*.elm 28 | 29 | - run: elm-review 30 | 31 | - run: elm-test 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | # elm-package generated files 3 | elm-stuff 4 | # elm-repl generated files 5 | repl-temp-* 6 | # build destination 7 | dest 8 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # elm-pool 2 | 3 | Physically simulated pool game. Work in progress. 4 | 5 | ## User Interface 6 | 7 | - Common controls 8 | 9 | 1. Click and drag anywhere to rotate the camera around the focal point ✅ 10 | 2. Zoom into the focal point with the mousewheel ✅ 11 | 12 | - Placing the cue ball in hand 13 | 14 | 1. The focal point is at the center of the table ✅ 15 | 2. Hover over the table to choose where to place the cue ball ✅ 16 | 3. The cue ball is rendered in gray when it overlaps with other objects ✅ 17 | 4. Click to place the cue ball if it is not overlapping with other objects ✅ 18 | 19 | - Aiming and shooting 20 | 21 | 1. The focal point is at the cue ball ✅ 22 | 2. The camera angle defines the azimuth of the cue ✅ 23 | 3. Click and hold on the cue ball to set the hit point, move cursor while pressed to set the cue elevation ✅ 24 | 4. The cue is rendered in gray if it overlaps with other objects ✅ 25 | 5. Press and hold the "Space" button to set the force ✅ 26 | 6. Release the "Space" button to shoot ✅ 27 | 28 | - Simulating 29 | 30 | 1. The focal point is where it was before ✅ 31 | 2. The camera is zoomed out to show the table (unless interrupted with the mousewheel) ✅ 32 | 33 | ## Game Rules 34 | 35 | The game format is two (2) player 8-Ball. It is a simplified version of [WPA 8-Ball rules](https://wpapool.com/rules-of-play/#eight-ball). The goal is to successfully pocket all seven (7) of one group (solids or stripes) without pocketing the cue ball, then pocket the 8-ball. 36 | 37 | - Getting started 38 | 39 | 1. Rack the balls ✅ 40 | 2. Place the cue ball behind the head string ✅ 41 | 42 | - Target group 43 | 44 | 1. View the current target group ✅ 45 | 2. The table is considered "open" until someone has pocketed a solid or stripe without scratching ✅ 46 | 3. When the table is open, pocketing balls in only one of the solids or stripes group without scratching sets the target for that player ✅ 47 | 48 | - During play 49 | 50 | 1. View the current player ✅ 51 | 2. Add shot with shot events ✅ 52 | 3. Place ball in hand ✅ 53 | 4. Check if shot is legal, that is, if the player has hit their target ball with the cue before any other, and some ball has hit a rail or went into a pocket ✅ 54 | 5. On scratch, require the next player to place the cue ball anywhere on the table (ball-in-hand) ✅ 55 | 6. If a player does not pocket one of their balls or scratches, the current player switches ✅ 56 | 7. Ensure balls are pocketed only once or send an error 57 | 8. Support spotting 8 ball when it falls off the table during break ✅ 58 | 59 | - Winning the game 60 | 61 | 1. If a player has pocketed all of their target balls and makes the 8-ball without scratching, they win ✅ 62 | 2. When a player has pocketed all of their target balls and makes the 8-ball but scratches, they lose ✅ 63 | 3. If a player pockets the 8-ball before all of their target balls, they lose ✅ 64 | 65 | ## Developing with nix flakes 66 | 67 | We are using the nix package manager, that can be installed following [these instructions](https://nixos.org/download.html). To activate the flakes feature, include `experimental-features = nix-command flakes` in `~/.config/nix/nix.conf` (create this file if it doesn't exist). 68 | 69 | Then, run `nix develop` from the project root. This will give you development environment with `elm`, so you can run: 70 | 71 | ```bash 72 | elm reactor 73 | ``` 74 | 75 | Open http://localhost:8000/src/Main.elm. 76 | -------------------------------------------------------------------------------- /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/http": "2.0.0", 14 | "elm/json": "1.1.3", 15 | "elm/time": "1.0.0", 16 | "elm-explorations/webgl": "1.1.3", 17 | "ianmackenzie/elm-3d-camera": "3.1.0", 18 | "ianmackenzie/elm-3d-scene": "1.0.2", 19 | "ianmackenzie/elm-geometry": "3.11.0", 20 | "ianmackenzie/elm-units": "2.10.0", 21 | "mdgriffith/elm-animator": "1.1.1", 22 | "w0rm/elm-obj-file": "1.2.1", 23 | "w0rm/elm-physics": "5.1.3" 24 | }, 25 | "indirect": { 26 | "elm/bytes": "1.0.8", 27 | "elm/file": "1.0.5", 28 | "elm/random": "1.0.0", 29 | "elm/url": "1.0.0", 30 | "elm/virtual-dom": "1.0.3", 31 | "elm-explorations/linear-algebra": "1.0.3", 32 | "ianmackenzie/elm-1d-parameter": "1.0.1", 33 | "ianmackenzie/elm-float-extra": "1.1.0", 34 | "ianmackenzie/elm-geometry-linear-algebra-interop": "2.0.2", 35 | "ianmackenzie/elm-interval": "3.1.0", 36 | "ianmackenzie/elm-triangular-mesh": "1.1.0", 37 | "ianmackenzie/elm-units-interval": "3.2.0" 38 | } 39 | }, 40 | "test-dependencies": { 41 | "direct": { 42 | "elm-explorations/test": "2.1.2" 43 | }, 44 | "indirect": {} 45 | } 46 | } 47 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1694529238, 9 | "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1699707865, 24 | "narHash": "sha256-Z8hCtc5JXSl11WAySJahygsYyUysRfuIBw0xmDzdYlM=", 25 | "owner": "nixos", 26 | "repo": "nixpkgs", 27 | "rev": "04ba0883815d54efa12dba5b9fea7834b9962cf3", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "nixos", 32 | "repo": "nixpkgs", 33 | "type": "github" 34 | } 35 | }, 36 | "root": { 37 | "inputs": { 38 | "flake-utils": "flake-utils", 39 | "nixpkgs": "nixpkgs" 40 | } 41 | }, 42 | "systems": { 43 | "locked": { 44 | "lastModified": 1681028828, 45 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 46 | "owner": "nix-systems", 47 | "repo": "default", 48 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 49 | "type": "github" 50 | }, 51 | "original": { 52 | "owner": "nix-systems", 53 | "repo": "default", 54 | "type": "github" 55 | } 56 | } 57 | }, 58 | "root": "root", 59 | "version": 7 60 | } 61 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs"; 4 | flake-utils.url = "github:numtide/flake-utils"; 5 | }; 6 | 7 | outputs = { self, nixpkgs, flake-utils }: 8 | flake-utils.lib.eachDefaultSystem (system: 9 | let pkgs = nixpkgs.legacyPackages.${system}; 10 | in 11 | { 12 | devShells.default = with pkgs; with elmPackages; mkShell { 13 | buildInputs = [ 14 | elm 15 | elm-format 16 | elm-test 17 | elm-review 18 | elm-json 19 | nodePackages.uglify-js 20 | butler 21 | ghostscript # for generating ball textures 22 | pngquant # for minimizing ball textures 23 | ]; 24 | }; 25 | }); 26 | } 27 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Pool 5 | 12 | 13 | 14 | 15 |
16 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /public/font/Teko-Medium.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/font/Teko-Medium.woff -------------------------------------------------------------------------------- /public/font/Teko-Medium.woff2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/font/Teko-Medium.woff2 -------------------------------------------------------------------------------- /public/font/teko-license.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Indian Type Foundry (info@indiantypefoundry.com). 2 | 3 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 4 | This license is copied below, and is also available with a FAQ at: 5 | http://scripts.sil.org/OFL 6 | 7 | 8 | ----------------------------------------------------------- 9 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 10 | ----------------------------------------------------------- 11 | 12 | PREAMBLE 13 | The goals of the Open Font License (OFL) are to stimulate worldwide 14 | development of collaborative font projects, to support the font creation 15 | efforts of academic and linguistic communities, and to provide a free and 16 | open framework in which fonts may be shared and improved in partnership 17 | with others. 18 | 19 | The OFL allows the licensed fonts to be used, studied, modified and 20 | redistributed freely as long as they are not sold by themselves. The 21 | fonts, including any derivative works, can be bundled, embedded, 22 | redistributed and/or sold with any software provided that any reserved 23 | names are not used by derivative works. The fonts and derivatives, 24 | however, cannot be released under any other type of license. The 25 | requirement for fonts to remain under this license does not apply 26 | to any document created using the fonts or their derivatives. 27 | 28 | DEFINITIONS 29 | "Font Software" refers to the set of files released by the Copyright 30 | Holder(s) under this license and clearly marked as such. This may 31 | include source files, build scripts and documentation. 32 | 33 | "Reserved Font Name" refers to any names specified as such after the 34 | copyright statement(s). 35 | 36 | "Original Version" refers to the collection of Font Software components as 37 | distributed by the Copyright Holder(s). 38 | 39 | "Modified Version" refers to any derivative made by adding to, deleting, 40 | or substituting -- in part or in whole -- any of the components of the 41 | Original Version, by changing formats or by porting the Font Software to a 42 | new environment. 43 | 44 | "Author" refers to any designer, engineer, programmer, technical 45 | writer or other person who contributed to the Font Software. 46 | 47 | PERMISSION & CONDITIONS 48 | Permission is hereby granted, free of charge, to any person obtaining 49 | a copy of the Font Software, to use, study, copy, merge, embed, modify, 50 | redistribute, and sell modified and unmodified copies of the Font 51 | Software, subject to the following conditions: 52 | 53 | 1) Neither the Font Software nor any of its individual components, 54 | in Original or Modified Versions, may be sold by itself. 55 | 56 | 2) Original or Modified Versions of the Font Software may be bundled, 57 | redistributed and/or sold with any software, provided that each copy 58 | contains the above copyright notice and this license. These can be 59 | included either as stand-alone text files, human-readable headers or 60 | in the appropriate machine-readable metadata fields within text or 61 | binary files as long as those fields can be easily viewed by the user. 62 | 63 | 3) No Modified Version of the Font Software may use the Reserved Font 64 | Name(s) unless explicit written permission is granted by the corresponding 65 | Copyright Holder. This restriction only applies to the primary font name as 66 | presented to the users. 67 | 68 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font 69 | Software shall not be used to promote, endorse or advertise any 70 | Modified Version, except to acknowledge the contribution(s) of the 71 | Copyright Holder(s) and the Author(s) or with their explicit written 72 | permission. 73 | 74 | 5) The Font Software, modified or unmodified, in part or in whole, 75 | must be distributed entirely under this license, and must not be 76 | distributed under any other license. The requirement for fonts to 77 | remain under this license does not apply to any document created 78 | using the Font Software. 79 | 80 | TERMINATION 81 | This license becomes null and void if any of the above conditions are 82 | not met. 83 | 84 | DISCLAIMER 85 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 86 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF 87 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT 88 | OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE 89 | COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 90 | INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 91 | DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 92 | FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM 93 | OTHER DEALINGS IN THE FONT SOFTWARE. 94 | -------------------------------------------------------------------------------- /public/img/balls/1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/1.png -------------------------------------------------------------------------------- /public/img/balls/10.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/10.png -------------------------------------------------------------------------------- /public/img/balls/11.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/11.png -------------------------------------------------------------------------------- /public/img/balls/12.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/12.png -------------------------------------------------------------------------------- /public/img/balls/13.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/13.png -------------------------------------------------------------------------------- /public/img/balls/14.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/14.png -------------------------------------------------------------------------------- /public/img/balls/15.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/15.png -------------------------------------------------------------------------------- /public/img/balls/2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/2.png -------------------------------------------------------------------------------- /public/img/balls/3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/3.png -------------------------------------------------------------------------------- /public/img/balls/4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/4.png -------------------------------------------------------------------------------- /public/img/balls/5.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/5.png -------------------------------------------------------------------------------- /public/img/balls/6.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/6.png -------------------------------------------------------------------------------- /public/img/balls/7.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/7.png -------------------------------------------------------------------------------- /public/img/balls/8.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/8.png -------------------------------------------------------------------------------- /public/img/balls/9.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/9.png -------------------------------------------------------------------------------- /public/img/balls/roughness.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/balls/roughness.jpg -------------------------------------------------------------------------------- /public/img/table/color.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/table/color.png -------------------------------------------------------------------------------- /public/img/table/metallic.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/table/metallic.png -------------------------------------------------------------------------------- /public/img/table/roughness.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/public/img/table/roughness.png -------------------------------------------------------------------------------- /review/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "elm/core": "1.0.5", 10 | "elm/json": "1.1.3", 11 | "elm/project-metadata-utils": "1.0.2", 12 | "jfmengels/elm-review": "2.13.1", 13 | "jfmengels/elm-review-simplify": "2.1.3", 14 | "jfmengels/elm-review-unused": "1.2.0", 15 | "stil4m/elm-syntax": "7.3.2" 16 | }, 17 | "indirect": { 18 | "elm/bytes": "1.0.8", 19 | "elm/html": "1.0.0", 20 | "elm/parser": "1.1.0", 21 | "elm/random": "1.0.0", 22 | "elm/time": "1.0.0", 23 | "elm/virtual-dom": "1.0.3", 24 | "elm-explorations/test": "2.1.2", 25 | "miniBill/elm-unicode": "1.0.3", 26 | "pzp1997/assoc-list": "1.0.0", 27 | "rtfeldman/elm-hex": "1.0.0", 28 | "stil4m/structured-writer": "1.0.3" 29 | } 30 | }, 31 | "test-dependencies": { 32 | "direct": {}, 33 | "indirect": {} 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /review/src/ReviewConfig.elm: -------------------------------------------------------------------------------- 1 | module ReviewConfig exposing (config) 2 | 3 | {-| Do not rename the ReviewConfig module or the config function, because 4 | `elm-review` will look for these. 5 | 6 | To add packages that contain rules, add them to this review project using 7 | 8 | `elm install author/packagename` 9 | 10 | when inside the directory containing this file. 11 | 12 | Note: there are suppressed 13 | 14 | -} 15 | 16 | import NoUnused.CustomTypeConstructorArgs 17 | import NoUnused.CustomTypeConstructors 18 | import NoUnused.Dependencies 19 | import NoUnused.Exports 20 | import NoUnused.Modules 21 | import NoUnused.Parameters 22 | import NoUnused.Patterns 23 | import NoUnused.Variables 24 | import Review.Rule exposing (Rule) 25 | import Simplify 26 | 27 | 28 | config : List Rule 29 | config = 30 | [ NoUnused.CustomTypeConstructors.rule 31 | [ { moduleName = "Point2d" 32 | , typeName = "Point2d" 33 | , index = 1 -- Position of the phantom variable in the type's arguments 34 | } 35 | ] 36 | , NoUnused.CustomTypeConstructorArgs.rule 37 | , NoUnused.Exports.rule 38 | , NoUnused.Modules.rule 39 | , NoUnused.Parameters.rule 40 | , NoUnused.Patterns.rule 41 | , NoUnused.Variables.rule 42 | , Simplify.rule Simplify.defaults 43 | ] 44 | -------------------------------------------------------------------------------- /scripts/font/Rubik-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/w0rm/elm-pool/770e7c35c328e290153286b343c1eaae42fc7311/scripts/font/Rubik-Regular.ttf -------------------------------------------------------------------------------- /scripts/font/SIL Open Font License.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 by Hubert & Fischer. All rights reserved. 2 | 3 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 4 | This license is copied below, and is also available with a FAQ at: 5 | http://scripts.sil.org/OFL 6 | 7 | 8 | This Font Software is licensed under the SIL Open Font License, Version 1.1. 9 | This license is copied below, and is also available with a FAQ at: http://scripts.sil.org/OFL 10 | 11 | ----------------------------------------------------------- 12 | SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007 13 | ----------------------------------------------------------- 14 | 15 | PREAMBLE 16 | The goals of the Open Font License (OFL) are to stimulate worldwide development of collaborative font projects, to support the font creation efforts of academic and linguistic communities, and to provide a free and open framework in which fonts may be shared and improved in partnership with others. 17 | 18 | The OFL allows the licensed fonts to be used, studied, modified and redistributed freely as long as they are not sold by themselves. The fonts, including any derivative works, can be bundled, embedded, redistributed and/or sold with any software provided that any reserved names are not used by derivative works. The fonts and derivatives, however, cannot be released under any other type of license. The requirement for fonts to remain under this license does not apply to any document created using the fonts or their derivatives. 19 | 20 | DEFINITIONS 21 | "Font Software" refers to the set of files released by the Copyright Holder(s) under this license and clearly marked as such. This may include source files, build scripts and documentation. 22 | 23 | "Reserved Font Name" refers to any names specified as such after the copyright statement(s). 24 | 25 | "Original Version" refers to the collection of Font Software components as distributed by the Copyright Holder(s). 26 | 27 | "Modified Version" refers to any derivative made by adding to, deleting, or substituting -- in part or in whole -- any of the components of the Original Version, by changing formats or by porting the Font Software to a new environment. 28 | 29 | "Author" refers to any designer, engineer, programmer, technical writer or other person who contributed to the Font Software. 30 | 31 | PERMISSION & CONDITIONS 32 | Permission is hereby granted, free of charge, to any person obtaining a copy of the Font Software, to use, study, copy, merge, embed, modify, redistribute, and sell modified and unmodified copies of the Font Software, subject to the following conditions: 33 | 34 | 1) Neither the Font Software nor any of its individual components, in Original or Modified Versions, may be sold by itself. 35 | 36 | 2) Original or Modified Versions of the Font Software may be bundled, redistributed and/or sold with any software, provided that each copy contains the above copyright notice and this license. These can be included either as stand-alone text files, human-readable headers or in the appropriate machine-readable metadata fields within text or binary files as long as those fields can be easily viewed by the user. 37 | 38 | 3) No Modified Version of the Font Software may use the Reserved Font Name(s) unless explicit written permission is granted by the corresponding Copyright Holder. This restriction only applies to the primary font name as presented to the users. 39 | 40 | 4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font Software shall not be used to promote, endorse or advertise any Modified Version, except to acknowledge the contribution(s) of the Copyright Holder(s) and the Author(s) or with their explicit written permission. 41 | 42 | 5) The Font Software, modified or unmodified, in part or in whole, must be distributed entirely under this license, and must not be distributed under any other license. The requirement for fonts to remain under this license does not apply to any document created using the Font Software. 43 | 44 | TERMINATION 45 | This license becomes null and void if any of the above conditions are not met. 46 | 47 | DISCLAIMER 48 | THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE. -------------------------------------------------------------------------------- /scripts/textures.sh: -------------------------------------------------------------------------------- 1 | 2 | SCRIPTPATH="$( cd "$(dirname "$0")" >/dev/null 2>&1 ; pwd -P )" 3 | 4 | function texture { 5 | background=$1 6 | stripe=$2 7 | number=$3 8 | 9 | PS_CODE=$(cat <> setpagedevice 12 | 13 | % background 14 | 0 0 moveto 1024 0 rlineto 0 512 rlineto -1024 0 rlineto 0 -512 rlineto closepath 15 | ${background} setrgbcolor fill 16 | 17 | % stripe 18 | 0 150 moveto 1024 0 rlineto 0 212 rlineto -1024 0 rlineto 0 -212 rlineto closepath 19 | ${stripe} setrgbcolor fill 20 | 21 | % circles 22 | 256 256 80 0 360 arc 23 | 768 256 80 0 360 arc closepath 24 | 1 1 1 setrgbcolor fill 25 | 26 | % text 27 | /Rubik-Regular.ttf findfont 130 scalefont setfont 28 | 0 0 0 setrgbcolor 29 | 256 210 moveto 30 | (${number}) stringwidth pop 2 div neg 0 rmoveto 31 | (${number}) show 32 | 768 210 moveto 33 | (${number}) stringwidth pop 2 div neg 0 rmoveto 34 | (${number}) show 35 | 36 | showpage 37 | EOF 38 | ) 39 | 40 | echo "$PS_CODE" \ 41 | | sed "s/$${background}/$background/g;s/$${stripe}/$stripe/g;s/$${number}/$number/g;" \ 42 | | gs -I$SCRIPTPATH/font -dSAFER -dQUIET -dBATCH -dNOPAUSE -sDEVICE=png16m -dGraphicsAlphaBits=4 -dTextAlphaBits=4 -sOutputFile=- -\ 43 | | pngquant --force --strip --speed=1 8 --output $SCRIPTPATH/../public/img/balls/$number.png - 44 | } 45 | 46 | texture "1 0.843 0" "1 0.843 0" 1 # yellow 47 | texture "0 0 1" "0 0 1" 2 # blue 48 | texture "1 0 0" "1 0 0" 3 # red 49 | texture "0.294 0 0.509" "0.294 0 0.509" 4 # violet 50 | texture "1 0.270 0" "1 0.270 0" 5 # orange 51 | texture "0.133 0.545 0.133" "0.133 0.545 0.133" 6 # green 52 | texture "0.5 0 0" "0.5 0 0" 7 # maroon 53 | texture "0 0 0" "0 0 0" 8 # black 54 | texture "1 1 1" "1 0.843 0" 9 # yellow-striped 55 | texture "1 1 1" "0 0 1" 10 # blue-striped 56 | texture "1 1 1" "1 0 0" 11 # red-striped 57 | texture "1 1 1" "0.294 0 0.509" 12 # violet-striped 58 | texture "1 1 1" "1 0.270 0" 13 # orange-striped 59 | texture "1 1 1" "0.133 0.545 0.133" 14 # green-striped 60 | texture "1 1 1" "0.5 0 0" 15 # maroon-striped 61 | -------------------------------------------------------------------------------- /src/Ball.elm: -------------------------------------------------------------------------------- 1 | module Ball exposing (body, entity, rack, radius, spot) 2 | 3 | import Angle 4 | import Axis2d exposing (Axis2d) 5 | import Axis3d 6 | import Bodies exposing (Id(..)) 7 | import Circle2d exposing (Circle2d) 8 | import Color exposing (Color) 9 | import Direction2d 10 | import Direction3d 11 | import EightBall exposing (Ball) 12 | import Length exposing (Length, Meters) 13 | import Mass exposing (Mass) 14 | import Physics.Body as Body exposing (Body) 15 | import Physics.Coordinates exposing (BodyCoordinates, WorldCoordinates) 16 | import Physics.Material as Material exposing (Material) 17 | import Physics.World as World exposing (World) 18 | import Point2d exposing (Point2d) 19 | import Point3d 20 | import Quantity 21 | import Scene3d exposing (Entity) 22 | import Scene3d.Material as Material 23 | import SketchPlane3d 24 | import Sphere3d 25 | import Vector2d 26 | import Vector3d 27 | 28 | 29 | radius : Length 30 | radius = 31 | Length.millimeters (57.15 / 2) 32 | 33 | 34 | weight : Mass 35 | weight = 36 | Mass.grams 170 37 | 38 | 39 | {-| The perfect sphere keeps rolling on the perfect plane, 40 | we need to damp the angular velocity to make it stop. 41 | -} 42 | damping : { linear : Float, angular : Float } 43 | damping = 44 | { linear = 0.4, angular = 0.4 } 45 | 46 | 47 | material : Material 48 | material = 49 | Material.custom 50 | { friction = 0.06 51 | , bounciness = 0.6 52 | } 53 | 54 | 55 | body : id -> Body id 56 | body id = 57 | Body.sphere (Sphere3d.atOrigin radius) id 58 | |> Body.withMaterial material 59 | |> Body.withDamping damping 60 | |> Body.withBehavior (Body.dynamic weight) 61 | -- rotate to see the numbers on the balls 62 | |> Body.rotateAround Axis3d.x (Angle.degrees 90) 63 | 64 | 65 | entity : Material.Texture Color -> Material.Texture Float -> Entity BodyCoordinates 66 | entity baseColor roughnessTexture = 67 | Scene3d.sphereWithShadow 68 | (Material.texturedPbr 69 | { baseColor = baseColor 70 | , roughness = roughnessTexture 71 | , metallic = Material.constant 0 72 | } 73 | ) 74 | (Sphere3d.atOrigin radius) 75 | 76 | 77 | {-| Rack the balls at the foot spot on the table 78 | -} 79 | rack : Point2d Meters WorldCoordinates -> List (Body Id) 80 | rack footSpot = 81 | let 82 | -- TODO: randomly shuffle the balls? 83 | numbers = 84 | [ 1, 10, 4, 2, 8, 5, 9, 3, 14, 15, 11, 12, 6, 13, 7 ] 85 | in 86 | numbers 87 | |> List.indexedMap 88 | (\index number -> 89 | let 90 | -- index: 91 | -- 14 92 | -- 9 93 | -- 5 13 94 | -- 2 8 95 | -- 0 4 12 96 | -- 1 7 97 | -- 3 11 98 | -- 6 99 | -- 10 100 | -- row: 101 | -- 0 1 2 3 4 102 | row = 103 | round (sqrt (2 * (toFloat index + 1))) - 1 104 | 105 | offset = 106 | Vector3d.xyz 107 | (Quantity.multiplyBy (toFloat row * sqrt 3) radius) 108 | (Quantity.multiplyBy (toFloat (index * 2 - row * (row + 2))) radius) 109 | radius 110 | 111 | position = 112 | footSpot 113 | |> Point3d.on SketchPlane3d.xy 114 | |> Point3d.translateBy offset 115 | in 116 | ( EightBall.numberedBall number |> Maybe.map Numbered, position ) 117 | ) 118 | |> List.filterMap 119 | (\( maybeId, pos ) -> 120 | Maybe.map (body >> Body.moveTo pos) maybeId 121 | ) 122 | 123 | 124 | {-| Place a spotted ball on the line behind the foot spot, 125 | such that it doesn't collide with existing balls 126 | -} 127 | spot : Point2d Meters WorldCoordinates -> Ball -> World Id -> World Id 128 | spot footSpot spottedBall world = 129 | let 130 | -- the line behind the foot spot 131 | axis = 132 | Axis2d.through footSpot Direction2d.x 133 | 134 | -- the distance from the center of the table to the foot spot 135 | -- is equal to the distance from the foot spot to the foot rail 136 | distanceToFootRail = 137 | Point2d.xCoordinate footSpot 138 | 139 | occupiedRange ballPosition = 140 | ballPosition 141 | |> Point3d.projectInto SketchPlane3d.xy 142 | |> Circle2d.withRadius (Quantity.twice radius) 143 | |> intersectBy axis 144 | 145 | -- list of occupied ranges on the line behind the foot spot, 146 | -- the endpoints are sorted along the axis, e.g. for balls a, b and c: 147 | -- a1 (f) a2 b1 b2 c1 c2 | 148 | -- foot spot -----> foot rail 149 | occupiedRanges = 150 | world 151 | |> World.bodies 152 | |> List.filterMap 153 | (\b -> 154 | case Body.data b of 155 | Numbered _ -> 156 | occupiedRange (Body.originPoint b) 157 | 158 | CueBall -> 159 | occupiedRange (Body.originPoint b) 160 | 161 | _ -> 162 | Nothing 163 | ) 164 | 165 | behindFootSpot = 166 | occupiedRanges 167 | -- collect the furthest endpoints 168 | |> List.map Tuple.second 169 | |> List.filter 170 | (\point -> 171 | Quantity.greaterThan Quantity.zero point 172 | && Quantity.lessThan distanceToFootRail point 173 | ) 174 | -- sort based on the distance to the foot spot 175 | |> List.sortBy Quantity.unwrap 176 | 177 | inFrontOfFootSpot = 178 | occupiedRanges 179 | -- collect the nearest endpoints 180 | |> List.map Tuple.first 181 | |> List.filter (Quantity.lessThan Quantity.zero) 182 | -- sort based on the distance to the foot spot 183 | |> List.sortBy (Quantity.unwrap >> negate) 184 | 185 | spawnLocation = 186 | (Quantity.zero :: behindFootSpot ++ inFrontOfFootSpot) 187 | |> List.filter 188 | (\distance -> 189 | List.all 190 | (\( start, end ) -> 191 | Quantity.lessThanOrEqualTo start distance 192 | || Quantity.greaterThanOrEqualTo end distance 193 | ) 194 | occupiedRanges 195 | ) 196 | |> List.head 197 | -- should never happen, would result in overlapping balls! 198 | |> Maybe.withDefault Quantity.zero 199 | |> Point2d.along axis 200 | |> Point3d.on SketchPlane3d.xy 201 | |> Point3d.translateIn Direction3d.z radius 202 | in 203 | world 204 | |> World.add (body (Numbered spottedBall) |> Body.moveTo spawnLocation) 205 | 206 | 207 | intersectBy : Axis2d Meters coordinates -> Circle2d Meters coordinates -> Maybe ( Length, Length ) 208 | intersectBy axis circle = 209 | let 210 | axisOrigin = 211 | Axis2d.originPoint axis 212 | 213 | axisDirection = 214 | Axis2d.direction axis 215 | 216 | centerPoint = 217 | Circle2d.centerPoint circle 218 | 219 | circleCenterToOrigin = 220 | Vector2d.from centerPoint axisOrigin 221 | 222 | cto = 223 | Vector2d.toMeters circleCenterToOrigin 224 | 225 | ctoLengthSquared = 226 | cto.x ^ 2 + cto.y ^ 2 227 | 228 | dotProduct = 229 | Vector2d.componentIn axisDirection circleCenterToOrigin |> Length.inMeters 230 | 231 | r = 232 | Circle2d.radius circle |> Length.inMeters 233 | 234 | inRoot = 235 | dotProduct ^ 2 - ctoLengthSquared + r ^ 2 236 | in 237 | if inRoot < 0 then 238 | Nothing 239 | 240 | else 241 | let 242 | d1 = 243 | (-dotProduct - sqrt inRoot) |> Length.meters 244 | 245 | d2 = 246 | (-dotProduct + sqrt inRoot) |> Length.meters 247 | in 248 | Just ( d1, d2 ) 249 | -------------------------------------------------------------------------------- /src/Bodies.elm: -------------------------------------------------------------------------------- 1 | module Bodies exposing (Id(..)) 2 | 3 | {-| 4 | 5 | @docs Id 6 | 7 | -} 8 | 9 | import EightBall exposing (Ball) 10 | 11 | 12 | {-| Identify the different bodies in the physical simulation 13 | -} 14 | type Id 15 | = Floor 16 | | Numbered Ball 17 | | CueBall 18 | | Table 19 | | Cushion 20 | | Pocket 21 | -------------------------------------------------------------------------------- /src/Camera.elm: -------------------------------------------------------------------------------- 1 | module Camera exposing 2 | ( ScreenCoordinates, Camera, initial 3 | , camera3d, azimuth, orbitingPrecision 4 | , ray, mouseOrbiting, mouseWheelZoom 5 | , focusOn, zoomOut, animate 6 | ) 7 | 8 | {-| Animated 3d camera controls 9 | 10 | @docs ScreenCoordinates, Camera, initial 11 | 12 | 13 | # Current state 14 | 15 | @docs camera3d, azimuth, orbitingPrecision 16 | 17 | 18 | # Interaction 19 | 20 | @docs ray, mouseOrbiting, mouseWheelZoom 21 | 22 | 23 | # Animation 24 | 25 | @docs focusOn, zoomOut, animate 26 | 27 | -} 28 | 29 | import Angle exposing (Angle) 30 | import Animator exposing (Timeline) 31 | import Axis3d exposing (Axis3d) 32 | import Camera3d exposing (Camera3d) 33 | import Length exposing (Meters) 34 | import Physics.Coordinates exposing (WorldCoordinates) 35 | import Pixels exposing (Pixels) 36 | import Point2d exposing (Point2d) 37 | import Point3d exposing (Point3d) 38 | import Quantity exposing (Quantity) 39 | import Rectangle2d exposing (Rectangle2d) 40 | import SketchPlane3d 41 | import Time exposing (Posix) 42 | import Vector2d 43 | import Viewpoint3d 44 | 45 | 46 | {-| Screen space coordinate system 47 | -} 48 | type ScreenCoordinates 49 | = ScreenCoordinates Never 50 | 51 | 52 | {-| -} 53 | type Camera 54 | = Camera 55 | { zoom : Timeline Float -- also used for orbiting precision 56 | , azimuth : Angle -- also used for aiming (hit azimuth is relative to camera azimuth) 57 | , elevation : Timeline Angle 58 | , focalPoint : Timeline (Point3d Meters WorldCoordinates) 59 | } 60 | 61 | 62 | {-| Initial look at the table 63 | -} 64 | initial : Camera 65 | initial = 66 | Camera 67 | { zoom = Animator.init 0.9 68 | , azimuth = Angle.degrees -115 69 | , elevation = Animator.init (Angle.degrees 30) 70 | , focalPoint = Animator.init Point3d.origin 71 | } 72 | 73 | 74 | 75 | -- CURRENT STATE 76 | 77 | 78 | {-| Get the currrent Camera3d for rendering with elm-3d-scene 79 | -} 80 | camera3d : Camera -> Camera3d Meters WorldCoordinates 81 | camera3d (Camera camera) = 82 | let 83 | distance = 84 | Animator.move camera.zoom Animator.at 85 | |> Quantity.interpolateFrom (Length.meters 0.5) (Length.meters 6) 86 | 87 | focalPoint = 88 | Point3d.fromRecord Length.meters <| 89 | Animator.xyz camera.focalPoint 90 | (Point3d.toMeters 91 | >> (\p -> { x = Animator.at p.x, y = Animator.at p.y, z = Animator.at p.z }) 92 | ) 93 | in 94 | Camera3d.perspective 95 | { viewpoint = 96 | Viewpoint3d.orbit 97 | { focalPoint = focalPoint 98 | , groundPlane = SketchPlane3d.xy 99 | , azimuth = camera.azimuth 100 | , elevation = angleFromTimeline camera.elevation 101 | , distance = distance 102 | } 103 | , verticalFieldOfView = Angle.degrees 24 104 | } 105 | 106 | 107 | {-| Get the currrent azimuth used for aiming the cue 108 | -} 109 | azimuth : Camera -> Angle 110 | azimuth (Camera camera) = 111 | camera.azimuth 112 | 113 | 114 | {-| Make orbiting precision depend on zoom level. 115 | Controls how much radians correspond to the change in mouse offset. 116 | -} 117 | orbitingPrecision : Camera -> Quantity Float (Quantity.Rate Angle.Radians Pixels) 118 | orbitingPrecision (Camera camera) = 119 | Quantity.rate 120 | (Angle.radians (0.2 + Animator.move camera.zoom Animator.at / 0.8)) 121 | (Pixels.pixels (180 / pi)) 122 | 123 | 124 | 125 | -- INTERACTION 126 | 127 | 128 | {-| Get the ray from the camera into the viewplane, 129 | useful for mouse interactions with the 3d objects 130 | -} 131 | ray : 132 | Camera 133 | -> Rectangle2d Pixels ScreenCoordinates 134 | -> Point2d Pixels ScreenCoordinates 135 | -> Axis3d Meters WorldCoordinates 136 | ray camera = 137 | Camera3d.ray (camera3d camera) 138 | 139 | 140 | {-| Orbit the camera with mouse 141 | -} 142 | mouseOrbiting : Point2d Pixels ScreenCoordinates -> Point2d Pixels ScreenCoordinates -> Camera -> Camera 143 | mouseOrbiting originalPosition newPosition (Camera camera) = 144 | let 145 | ( deltaX, deltaY ) = 146 | newPosition 147 | |> Vector2d.from originalPosition 148 | |> Vector2d.components 149 | 150 | radiansInPixels = 151 | orbitingPrecision (Camera camera) 152 | 153 | newAzimuth = 154 | camera.azimuth 155 | |> Quantity.minus (Quantity.at radiansInPixels deltaX) 156 | |> Angle.normalize 157 | 158 | newElevation = 159 | angleFromTimeline camera.elevation 160 | |> Quantity.plus (Quantity.at radiansInPixels deltaY) 161 | |> Quantity.clamp (Angle.degrees 6) (Angle.degrees 90) 162 | in 163 | Camera 164 | { camera 165 | | azimuth = newAzimuth 166 | , elevation = Animator.go Animator.immediately newElevation camera.elevation 167 | } 168 | 169 | 170 | {-| Zoom in/out by mouse wheel delta 171 | -} 172 | mouseWheelZoom : Float -> Camera -> Camera 173 | mouseWheelZoom deltaY (Camera camera) = 174 | let 175 | newZoom = 176 | clamp 0 1 (Animator.move camera.zoom Animator.at - deltaY * 0.002) 177 | in 178 | Camera { camera | zoom = Animator.go Animator.immediately newZoom camera.zoom } 179 | 180 | 181 | {-| Read the angle value from the timeline 182 | -} 183 | angleFromTimeline : Timeline Angle -> Angle 184 | angleFromTimeline angleTimeline = 185 | Angle.radians (Animator.move angleTimeline (Angle.inRadians >> Animator.at)) 186 | 187 | 188 | 189 | -- ANIMATION 190 | 191 | 192 | {-| Animate the focal point of the camera to the new position 193 | -} 194 | focusOn : Point3d Meters WorldCoordinates -> Camera -> Camera 195 | focusOn focalPoint (Camera camera) = 196 | Camera 197 | { camera 198 | | focalPoint = Animator.go Animator.quickly focalPoint camera.focalPoint 199 | } 200 | 201 | 202 | {-| Zoom out the camera to look over the table from the top 203 | -} 204 | zoomOut : Camera -> Camera 205 | zoomOut (Camera camera) = 206 | Camera 207 | { camera 208 | | zoom = Animator.go Animator.verySlowly 1 camera.zoom 209 | , elevation = Animator.go Animator.verySlowly (Angle.degrees 50) camera.elevation 210 | } 211 | 212 | 213 | {-| Update the camera animation state, this needs to be called 214 | from the animation frame subscription 215 | -} 216 | animate : Posix -> Camera -> Camera 217 | animate time (Camera camera) = 218 | Camera 219 | { camera 220 | | elevation = Animator.updateTimeline time camera.elevation 221 | , zoom = Animator.updateTimeline time camera.zoom 222 | , focalPoint = Animator.updateTimeline time camera.focalPoint 223 | } 224 | -------------------------------------------------------------------------------- /src/Cue.elm: -------------------------------------------------------------------------------- 1 | module Cue exposing (entity, canShoot) 2 | 3 | {-| The cue is reperensented as an `Axis3d Meters WorldCoordinates` 4 | that points away from the hit point on the cue ball. 5 | 6 | @docs entity, canShoot 7 | 8 | -} 9 | 10 | import Angle 11 | import Axis3d exposing (Axis3d) 12 | import Bodies exposing (Id(..)) 13 | import Camera3d exposing (Camera3d) 14 | import Color exposing (Color) 15 | import Cylinder3d exposing (Cylinder3d) 16 | import Direction3d 17 | import Length exposing (Length, Meters) 18 | import Physics.Body as Body 19 | import Physics.Coordinates exposing (WorldCoordinates) 20 | import Physics.World as World exposing (World) 21 | import Point3d 22 | import Quantity 23 | import Scene3d exposing (Entity) 24 | import Scene3d.Material as Material 25 | import SketchPlane3d 26 | import Viewpoint3d 27 | 28 | 29 | length : Length 30 | length = 31 | Length.centimeters 150 32 | 33 | 34 | radius : Length 35 | radius = 36 | Length.millimeters 6 37 | 38 | 39 | {-| Cue offset from the cue ball 40 | -} 41 | offset : Length 42 | offset = 43 | Length.centimeters 2 44 | 45 | 46 | {-| Render the cue as a cylinder, make sure it is trimmed with the end cap 47 | when interecting with the view plane. 48 | -} 49 | entity : Camera3d Meters WorldCoordinates -> Length -> Color -> Axis3d Meters WorldCoordinates -> Entity WorldCoordinates 50 | entity camera3d clipDepth color axis = 51 | case cylinder camera3d clipDepth axis of 52 | Just trimmedCylinder -> 53 | Scene3d.cylinderWithShadow 54 | (Material.nonmetal 55 | { baseColor = color 56 | , roughness = 0.6 57 | } 58 | ) 59 | trimmedCylinder 60 | 61 | Nothing -> 62 | Scene3d.nothing 63 | 64 | 65 | cylinder : Camera3d Meters WorldCoordinates -> Length -> Axis3d Meters WorldCoordinates -> Maybe (Cylinder3d Meters WorldCoordinates) 66 | cylinder camera3d clipDepth axis = 67 | let 68 | viewPlane = 69 | camera3d 70 | |> Camera3d.viewpoint 71 | |> Viewpoint3d.viewPlane 72 | |> SketchPlane3d.toPlane 73 | 74 | trimmedCueLength = 75 | -- shorten the cue cylinder if intersects with the view plane 76 | case Axis3d.intersectionWithPlane viewPlane axis of 77 | Just point -> 78 | let 79 | distanceFromCamera = 80 | Point3d.distanceFrom (Axis3d.originPoint axis) point 81 | |> Quantity.minus clipDepth 82 | -- minus the offset from the cue ball 83 | |> Quantity.minus offset 84 | in 85 | if Quantity.lessThanOrEqualTo length distanceFromCamera then 86 | distanceFromCamera 87 | 88 | else 89 | length 90 | 91 | Nothing -> 92 | length 93 | in 94 | Cylinder3d.from 95 | (Point3d.along axis offset) 96 | (Point3d.along axis (Quantity.plus trimmedCueLength offset)) 97 | radius 98 | 99 | 100 | {-| Check if the cue doesn't overlap with any other objects 101 | -} 102 | canShoot : World Id -> Axis3d Meters WorldCoordinates -> Bool 103 | canShoot world axis = 104 | let 105 | direction = 106 | Axis3d.direction axis 107 | 108 | -- point on the perimeter of the tip of the cue cylinder, 109 | -- where the cue is placed at the hit point on the ball 110 | pointOnCueEnd = 111 | Point3d.translateIn 112 | (Direction3d.perpendicularTo direction) 113 | radius 114 | (Axis3d.originPoint axis) 115 | 116 | -- ignore collision with the cue ball 117 | worldWithoutCueBall = 118 | World.keepIf (\b -> Body.data b /= CueBall) world 119 | in 120 | -- cast 8 rays along the surface of the cue cylinder 121 | List.all 122 | (\n -> 123 | let 124 | rotatedPoint = 125 | pointOnCueEnd 126 | |> Point3d.rotateAround axis (Angle.turns (toFloat n / 8)) 127 | 128 | cueRay = 129 | Axis3d.through rotatedPoint direction 130 | in 131 | case World.raycast cueRay worldWithoutCueBall of 132 | Just { point, body } -> 133 | let 134 | collisionPoint = 135 | point |> Point3d.placeIn (Body.frame body) 136 | in 137 | -- if the distance is greater than the cue length + offset, then there is no overlap 138 | rotatedPoint 139 | |> Point3d.distanceFrom collisionPoint 140 | |> Quantity.greaterThan (Quantity.plus offset length) 141 | 142 | Nothing -> 143 | True 144 | ) 145 | (List.range 0 7) 146 | -------------------------------------------------------------------------------- /src/EightBall.elm: -------------------------------------------------------------------------------- 1 | module EightBall exposing 2 | ( Pool, start, AwaitingRack, AwaitingPlayerShot, AwaitingPlaceBallInHand, AwaitingPlaceBallBehindHeadstring, AwaitingStart 3 | , Player(..), currentPlayer, currentScore 4 | , CurrentTarget(..), currentTarget 5 | , rack, placeBallBehindHeadstring, placeBallInHand, playerShot, spotEightBall 6 | , ShotEvent 7 | , cueHitBall, cueHitWall, ballFellInPocket, ballHitWall, ballOffTable, scratch 8 | , Ball, oneBall, twoBall, threeBall, fourBall, fiveBall, sixBall, sevenBall, eightBall, nineBall, tenBall, elevenBall, twelveBall, thirteenBall, fourteenBall, fifteenBall, numberedBall, ballNumber 9 | , WhatHappened(..), NextPlayerAction(..) 10 | ) 11 | 12 | {-| Pool game rules. Agnostic to game engine. 13 | 14 | 8-Ball rules follow the WPA [8-Ball rules](https://wpapool.com/rules-of-play/#eight-ball) with the following exceptions: 15 | 16 | - Shots do not have to be called 17 | - Determining target group requires to sink only balls in one group. 18 | Examples: 19 | - Shooter pockets two solids while table is open (and doesn't scratch), then that player's target will become solids. 20 | - Shooter pockets a stripe while table is open (and doesn't scratch), then that player's target will become stripes. 21 | - Shooter pockets a stripe and two solids while table is open (and doesn't scratch), then the table is still open. 22 | 23 | 24 | # Init 25 | 26 | @docs Pool, start, AwaitingRack, AwaitingPlayerShot, AwaitingPlaceBallInHand, AwaitingPlaceBallBehindHeadstring, AwaitingStart 27 | 28 | 29 | # View 30 | 31 | @docs Player, currentPlayer, currentScore 32 | 33 | @docs CurrentTarget, currentTarget 34 | 35 | 36 | # Update 37 | 38 | @docs rack, placeBallBehindHeadstring, placeBallInHand, playerShot, spotEightBall 39 | 40 | 41 | ## Shot Events 42 | 43 | @docs ShotEvent 44 | @docs cueHitBall, cueHitWall, ballFellInPocket, ballHitWall, ballOffTable, scratch 45 | 46 | 47 | ## Balls 48 | 49 | @docs Ball, oneBall, twoBall, threeBall, fourBall, fiveBall, sixBall, sevenBall, eightBall, nineBall, tenBall, elevenBall, twelveBall, thirteenBall, fourteenBall, fifteenBall, numberedBall, ballNumber 50 | 51 | 52 | ## Ruling 53 | 54 | @docs WhatHappened, NextPlayerAction 55 | 56 | -} 57 | 58 | import Set 59 | import Time 60 | 61 | 62 | 63 | -- Model 64 | 65 | 66 | {-| This has details about the state of the game as it pertains to rules. 67 | This is what goes into your `Model`. 68 | -} 69 | type Pool state 70 | = Pool PoolData 71 | 72 | 73 | type alias PoolData = 74 | { events : List EventData 75 | , player : Player 76 | , pocketed : List ( Ball, Player ) -- Ideally this would be a Dictionary, but it would require a bit more work to generate a comparable for each ball. 77 | , target : TargetBalls 78 | } 79 | 80 | 81 | type alias EventData = 82 | { when : Time.Posix 83 | , event : InternalEvent 84 | } 85 | 86 | 87 | type TargetBalls 88 | = Open -- Any ball except the eight ball may be struck. 89 | | Grouped { solids : Player } 90 | 91 | 92 | pocketedIn : BallGroup -> List ( Ball, Player ) -> Int 93 | pocketedIn group pocketedBalls = 94 | pocketedBalls 95 | |> List.filter 96 | (\( Ball _ pocketedBallGroup, _ ) -> 97 | pocketedBallGroup == group 98 | ) 99 | |> List.length 100 | 101 | 102 | 103 | -- Player 104 | 105 | 106 | type Player 107 | = Player1 108 | | Player2 109 | 110 | 111 | switchPlayer : Player -> Player 112 | switchPlayer player = 113 | case player of 114 | Player1 -> 115 | Player2 116 | 117 | Player2 -> 118 | Player1 119 | 120 | 121 | 122 | -- Ball 123 | 124 | 125 | {-| A numbered ball. 126 | -} 127 | type Ball 128 | = Ball Int BallGroup 129 | 130 | 131 | {-| Create a ball. 132 | -} 133 | oneBall : Ball 134 | oneBall = 135 | Ball 1 SolidGroup 136 | 137 | 138 | {-| Create a ball. 139 | -} 140 | twoBall : Ball 141 | twoBall = 142 | Ball 2 SolidGroup 143 | 144 | 145 | {-| Create a ball. 146 | -} 147 | threeBall : Ball 148 | threeBall = 149 | Ball 3 SolidGroup 150 | 151 | 152 | {-| Create a ball. 153 | -} 154 | fourBall : Ball 155 | fourBall = 156 | Ball 4 SolidGroup 157 | 158 | 159 | {-| Create a ball. 160 | -} 161 | fiveBall : Ball 162 | fiveBall = 163 | Ball 5 SolidGroup 164 | 165 | 166 | {-| Create a ball. 167 | -} 168 | sixBall : Ball 169 | sixBall = 170 | Ball 6 SolidGroup 171 | 172 | 173 | {-| Create a ball. 174 | -} 175 | sevenBall : Ball 176 | sevenBall = 177 | Ball 7 SolidGroup 178 | 179 | 180 | {-| Create a ball. 181 | -} 182 | eightBall : Ball 183 | eightBall = 184 | Ball 8 EightGroup 185 | 186 | 187 | {-| Create a ball. 188 | -} 189 | nineBall : Ball 190 | nineBall = 191 | Ball 9 StripeGroup 192 | 193 | 194 | {-| Create a ball. 195 | -} 196 | tenBall : Ball 197 | tenBall = 198 | Ball 10 StripeGroup 199 | 200 | 201 | {-| Create a ball. 202 | -} 203 | elevenBall : Ball 204 | elevenBall = 205 | Ball 11 StripeGroup 206 | 207 | 208 | {-| Create a ball. 209 | -} 210 | twelveBall : Ball 211 | twelveBall = 212 | Ball 12 StripeGroup 213 | 214 | 215 | {-| Create a ball. 216 | -} 217 | thirteenBall : Ball 218 | thirteenBall = 219 | Ball 13 StripeGroup 220 | 221 | 222 | {-| Create a ball. 223 | -} 224 | fourteenBall : Ball 225 | fourteenBall = 226 | Ball 14 StripeGroup 227 | 228 | 229 | {-| Create a ball. 230 | -} 231 | fifteenBall : Ball 232 | fifteenBall = 233 | Ball 15 StripeGroup 234 | 235 | 236 | {-| Create a ball with a given number. Returns `Nothing` for numbers outside of [1, 15]. 237 | 238 | numberedBall 13 == Just thirteenBall 239 | 240 | numberedBall 66 == Nothing 241 | 242 | -} 243 | numberedBall : Int -> Maybe Ball 244 | numberedBall number = 245 | if number <= 0 then 246 | Nothing 247 | 248 | else if number <= 7 then 249 | Just (Ball number SolidGroup) 250 | 251 | else if number == 8 then 252 | Just (Ball 8 EightGroup) 253 | 254 | else if number <= 15 then 255 | Just (Ball number StripeGroup) 256 | 257 | else 258 | Nothing 259 | 260 | 261 | {-| Get the int value for a ball: 262 | 263 | ballNumber eightBall == 8 264 | 265 | ballNumber fifteenBall == 15 266 | 267 | -} 268 | ballNumber : Ball -> Int 269 | ballNumber (Ball n _) = 270 | n 271 | 272 | 273 | 274 | -- Init 275 | 276 | 277 | {-| Start a game. 278 | -} 279 | start : Pool AwaitingRack 280 | start = 281 | Pool 282 | { events = [] 283 | , player = Player1 284 | , pocketed = [] 285 | , target = Open 286 | } 287 | 288 | 289 | 290 | -- View 291 | 292 | 293 | {-| Get the current player 294 | -} 295 | currentPlayer : Pool state -> Player 296 | currentPlayer (Pool { player }) = 297 | player 298 | 299 | 300 | {-| Get the current score. 301 | -} 302 | currentScore : Pool state -> { player1 : Int, player2 : Int } 303 | currentScore (Pool { pocketed, target }) = 304 | case target of 305 | Open -> 306 | { player1 = 0 307 | , player2 = 0 308 | } 309 | 310 | Grouped { solids } -> 311 | case solids of 312 | Player1 -> 313 | { player1 = pocketedIn SolidGroup pocketed 314 | , player2 = pocketedIn StripeGroup pocketed 315 | } 316 | 317 | Player2 -> 318 | { player1 = pocketedIn StripeGroup pocketed 319 | , player2 = pocketedIn SolidGroup pocketed 320 | } 321 | 322 | 323 | {-| The current target. 324 | -} 325 | type CurrentTarget 326 | = OpenTable 327 | | Solids 328 | | Stripes 329 | | EightBall 330 | 331 | 332 | {-| Get the current target based on the current player and pocketed balls in the game. 333 | 334 | 1. Open table - when the player may shoot at either solids or stripes, attempting to pocket a ball of either set. 335 | 2. Solids - the current player must shoot at solids, pocketing at least one of them without scratching in order to keep shooting. 336 | 3. Stripes - the current player must shoot at stripes, pocketing at least one of them without scratching in order to keep shooting. 337 | 4. 8-ball - the player must shoot at the 8-ball. If it is pocketed without a foul or scratch, the player wins. 338 | 339 | -} 340 | currentTarget : Pool state -> CurrentTarget 341 | currentTarget (Pool ({ pocketed } as poolData)) = 342 | case poolData.target of 343 | Open -> 344 | OpenTable 345 | 346 | Grouped { solids } -> 347 | if solids == poolData.player then 348 | if pocketedIn SolidGroup pocketed == 7 then 349 | EightBall 350 | 351 | else 352 | Solids 353 | 354 | else if pocketedIn StripeGroup pocketed == 7 then 355 | EightBall 356 | 357 | else 358 | Stripes 359 | 360 | 361 | 362 | -- Update 363 | 364 | 365 | {-| Waiting for the balls to be racked. 366 | 367 | Use `rack` when in this state. 368 | 369 | -} 370 | type AwaitingRack 371 | = AwaitingRack Never 372 | 373 | 374 | {-| Ready for a player to take a shot. 375 | -} 376 | type AwaitingPlayerShot 377 | = AwaitingPlayerShot Never 378 | 379 | 380 | {-| When a player scratches, or otherwise fouls, during regular play, the next player is given ball-in-hand anywhere on the table. 381 | 382 | See [WPA rules](https://wpapool.com/rules-of-play/) 1.5 Cue Ball in Hand for more info. 383 | 384 | -} 385 | type AwaitingPlaceBallInHand 386 | = AwaitingPlaceBallInHand Never 387 | 388 | 389 | {-| This is the area where the player can place the cue ball before a break. 390 | 391 | From WPA [rules 8.1 Parts of the Table](https://wpapool.com/rules-of-play/#Definitions): 392 | 393 | > Behind the head string is the area between the head rail and the head string, not including the 394 | > head string. 395 | 396 | Also known as "in the kitchen". 397 | 398 | -} 399 | type AwaitingPlaceBallBehindHeadstring 400 | = AwaitingPlaceBallBehindHeadstring Never 401 | 402 | 403 | {-| When a player knocks the eight (8) ball off the table on the break, the 8-ball must be spotted before the next player places ball-in-hand. 404 | 405 | From WPA [rules 3.7 Spotting Balls](https://wpapool.com/rules-of-play/#eight-ball) 406 | 407 | > If the eight ball is pocketed or driven off the table on the break, it will be spotted or the balls 408 | > will be re-racked. (See 3.3 Break Shot and 1.4 Spotting Balls.) No other object ball is ever 409 | > spotted. 410 | 411 | -} 412 | type AwaitingSpotEightBall 413 | = AwaitingSpotEightBall Never 414 | 415 | 416 | {-| When the game is over, start a new game to play again. 417 | -} 418 | type AwaitingStart 419 | = AwaitingStart Never 420 | 421 | 422 | {-| The balls must be racked before the player can place the cue ball and break. 423 | -} 424 | rack : Time.Posix -> Pool AwaitingRack -> Pool AwaitingPlaceBallBehindHeadstring 425 | rack when (Pool data) = 426 | Pool 427 | { data 428 | | events = 429 | data.events 430 | ++ [ { when = when 431 | , event = Racked 432 | } 433 | ] 434 | } 435 | 436 | 437 | type InternalEvent 438 | = Racked 439 | -- Player actions 440 | | BallPlacedBehindHeadString 441 | | BallPlacedInHand 442 | | EightBallSpotted 443 | -- | CallShot Ball Pocket 444 | | Shot (List ( Time.Posix, ShotEvent )) 445 | -- Game over 446 | | GameOver_ 447 | 448 | 449 | {-| All potential shot events available. 450 | 451 | There is one which should be supported, but is not yet: 452 | 453 | - BallToBall 454 | 455 | -} 456 | type ShotEvent 457 | = BallOffTable Ball 458 | -- BallToBall Ball Ball (List Ball) 459 | | BallToPocket Ball --Pocket 460 | | BallToWall Ball -- Wall 461 | | CueHitBall Ball 462 | | CueHitWall 463 | | Scratch 464 | 465 | 466 | {-| When the ball is placed behind the head string after racking. 467 | -} 468 | placeBallBehindHeadstring : Time.Posix -> Pool AwaitingPlaceBallBehindHeadstring -> Pool AwaitingPlayerShot 469 | placeBallBehindHeadstring when (Pool data) = 470 | Pool 471 | { data 472 | | events = 473 | data.events 474 | ++ [ { when = when 475 | , event = BallPlacedBehindHeadString 476 | } 477 | ] 478 | } 479 | 480 | 481 | {-| When the ball is placed anywhere on the table. 482 | -} 483 | placeBallInHand : Time.Posix -> Pool AwaitingPlaceBallInHand -> Pool AwaitingPlayerShot 484 | placeBallInHand when (Pool data) = 485 | Pool 486 | { data 487 | | events = 488 | data.events 489 | ++ [ { when = when 490 | , event = BallPlacedInHand 491 | } 492 | ] 493 | } 494 | 495 | 496 | {-| When the 8-ball is spotted. 497 | -} 498 | spotEightBall : Time.Posix -> Pool AwaitingSpotEightBall -> Pool AwaitingPlaceBallBehindHeadstring 499 | spotEightBall when (Pool data) = 500 | Pool 501 | { data 502 | | events = 503 | data.events 504 | ++ [ { when = when 505 | , event = EightBallSpotted 506 | } 507 | ] 508 | } 509 | 510 | 511 | {-| When the cue ball comes into contact with a numbered ball. 512 | 513 | Note: once they are touching, there's no need to send this event again unless they are separated and come back into contact. 514 | 515 | -} 516 | cueHitBall : Time.Posix -> Ball -> ( Time.Posix, ShotEvent ) 517 | cueHitBall when ball = 518 | ( when 519 | , CueHitBall ball 520 | ) 521 | 522 | 523 | {-| When the cue ball touches the wall. 524 | 525 | Note: once they are touching, there's no need to send this event again unless they are separated and come back into contact. 526 | 527 | -} 528 | cueHitWall : Time.Posix -> ( Time.Posix, ShotEvent ) 529 | cueHitWall when = 530 | ( when 531 | , CueHitWall 532 | ) 533 | 534 | 535 | 536 | -- {-| When two or more balls contact one another. 537 | -- 538 | -- Note: once they are touching, there's no need to send this event again unless they are separated and come back into contact. 539 | -- 540 | -- -} 541 | -- ballsCollided : Time.Posix -> Ball -> Ball -> List Ball -> ( Time.Posix, ShotEvent ) 542 | -- ballsCollided when ball1 ball2 otherBalls = 543 | -- ( when 544 | -- , BallToBall ball1 ball2 otherBalls 545 | -- ) 546 | 547 | 548 | {-| When a ball touches the wall. 549 | 550 | Note: once they are touching, there's no need to send this event again unless they are separated and come back into contact. 551 | 552 | -} 553 | ballHitWall : Time.Posix -> Ball -> ( Time.Posix, ShotEvent ) 554 | ballHitWall when ball = 555 | ( when 556 | , BallToWall ball 557 | ) 558 | 559 | 560 | {-| When a numbered ball is pocketed. 561 | -} 562 | ballFellInPocket : Time.Posix -> Ball -> ( Time.Posix, ShotEvent ) 563 | ballFellInPocket when ball = 564 | ( when 565 | , BallToPocket ball 566 | ) 567 | 568 | 569 | {-| When a ball is knocked off the table. 570 | -} 571 | ballOffTable : Time.Posix -> Ball -> ( Time.Posix, ShotEvent ) 572 | ballOffTable when ball = 573 | ( when 574 | , BallOffTable ball 575 | ) 576 | 577 | 578 | {-| When the cue ball is pocketed. 579 | 580 | [WPA Rules 8.6](https://wpapool.com/rules-of-play/#86Scratch) 581 | 582 | -} 583 | scratch : Time.Posix -> ( Time.Posix, ShotEvent ) 584 | scratch when = 585 | ( when 586 | , Scratch 587 | ) 588 | 589 | 590 | 591 | -- Ruling 592 | 593 | 594 | {-| After a player shoots, this returns the outcome. 595 | 596 | - IllegalBreak - when a player does not drive four (4) balls to a wall. The balls must be reracked and the next player must place the ball behind the head string and break again. 597 | - PlayersFault - when a player scratches (or, in the future, hits the wrong ball first). The next player must place the ball in hand. 598 | - NextShot - waiting for a player to shoot. Use `currentPlayer` to figure out which player is shooting. Use `playerShot` after the player shoots. 599 | - GameOver - when the game is over, this returns the winner. 600 | 601 | -} 602 | type WhatHappened 603 | = IllegalBreak (Pool AwaitingRack) 604 | | PlayersFault NextPlayerAction 605 | | NextShot (Pool AwaitingPlayerShot) 606 | | GameOver (Pool AwaitingStart) { winner : Player } 607 | 608 | 609 | type NextPlayerAction 610 | = SpotEightBall (Pool AwaitingSpotEightBall) 611 | -- | ChooseNextAction NextPlayerAction NextPlayerAction (List NextPlayerAction) 612 | | PlaceBallInHand (Pool AwaitingPlaceBallInHand) 613 | 614 | 615 | {-| Set game over via this function so we don't forget to add the internal event. 616 | -} 617 | endGame : Pool a -> Pool AwaitingStart 618 | endGame (Pool poolData) = 619 | Pool 620 | { poolData 621 | | events = 622 | poolData.events 623 | ++ [ { event = GameOver_ 624 | , when = lastEventTime poolData.events 625 | } 626 | ] 627 | } 628 | 629 | 630 | {-| Send a series of shot events. 631 | 632 | Note: if no balls are hit by the cue ball, send an empty list. 633 | 634 | playerShot [] pool -- Cue struck, but no other balls hit. 635 | 636 | -} 637 | playerShot : List ( Time.Posix, ShotEvent ) -> Pool AwaitingPlayerShot -> WhatHappened 638 | playerShot shotEvents (Pool data) = 639 | case lastEvent data.events of 640 | Just BallPlacedBehindHeadString -> 641 | playerBreak shotEvents data 642 | 643 | Just Racked -> 644 | -- Error "The cue ball must be placed behind the headstring. The API should not allow this." 645 | -- Make an assumption for now since we do not handle errors well in the game. 646 | playerRegularShot shotEvents data 647 | 648 | Just BallPlacedInHand -> 649 | playerRegularShot shotEvents data 650 | 651 | Just EightBallSpotted -> 652 | -- Error "The cue ball must be placed behind the headstring. The API should not allow this." 653 | -- Make an assumption for now since we do not handle errors well in the game. 654 | playerRegularShot shotEvents data 655 | 656 | Just (Shot _) -> 657 | playerRegularShot shotEvents data 658 | 659 | Just GameOver_ -> 660 | -- Error "The game is over. How did a player take another shot? The API should not allow this." 661 | -- Make an assumption for now since we do not handle errors well in the game. 662 | playerRegularShot shotEvents data 663 | 664 | Nothing -> 665 | -- Error "The table must be racked and ball placed behind the headstring. The API should not allow this." 666 | -- Make an assumption for now since we do not handle errors well in the game. 667 | playerRegularShot shotEvents data 668 | 669 | 670 | playerBreak : List ( Time.Posix, ShotEvent ) -> PoolData -> WhatHappened 671 | playerBreak shotEvents data = 672 | let 673 | { allPocketedBalls } = 674 | groupPocketedEvents shotEvents 675 | 676 | numberOfBallsToWall = 677 | numberOfBallsHitWall shotEvents 678 | in 679 | if (numberOfBallsToWall < 4) && (List.length allPocketedBalls < 1) then 680 | IllegalBreak <| 681 | Pool 682 | { data 683 | | player = switchPlayer data.player 684 | , events = 685 | data.events 686 | ++ [ { event = Shot [] 687 | , when = lastEventTime data.events 688 | } 689 | ] 690 | |> List.sortWith eventTimeComparison 691 | } 692 | 693 | else if eightBallOffTable shotEvents then 694 | PlayersFault <| 695 | SpotEightBall <| 696 | Pool 697 | { data 698 | | player = switchPlayer data.player 699 | , events = 700 | data.events 701 | ++ [ { event = Shot shotEvents 702 | , when = lastEventTime data.events 703 | } 704 | ] 705 | |> List.sortWith eventTimeComparison 706 | } 707 | 708 | else 709 | -- We can assume the regular shot rules will apply because there are no incongruities. 710 | playerRegularShot shotEvents data 711 | 712 | 713 | numberOfBallsHitWall : List ( Time.Posix, ShotEvent ) -> Int 714 | numberOfBallsHitWall = 715 | List.filterMap 716 | (\( _, shotEvent ) -> 717 | case shotEvent of 718 | BallOffTable _ -> 719 | Nothing 720 | 721 | BallToPocket _ -> 722 | Nothing 723 | 724 | BallToWall (Ball number _) -> 725 | Just number 726 | 727 | CueHitBall _ -> 728 | Nothing 729 | 730 | CueHitWall -> 731 | Nothing 732 | 733 | Scratch -> 734 | Nothing 735 | ) 736 | >> Set.fromList 737 | >> Set.size 738 | 739 | 740 | playerRegularShot : List ( Time.Posix, ShotEvent ) -> PoolData -> WhatHappened 741 | playerRegularShot shotEvents data = 742 | case shotEvents of 743 | [] -> 744 | -- Assume the cue is struck, but no other balls are hit. 745 | PlayersFault <| 746 | PlaceBallInHand <| 747 | Pool 748 | { data 749 | | player = switchPlayer data.player 750 | , events = 751 | data.events 752 | ++ [ { event = Shot [] 753 | , when = lastEventTime data.events 754 | } 755 | ] 756 | |> List.sortWith eventTimeComparison 757 | } 758 | 759 | ( firstShotTime, _ ) :: _ -> 760 | let 761 | allEventDataSorted = 762 | data.events 763 | ++ [ { event = Shot shotEvents -- TODO: Sort these shotEvents. 764 | , when = firstShotTime 765 | } 766 | ] 767 | |> List.sortWith eventTimeComparison 768 | 769 | ballPocketedEvents = 770 | groupPocketedEvents shotEvents 771 | 772 | newPoolData = 773 | { data 774 | | events = allEventDataSorted 775 | , target = 776 | checkNextTarget 777 | ballPocketedEvents 778 | data 779 | , pocketed = 780 | updatePocketed 781 | ballPocketedEvents 782 | data 783 | } 784 | 785 | previousTarget = 786 | -- This gets the currentTarget on the _old_ `data`. 787 | currentTarget (Pool data) 788 | in 789 | checkShot shotEvents 790 | ballPocketedEvents 791 | previousTarget 792 | newPoolData 793 | 794 | 795 | {-| TODO: May need to check for equal times and put things like Racked before BallPlacedBehindHeadString. 796 | -} 797 | eventTimeComparison : EventData -> EventData -> Order 798 | eventTimeComparison eventData1 eventData2 = 799 | compare 800 | (Time.posixToMillis eventData1.when) 801 | (Time.posixToMillis eventData2.when) 802 | 803 | 804 | {-| TODO: May need to check for equal times and put things like CueHitBall before BallToPocket. 805 | -} 806 | shotEventTimeComparison : ( Time.Posix, ShotEvent ) -> ( Time.Posix, ShotEvent ) -> Order 807 | shotEventTimeComparison ( time1, _ ) ( time2, _ ) = 808 | compare 809 | (Time.toMillis Time.utc time1) 810 | (Time.toMillis Time.utc time2) 811 | 812 | 813 | checkNextTarget : BallPocketedEvents -> PoolData -> TargetBalls 814 | checkNextTarget { allPocketedBalls, solidsPocketed, stripesPocketed } poolData = 815 | case poolData.target of 816 | Open -> 817 | if 818 | List.length allPocketedBalls > 0 819 | -- TODO: and player did not foul. 820 | then 821 | if List.length solidsPocketed == List.length allPocketedBalls then 822 | -- All balls pocketed are solids. 823 | Grouped 824 | { solids = 825 | poolData.player 826 | } 827 | 828 | else if List.length stripesPocketed == List.length allPocketedBalls then 829 | -- All balls pocketed are stripes. 830 | Grouped 831 | { solids = 832 | switchPlayer poolData.player 833 | } 834 | 835 | else 836 | poolData.target 837 | 838 | else 839 | poolData.target 840 | 841 | Grouped _ -> 842 | poolData.target 843 | 844 | 845 | type alias BallPocketedEvents = 846 | { allPocketedBalls : List ( Time.Posix, ShotEvent ) 847 | , solidsPocketed : List ( Time.Posix, ShotEvent ) 848 | , stripesPocketed : List ( Time.Posix, ShotEvent ) 849 | , scratched : Bool 850 | , eightBallPocketed : Bool 851 | } 852 | 853 | 854 | {-| Categorize ball pocketing events. 855 | 856 | TODO: It would be more efficient to fold over the list. 857 | 858 | -} 859 | groupPocketedEvents : List ( Time.Posix, ShotEvent ) -> BallPocketedEvents 860 | groupPocketedEvents shotEvents = 861 | let 862 | allPocketedBalls = 863 | List.filter 864 | (\( _, shotEvent ) -> 865 | case shotEvent of 866 | BallOffTable _ -> 867 | False 868 | 869 | BallToPocket _ -> 870 | True 871 | 872 | BallToWall _ -> 873 | False 874 | 875 | CueHitBall _ -> 876 | False 877 | 878 | CueHitWall -> 879 | False 880 | 881 | Scratch -> 882 | True 883 | ) 884 | shotEvents 885 | 886 | scratched = 887 | List.any 888 | (\( _, shotEvent ) -> 889 | case shotEvent of 890 | BallOffTable _ -> 891 | False 892 | 893 | BallToPocket _ -> 894 | False 895 | 896 | BallToWall _ -> 897 | False 898 | 899 | CueHitBall _ -> 900 | False 901 | 902 | CueHitWall -> 903 | False 904 | 905 | Scratch -> 906 | True 907 | ) 908 | allPocketedBalls 909 | in 910 | { allPocketedBalls = allPocketedBalls 911 | , scratched = scratched 912 | , solidsPocketed = List.filter (ballPocketedInGroup SolidGroup) allPocketedBalls 913 | , stripesPocketed = List.filter (ballPocketedInGroup StripeGroup) allPocketedBalls 914 | , eightBallPocketed = List.any (ballPocketedInGroup EightGroup) allPocketedBalls 915 | } 916 | 917 | 918 | updatePocketed : BallPocketedEvents -> PoolData -> List ( Ball, Player ) 919 | updatePocketed ballPocketedEvents poolData = 920 | let 921 | newPocketedBalls = 922 | (ballPocketedEvents.solidsPocketed 923 | ++ ballPocketedEvents.stripesPocketed 924 | ) 925 | |> List.filterMap 926 | (\( _, shotEvent ) -> 927 | case shotEvent of 928 | BallToPocket ball -> 929 | Just ( ball, poolData.player ) 930 | 931 | _ -> 932 | Nothing 933 | ) 934 | in 935 | poolData.pocketed 936 | ++ newPocketedBalls 937 | 938 | 939 | type BallGroup 940 | = SolidGroup 941 | | StripeGroup 942 | | EightGroup 943 | 944 | 945 | ballGroup : Ball -> BallGroup 946 | ballGroup (Ball _ group) = 947 | group 948 | 949 | 950 | ballPocketedInGroup : BallGroup -> ( Time.Posix, ShotEvent ) -> Bool 951 | ballPocketedInGroup ballGroup_ ( _, shotEvent ) = 952 | case shotEvent of 953 | BallOffTable _ -> 954 | False 955 | 956 | BallToPocket ball -> 957 | ballGroup ball == ballGroup_ 958 | 959 | BallToWall _ -> 960 | False 961 | 962 | CueHitBall _ -> 963 | False 964 | 965 | CueHitWall -> 966 | False 967 | 968 | Scratch -> 969 | False 970 | 971 | 972 | {-| Check whether the player makes a legal hit. 973 | 974 | A legal hit during regular play (after the break) is based on the target ball group: 975 | 976 | - Open table: the first ball hit by the cue can be either a solid or a stripe, but not the 8-ball. 977 | - Solid group: the first ball hit by the cue must be in the solid group. 978 | - Stripe group: the first ball hit by the cue must be in the stripe group. 979 | - Eight ball: the first ball hit by the cue must be the 8-ball. 980 | 981 | -} 982 | isLegalHit : List ( Time.Posix, ShotEvent ) -> CurrentTarget -> Bool 983 | isLegalHit shotEvents previousTarget = 984 | case ( previousTarget, legalFirstBallHitGroup shotEvents ) of 985 | ( OpenTable, Just SolidGroup ) -> 986 | True 987 | 988 | ( OpenTable, Just StripeGroup ) -> 989 | True 990 | 991 | ( Solids, Just SolidGroup ) -> 992 | True 993 | 994 | ( Stripes, Just StripeGroup ) -> 995 | True 996 | 997 | ( EightBall, Just EightGroup ) -> 998 | True 999 | 1000 | _ -> 1001 | False 1002 | 1003 | 1004 | {-| This finds the group of the first ball hit by the cue, if there is one, and only if any ball hit a wall after. 1005 | -} 1006 | legalFirstBallHitGroup : List ( Time.Posix, ShotEvent ) -> Maybe BallGroup 1007 | legalFirstBallHitGroup shotEvents = 1008 | case shotEvents of 1009 | [] -> 1010 | Nothing 1011 | 1012 | ( _, CueHitBall ball ) :: otherShotEvents -> 1013 | if List.any hasHitAWallOrPocket otherShotEvents then 1014 | Just (ballGroup ball) 1015 | 1016 | else 1017 | Nothing 1018 | 1019 | _ :: otherShotEvents -> 1020 | legalFirstBallHitGroup otherShotEvents 1021 | 1022 | 1023 | hasHitAWallOrPocket : ( Time.Posix, ShotEvent ) -> Bool 1024 | hasHitAWallOrPocket ( _, shotEvent ) = 1025 | case shotEvent of 1026 | BallOffTable _ -> 1027 | False 1028 | 1029 | CueHitBall _ -> 1030 | False 1031 | 1032 | CueHitWall -> 1033 | True 1034 | 1035 | BallToPocket _ -> 1036 | True 1037 | 1038 | BallToWall _ -> 1039 | True 1040 | 1041 | Scratch -> 1042 | False 1043 | 1044 | 1045 | eightBallOffTable : List ( Time.Posix, ShotEvent ) -> Bool 1046 | eightBallOffTable shotEvents = 1047 | List.any eightBallOffTableEvent shotEvents 1048 | 1049 | 1050 | eightBallOffTableEvent : ( Time.Posix, ShotEvent ) -> Bool 1051 | eightBallOffTableEvent ( _, shotEvent ) = 1052 | case shotEvent of 1053 | BallOffTable ball -> 1054 | ball == eightBall 1055 | 1056 | _ -> 1057 | False 1058 | 1059 | 1060 | nonEightBallOffTable : List ( Time.Posix, ShotEvent ) -> Bool 1061 | nonEightBallOffTable shotEvents = 1062 | List.any nonEightBallOffTableEvent shotEvents 1063 | 1064 | 1065 | nonEightBallOffTableEvent : ( Time.Posix, ShotEvent ) -> Bool 1066 | nonEightBallOffTableEvent ( _, shotEvent ) = 1067 | case shotEvent of 1068 | BallOffTable ball -> 1069 | ball /= eightBall 1070 | 1071 | _ -> 1072 | False 1073 | 1074 | 1075 | checkShot : List ( Time.Posix, ShotEvent ) -> BallPocketedEvents -> CurrentTarget -> PoolData -> WhatHappened 1076 | checkShot shotEvents ballPocketedEvents previousTarget poolData = 1077 | if 1078 | ballPocketedEvents.eightBallPocketed 1079 | || eightBallOffTable shotEvents 1080 | then 1081 | case currentTarget (Pool poolData) of 1082 | EightBall -> 1083 | -- TODO: Combine case into tuple with new type `Scratched | NotScratched`. 1084 | let 1085 | winningPlayer = 1086 | if 1087 | ballPocketedEvents.scratched 1088 | || not (isLegalHit shotEvents previousTarget) 1089 | || eightBallOffTable shotEvents 1090 | then 1091 | switchPlayer poolData.player 1092 | 1093 | else 1094 | poolData.player 1095 | in 1096 | GameOver (endGame (Pool poolData)) 1097 | { winner = winningPlayer } 1098 | 1099 | _ -> 1100 | -- If the player wasn't targeting the 8-ball, then they lose! 1101 | GameOver (endGame (Pool poolData)) 1102 | { winner = switchPlayer poolData.player } 1103 | 1104 | else if 1105 | ballPocketedEvents.scratched 1106 | || not (isLegalHit shotEvents previousTarget) 1107 | || nonEightBallOffTable shotEvents 1108 | then 1109 | PlayersFault <| 1110 | PlaceBallInHand <| 1111 | Pool 1112 | { poolData 1113 | | player = switchPlayer poolData.player 1114 | 1115 | -- TODO: Log Scratched/PlayersFault internal event. 1116 | -- Should these be two separate events? 1117 | } 1118 | 1119 | else 1120 | NextShot <| 1121 | Pool 1122 | { poolData 1123 | | player = 1124 | checkNextPlayer ballPocketedEvents 1125 | previousTarget 1126 | poolData 1127 | } 1128 | 1129 | 1130 | {-| Check who should be the next player. 1131 | -} 1132 | checkNextPlayer : BallPocketedEvents -> CurrentTarget -> PoolData -> Player 1133 | checkNextPlayer ({ allPocketedBalls, eightBallPocketed, solidsPocketed, stripesPocketed, scratched } as ballPocketedEvents) previousTarget poolData = 1134 | if scratched then 1135 | switchPlayer poolData.player 1136 | 1137 | else if List.length allPocketedBalls == 0 then 1138 | switchPlayer poolData.player 1139 | 1140 | else 1141 | case previousTarget of 1142 | OpenTable -> 1143 | if pocketedInSameGroup ballPocketedEvents then 1144 | poolData.player 1145 | 1146 | else 1147 | switchPlayer poolData.player 1148 | 1149 | Solids -> 1150 | if List.length solidsPocketed > 0 then 1151 | poolData.player 1152 | 1153 | else 1154 | switchPlayer poolData.player 1155 | 1156 | Stripes -> 1157 | if List.length stripesPocketed > 0 then 1158 | poolData.player 1159 | 1160 | else 1161 | switchPlayer poolData.player 1162 | 1163 | EightBall -> 1164 | if eightBallPocketed then 1165 | poolData.player 1166 | 1167 | else 1168 | switchPlayer poolData.player 1169 | 1170 | 1171 | pocketedInSameGroup : BallPocketedEvents -> Bool 1172 | pocketedInSameGroup { solidsPocketed, stripesPocketed } = 1173 | (List.length solidsPocketed 1174 | > 0 1175 | && List.length stripesPocketed 1176 | == 0 1177 | ) 1178 | || (List.length stripesPocketed 1179 | > 0 1180 | && List.length solidsPocketed 1181 | == 0 1182 | ) 1183 | 1184 | 1185 | lastEvent : List EventData -> Maybe InternalEvent 1186 | lastEvent = 1187 | List.sortWith eventTimeComparison 1188 | >> List.reverse 1189 | >> List.head 1190 | >> Maybe.map .event 1191 | 1192 | 1193 | {-| When a player shoots, but sends no events, we still want to log the event, so we try to find the last event time. If there is none, default to `Time.millisToPosix 0`. 1194 | -} 1195 | lastEventTime : List EventData -> Time.Posix 1196 | lastEventTime events = 1197 | let 1198 | maybeLastEventTime = 1199 | events 1200 | |> List.sortWith eventTimeComparison 1201 | |> List.reverse 1202 | |> List.head 1203 | |> Maybe.andThen lastEventTimeByEventType 1204 | in 1205 | case maybeLastEventTime of 1206 | Nothing -> 1207 | Time.millisToPosix 0 1208 | 1209 | Just time -> 1210 | time 1211 | 1212 | 1213 | lastEventTimeByEventType : EventData -> Maybe Time.Posix 1214 | lastEventTimeByEventType eventData = 1215 | case eventData.event of 1216 | Shot shotEvents -> 1217 | lastShotEventTime shotEvents 1218 | 1219 | Racked -> 1220 | Just eventData.when 1221 | 1222 | BallPlacedBehindHeadString -> 1223 | Just eventData.when 1224 | 1225 | BallPlacedInHand -> 1226 | Just eventData.when 1227 | 1228 | EightBallSpotted -> 1229 | Just eventData.when 1230 | 1231 | GameOver_ -> 1232 | Just eventData.when 1233 | 1234 | 1235 | lastShotEventTime : List ( Time.Posix, ShotEvent ) -> Maybe Time.Posix 1236 | lastShotEventTime shotEvents = 1237 | case 1238 | shotEvents 1239 | |> List.sortWith shotEventTimeComparison 1240 | |> List.reverse 1241 | of 1242 | [] -> 1243 | Nothing 1244 | 1245 | ( firstShotTime, _ ) :: _ -> 1246 | Just firstShotTime 1247 | -------------------------------------------------------------------------------- /src/Game.elm: -------------------------------------------------------------------------------- 1 | module Game exposing 2 | ( Model 3 | , Msg(..) 4 | , State(..) 5 | , currentPlayer 6 | , currentTarget 7 | , initial 8 | , subscriptions 9 | , update 10 | , view 11 | ) 12 | 13 | import Acceleration 14 | import Angle exposing (Angle) 15 | import Axis3d exposing (Axis3d) 16 | import Ball 17 | import Bodies exposing (Id(..)) 18 | import Browser.Events 19 | import Camera exposing (Camera, ScreenCoordinates) 20 | import Color exposing (Color) 21 | import Cue 22 | import Dict exposing (Dict) 23 | import Direction3d 24 | import Duration 25 | import EightBall exposing (Player, Pool, ShotEvent) 26 | import Force 27 | import Frame3d 28 | import Html exposing (Html) 29 | import Html.Attributes 30 | import Html.Events 31 | import Illuminance 32 | import Json.Decode 33 | import Length exposing (Meters) 34 | import List 35 | import LuminousFlux 36 | import Physics.Body as Body exposing (Body) 37 | import Physics.Contact as Contact 38 | import Physics.Coordinates exposing (WorldCoordinates) 39 | import Physics.World as World exposing (World) 40 | import Pixels exposing (Pixels) 41 | import Point2d exposing (Point2d) 42 | import Point3d exposing (Point3d) 43 | import Quantity 44 | import Rectangle2d exposing (Rectangle2d) 45 | import Rectangle3d exposing (Rectangle3d) 46 | import Scene3d exposing (Entity) 47 | import Scene3d.Light 48 | import Scene3d.Material as Material exposing (Texture) 49 | import Set exposing (Set) 50 | import SketchPlane3d 51 | import Speed 52 | import Table exposing (Table) 53 | import Time exposing (Posix) 54 | import Vector2d 55 | import Vector3d 56 | 57 | 58 | 59 | -- MODEL 60 | 61 | 62 | type alias Model = 63 | { time : Posix 64 | , world : World Id 65 | , state : State 66 | , camera : Camera 67 | , table : Table 68 | , orbiting : Maybe (Point2d Pixels ScreenCoordinates) 69 | } 70 | 71 | 72 | type State 73 | = PlacingBall BallInHand PoolWithBallInHand 74 | | Shooting AimingCue Shot (Pool EightBall.AwaitingPlayerShot) 75 | | Simulating (List ( Posix, ShotEvent )) (Pool EightBall.AwaitingPlayerShot) 76 | | GameOver Player (Pool EightBall.AwaitingStart) 77 | 78 | 79 | type BallInHand 80 | = OnTable CanPlace (Point3d Meters WorldCoordinates) 81 | | OutsideOfTable 82 | 83 | 84 | type CanPlace 85 | = CanPlace 86 | | CannotPlace 87 | 88 | 89 | type PoolWithBallInHand 90 | = BehindHeadString (Pool EightBall.AwaitingPlaceBallBehindHeadstring) 91 | | Anywhere (Pool EightBall.AwaitingPlaceBallInHand) 92 | 93 | 94 | type AimingCue 95 | = TargetingCueBall (Maybe HitTarget) 96 | | ElevatingCue (Point2d Pixels ScreenCoordinates) 97 | 98 | 99 | type alias Shot = 100 | { cueElevation : Angle 101 | , shootPressedAt : Maybe Posix 102 | , hitTarget : HitTarget 103 | } 104 | 105 | 106 | {-| Polar coordinates of the hit point on the surface of the cue ball 107 | -} 108 | type alias HitTarget = 109 | { relativeAzimuth : Angle -- relative to the camera azimuth 110 | , elevation : Angle 111 | } 112 | 113 | 114 | initialShot : Shot 115 | initialShot = 116 | { cueElevation = Angle.degrees 5 117 | , shootPressedAt = Nothing 118 | , hitTarget = HitTarget (Angle.degrees 0) (Angle.degrees 0) -- aim at the center by default 119 | } 120 | 121 | 122 | initialState : Posix -> Pool EightBall.AwaitingRack -> State 123 | initialState time pool = 124 | PlacingBall OutsideOfTable (BehindHeadString (EightBall.rack time pool)) 125 | 126 | 127 | initial : Table -> Model 128 | initial table = 129 | let 130 | time = 131 | -- TODO: consider getting the initial time 132 | Time.millisToPosix 0 133 | in 134 | { world = initialWorld table 135 | , time = time 136 | , table = table 137 | , camera = Camera.initial 138 | , state = initialState time EightBall.start 139 | , orbiting = Nothing 140 | } 141 | 142 | 143 | initialWorld : Table -> World Id 144 | initialWorld table = 145 | World.empty 146 | |> World.withGravity 147 | (Acceleration.metersPerSecondSquared 9.80665) 148 | Direction3d.negativeZ 149 | |> (\w -> List.foldl World.add w table.bodies) 150 | |> (\w -> List.foldl World.add w (Ball.rack Table.footSpot)) 151 | 152 | 153 | 154 | -- UPDATE 155 | 156 | 157 | type Msg 158 | = Tick Posix 159 | | MouseWheel Float 160 | | MouseDown (Point2d Pixels ScreenCoordinates) 161 | | MouseMove (Point2d Pixels ScreenCoordinates) 162 | | MouseUp 163 | | ShootPressed 164 | | ShootReleased 165 | 166 | 167 | update : Rectangle2d Pixels ScreenCoordinates -> Msg -> Model -> Model 168 | update window msg oldModel = 169 | let 170 | model = 171 | preUpdate msg oldModel 172 | in 173 | case ( model.state, msg ) of 174 | -- Start by moving the ball above the table 175 | ( PlacingBall _ pool, MouseMove mousePosition ) -> 176 | let 177 | placingArea = 178 | case pool of 179 | Anywhere _ -> 180 | Table.areaBallInHand 181 | 182 | BehindHeadString _ -> 183 | Table.areaBehindTheHeadString 184 | 185 | mouseRay = 186 | Camera.ray model.camera window mousePosition 187 | 188 | newBallInHand = 189 | placeBallInHand mouseRay placingArea model.world 190 | in 191 | { model | state = PlacingBall newBallInHand pool } 192 | 193 | -- If the ball is on the table and doesn't overlap other balls then place it 194 | ( PlacingBall (OnTable CanPlace position) poolWithBallInHand, MouseDown _ ) -> 195 | let 196 | newPool = 197 | case poolWithBallInHand of 198 | BehindHeadString pool -> 199 | EightBall.placeBallBehindHeadstring model.time pool 200 | 201 | Anywhere pool -> 202 | EightBall.placeBallInHand model.time pool 203 | in 204 | { model 205 | | state = Shooting (TargetingCueBall Nothing) initialShot newPool 206 | , world = World.add (Body.moveTo position (Ball.body CueBall)) model.world 207 | , camera = Camera.focusOn position model.camera 208 | } 209 | 210 | -- If the ball overlaps - do nothing 211 | ( PlacingBall (OnTable CannotPlace _) _, MouseDown _ ) -> 212 | -- this case is for preventing orbiting 213 | model 214 | 215 | -- Moving mouse over the cue ball lets us pick the hit target 216 | ( Shooting (TargetingCueBall _) shot pool, MouseMove mousePosition ) -> 217 | let 218 | mouseRay = 219 | Camera.ray model.camera window mousePosition 220 | 221 | hitTarget = 222 | targetCueBall mouseRay model.world (Camera.azimuth model.camera) 223 | in 224 | { model | state = Shooting (TargetingCueBall hitTarget) shot pool } 225 | 226 | -- Mouse down on the hit target applies it to the next shot to be made 227 | ( Shooting (TargetingCueBall (Just hitTarget)) shot pool, MouseDown mousePosition ) -> 228 | let 229 | newShot = 230 | { shot | hitTarget = hitTarget } 231 | in 232 | { model | state = Shooting (ElevatingCue mousePosition) newShot pool } 233 | 234 | -- Change the cue elevation by moving the mouse with the button pressed 235 | ( Shooting (ElevatingCue originalPosition) shot pool, MouseMove mousePosition ) -> 236 | let 237 | newElevation = 238 | elevateCue originalPosition mousePosition model.camera shot.cueElevation 239 | 240 | newShot = 241 | { shot | cueElevation = newElevation } 242 | in 243 | { model | state = Shooting (ElevatingCue mousePosition) newShot pool } 244 | 245 | -- Releasing the mouse button stops elevating the cue 246 | ( Shooting (ElevatingCue _) shot pool, MouseUp ) -> 247 | { model | state = Shooting (TargetingCueBall Nothing) shot pool } 248 | 249 | -- Holding the shoot button down allows to select the force 250 | ( Shooting aimingCue shot pool, ShootPressed ) -> 251 | let 252 | axis = 253 | cueAxis (cueBallPosition model.world) (Camera.azimuth model.camera) shot 254 | in 255 | -- the message can be sent many times 256 | -- we need to check if the button isn't already pressed 257 | if Cue.canShoot model.world axis && shot.shootPressedAt == Nothing then 258 | let 259 | -- save the time the buttom was pressed 260 | newShot = 261 | { shot | shootPressedAt = Just model.time } 262 | in 263 | { model | state = Shooting aimingCue newShot pool } 264 | 265 | else 266 | model 267 | 268 | -- Releasing the button shoots the ball! 269 | ( Shooting aimingCue shot pool, ShootReleased ) -> 270 | let 271 | axis = 272 | cueAxis (cueBallPosition model.world) (Camera.azimuth model.camera) shot 273 | 274 | startTime = 275 | Maybe.withDefault model.time shot.shootPressedAt 276 | in 277 | if Cue.canShoot model.world axis then 278 | { model 279 | | state = Simulating [] pool 280 | , camera = Camera.zoomOut model.camera 281 | , world = shoot axis startTime model.time model.world 282 | } 283 | 284 | else 285 | { model | state = Shooting aimingCue { shot | shootPressedAt = Nothing } pool } 286 | 287 | -- Simulate the physics! 288 | ( Simulating events pool, Tick time ) -> 289 | case simulate time model.world events pool of 290 | -- Continue simulating on the next tick 291 | Continue ( newWorld, newEvents ) -> 292 | { model 293 | | world = newWorld 294 | , state = Simulating newEvents pool 295 | } 296 | 297 | -- Stop the simulation, decide what to do next! 298 | Stop (EightBall.IllegalBreak newPool) -> 299 | { model 300 | | world = initialWorld model.table -- Reset the table. 301 | , state = initialState time newPool 302 | , camera = Camera.focusOn Point3d.origin model.camera 303 | } 304 | 305 | Stop (EightBall.PlayersFault (EightBall.PlaceBallInHand newPool)) -> 306 | { model 307 | | world = World.keepIf (\b -> Body.data b /= CueBall) model.world 308 | , state = PlacingBall OutsideOfTable (Anywhere newPool) 309 | , camera = Camera.focusOn Point3d.origin model.camera 310 | } 311 | 312 | Stop (EightBall.PlayersFault (EightBall.SpotEightBall newPool)) -> 313 | { model 314 | | world = 315 | model.world 316 | |> World.keepIf (\b -> Body.data b /= CueBall) 317 | |> Ball.spot Table.footSpot EightBall.eightBall 318 | , state = PlacingBall OutsideOfTable (BehindHeadString (EightBall.spotEightBall time newPool)) 319 | , camera = Camera.focusOn Point3d.origin model.camera 320 | } 321 | 322 | Stop (EightBall.NextShot newPool) -> 323 | let 324 | newFocalPoint = 325 | cueBallPosition model.world 326 | in 327 | { model 328 | | state = Shooting (TargetingCueBall Nothing) initialShot newPool 329 | , camera = Camera.focusOn newFocalPoint model.camera 330 | } 331 | 332 | Stop (EightBall.GameOver newPool { winner }) -> 333 | { model 334 | | state = GameOver winner newPool 335 | , camera = Camera.focusOn Point3d.origin model.camera 336 | } 337 | 338 | -- this case is here, to let the cases above prevent orbiting 339 | -- by intercepting the MouseDown event 340 | ( _, MouseDown mousePosition ) -> 341 | { model | orbiting = Just mousePosition } 342 | 343 | _ -> 344 | model 345 | 346 | 347 | {-| Perform the updates that are always necessary no matter the game state 348 | -} 349 | preUpdate : Msg -> Model -> Model 350 | preUpdate msg model = 351 | case msg of 352 | -- advance the time 353 | Tick time -> 354 | { model 355 | | time = time 356 | , camera = Camera.animate time model.camera 357 | } 358 | 359 | -- continue orbiting if already started 360 | MouseMove mousePosition -> 361 | case model.orbiting of 362 | Just originalPosition -> 363 | -- update the camera orientation 364 | -- note that changing the azimuth impacts the cue axis 365 | let 366 | newCamera = 367 | Camera.mouseOrbiting originalPosition mousePosition model.camera 368 | in 369 | { model | camera = newCamera, orbiting = Just mousePosition } 370 | 371 | Nothing -> 372 | model 373 | 374 | -- always stop orbiting on mouse up 375 | MouseUp -> 376 | { model | orbiting = Nothing } 377 | 378 | MouseWheel deltaY -> 379 | { model | camera = Camera.mouseWheelZoom deltaY model.camera } 380 | 381 | _ -> 382 | model 383 | 384 | 385 | 386 | -- Placing ball in hand 387 | 388 | 389 | placeBallInHand : Axis3d Meters WorldCoordinates -> Rectangle3d Meters WorldCoordinates -> World Id -> BallInHand 390 | placeBallInHand mouseRay spawnArea world = 391 | let 392 | -- raise the interection rectangles to vertically align with the center of the ball 393 | elevatedWholeTableArea = 394 | Table.areaBallInHand 395 | |> Rectangle3d.translateIn Direction3d.z Ball.radius 396 | 397 | elevatedSpawnArea = 398 | spawnArea 399 | |> Rectangle3d.translateIn Direction3d.z Ball.radius 400 | in 401 | case Axis3d.intersectionWithRectangle elevatedWholeTableArea mouseRay of 402 | Just position -> 403 | case Axis3d.intersectionWithRectangle elevatedSpawnArea mouseRay of 404 | Just _ -> 405 | placeBallInHandHelp (World.bodies world) position 406 | 407 | Nothing -> 408 | OnTable CannotPlace position 409 | 410 | _ -> 411 | OutsideOfTable 412 | 413 | 414 | {-| Check if overlaps with any of the numbered balls 415 | -} 416 | placeBallInHandHelp : List (Body Id) -> Point3d Meters WorldCoordinates -> BallInHand 417 | placeBallInHandHelp bodies position = 418 | case bodies of 419 | body :: remaining -> 420 | case Body.data body of 421 | Numbered _ -> 422 | if 423 | Body.originPoint body 424 | |> Point3d.distanceFrom position 425 | |> Quantity.lessThan (Quantity.twice Ball.radius) 426 | then 427 | OnTable CannotPlace position 428 | 429 | else 430 | placeBallInHandHelp remaining position 431 | 432 | _ -> 433 | placeBallInHandHelp remaining position 434 | 435 | [] -> 436 | OnTable CanPlace position 437 | 438 | 439 | 440 | -- Aiming cue 441 | 442 | 443 | {-| Pick a point on the cue ball to hit 444 | -} 445 | targetCueBall : Axis3d Meters WorldCoordinates -> World Id -> Angle -> Maybe HitTarget 446 | targetCueBall mouseRay world azimuth = 447 | case World.raycast mouseRay world of 448 | Just { body, normal } -> 449 | let 450 | frame = 451 | Body.frame body 452 | 453 | hitNormal = 454 | Direction3d.placeIn frame normal 455 | 456 | hitAzimuth = 457 | Direction3d.azimuthIn SketchPlane3d.xy hitNormal 458 | 459 | hitElevation = 460 | Direction3d.elevationFrom SketchPlane3d.xy hitNormal 461 | 462 | hitRelativeAzimuth = 463 | hitAzimuth 464 | |> Quantity.minus azimuth 465 | |> Angle.normalize 466 | 467 | hoveringFrontHemisphere = 468 | -- Prevent from hoveing the back hemisphere when looking from the top 469 | Quantity.lessThan (Angle.degrees 90) (Quantity.abs hitRelativeAzimuth) 470 | in 471 | if Body.data body == CueBall && hoveringFrontHemisphere then 472 | Just 473 | { relativeAzimuth = hitRelativeAzimuth 474 | , elevation = hitElevation 475 | } 476 | 477 | else 478 | Nothing 479 | 480 | Nothing -> 481 | Nothing 482 | 483 | 484 | {-| Calculate the new cue elevation using the exising elevation and the mouse y offset. 485 | 486 | The precision depends on the zoom level. 487 | 488 | -} 489 | elevateCue : Point2d Pixels ScreenCoordinates -> Point2d Pixels ScreenCoordinates -> Camera -> Angle -> Angle 490 | elevateCue originalPosition newPosition camera elevation = 491 | let 492 | radiansInPixels = 493 | Camera.orbitingPrecision camera 494 | 495 | deltaElevation = 496 | Vector2d.from originalPosition newPosition 497 | |> Vector2d.yComponent 498 | |> Quantity.at radiansInPixels 499 | in 500 | elevation 501 | |> Quantity.minus deltaElevation 502 | |> Quantity.clamp (Angle.degrees 0) (Angle.degrees 90) 503 | 504 | 505 | 506 | -- Shooting 507 | 508 | 509 | {-| Get the position of the cue ball from the world 510 | -} 511 | cueBallPosition : World Id -> Point3d Meters WorldCoordinates 512 | cueBallPosition world = 513 | world 514 | |> World.keepIf (\b -> Body.data b == CueBall) 515 | |> World.bodies 516 | |> List.head 517 | |> Maybe.map Body.originPoint 518 | |> Maybe.withDefault Point3d.origin 519 | 520 | 521 | {-| Axis from the hit point on the cue ball along the cue 522 | -} 523 | cueAxis : Point3d Meters WorldCoordinates -> Angle -> Shot -> Axis3d Meters WorldCoordinates 524 | cueAxis ballPosition cameraAzimuth { hitTarget, cueElevation } = 525 | let 526 | hitAzimuth = 527 | cameraAzimuth 528 | |> Quantity.plus hitTarget.relativeAzimuth 529 | 530 | pointDirection = 531 | Direction3d.xyZ hitAzimuth hitTarget.elevation 532 | 533 | pointOnCueBall = 534 | Point3d.translateIn pointDirection Ball.radius ballPosition 535 | 536 | axisDirection = 537 | Direction3d.xyZ cameraAzimuth cueElevation 538 | in 539 | Axis3d.through pointOnCueBall axisDirection 540 | 541 | 542 | {-| Apply impulse to the cue ball depending on the shooting strength. 543 | The strength is calculated based on how long the spacebar has been pressed. 544 | -} 545 | shoot : Axis3d Meters WorldCoordinates -> Posix -> Posix -> World Id -> World Id 546 | shoot axis startTime endTime = 547 | World.update 548 | (\body -> 549 | if Body.data body == CueBall then 550 | let 551 | shootingAxis = 552 | Axis3d.reverse axis 553 | 554 | force = 555 | Quantity.interpolateFrom 556 | (Force.newtons 10) 557 | (Force.newtons 60) 558 | (shootingStrength startTime endTime) 559 | in 560 | Body.applyImpulse 561 | (Quantity.times (Duration.milliseconds 16) force) 562 | (Axis3d.direction shootingAxis) 563 | (Axis3d.originPoint shootingAxis) 564 | body 565 | 566 | else 567 | body 568 | ) 569 | 570 | 571 | {-| Returns a value from 0 to 1 572 | -} 573 | shootingStrength : Posix -> Posix -> Float 574 | shootingStrength startTime endTime = 575 | let 576 | duration = 577 | toFloat (Time.posixToMillis endTime - Time.posixToMillis startTime) 578 | in 579 | -(cos (duration / 2000 * pi) / 2) + 0.5 580 | 581 | 582 | 583 | -- Simulation 584 | 585 | 586 | type SimulatedWorld 587 | = Continue ( World Id, List ( Posix, ShotEvent ) ) 588 | | Stop EightBall.WhatHappened 589 | 590 | 591 | simulate : Posix -> World Id -> List ( Posix, ShotEvent ) -> Pool EightBall.AwaitingPlayerShot -> SimulatedWorld 592 | simulate time world events pool = 593 | let 594 | ballsStoppedMoving = 595 | List.all 596 | (\body -> 597 | Body.velocity body 598 | |> Vector3d.length 599 | |> Quantity.lessThan (Speed.metersPerSecond 0.0005) 600 | ) 601 | (World.bodies world) 602 | in 603 | if ballsStoppedMoving then 604 | Stop (EightBall.playerShot (List.reverse events) pool) 605 | 606 | else 607 | Continue (simulateWithEvents 2 time world events) 608 | 609 | 610 | {-| Simulate multiple frames and collect the game events 611 | -} 612 | simulateWithEvents : Int -> Posix -> World Id -> List ( Posix, ShotEvent ) -> ( World Id, List ( Posix, ShotEvent ) ) 613 | simulateWithEvents frame time world events = 614 | if frame > 0 then 615 | let 616 | frozen = 617 | -- Frozen balls from before the simulation 618 | frozenBalls world 619 | 620 | frozenCue = 621 | -- Frozen cue ball from before the simulation 622 | frozenCueBall world 623 | 624 | simulatedWorld = 625 | -- Simulate at shorter interval to prevent tunneling 626 | World.simulate (Duration.seconds (1 / 120)) world 627 | 628 | contacts = 629 | World.contacts simulatedWorld 630 | 631 | ( newEvents, newWorld ) = 632 | List.foldl 633 | (\contact ( currentEvents, currentWorld ) -> 634 | let 635 | ( b1, b2 ) = 636 | Contact.bodies contact 637 | in 638 | case ( Body.data b1, Body.data b2 ) of 639 | ( Numbered ball, Pocket ) -> 640 | ( EightBall.ballFellInPocket time ball :: currentEvents 641 | , World.keepIf (\b -> Body.data b /= Numbered ball) currentWorld 642 | ) 643 | 644 | ( Pocket, Numbered ball ) -> 645 | ( EightBall.ballFellInPocket time ball :: currentEvents 646 | , World.keepIf (\b -> Body.data b /= Numbered ball) currentWorld 647 | ) 648 | 649 | ( Numbered ball, Floor ) -> 650 | ( EightBall.ballOffTable time ball :: currentEvents 651 | , World.keepIf (\b -> Body.data b /= Numbered ball) currentWorld 652 | ) 653 | 654 | ( Floor, Numbered ball ) -> 655 | ( EightBall.ballOffTable time ball :: currentEvents 656 | , World.keepIf (\b -> Body.data b /= Numbered ball) currentWorld 657 | ) 658 | 659 | ( CueBall, Floor ) -> 660 | ( EightBall.scratch time :: currentEvents 661 | , World.keepIf (\b -> Body.data b /= CueBall) currentWorld 662 | ) 663 | 664 | ( Floor, CueBall ) -> 665 | ( EightBall.scratch time :: currentEvents 666 | , World.keepIf (\b -> Body.data b /= CueBall) currentWorld 667 | ) 668 | 669 | ( Pocket, CueBall ) -> 670 | ( EightBall.scratch time :: currentEvents 671 | , World.keepIf (\b -> Body.data b /= CueBall) currentWorld 672 | ) 673 | 674 | ( CueBall, Numbered ball ) -> 675 | ( EightBall.cueHitBall time ball :: currentEvents, currentWorld ) 676 | 677 | ( Numbered ball, CueBall ) -> 678 | ( EightBall.cueHitBall time ball :: currentEvents, currentWorld ) 679 | 680 | --(Numbered _, Numbered _) -> 681 | -- (EightBall.ballsCollided time, currentWorld) 682 | ( Cushion, Numbered ball ) -> 683 | if not (Set.member (EightBall.ballNumber ball) frozen) then 684 | ( EightBall.ballHitWall time ball :: currentEvents, currentWorld ) 685 | 686 | else 687 | ( currentEvents, currentWorld ) 688 | 689 | ( Numbered ball, Cushion ) -> 690 | if not (Set.member (EightBall.ballNumber ball) frozen) then 691 | ( EightBall.ballHitWall time ball :: currentEvents, currentWorld ) 692 | 693 | else 694 | ( currentEvents, currentWorld ) 695 | 696 | ( Cushion, CueBall ) -> 697 | if not frozenCue then 698 | ( EightBall.cueHitWall time :: currentEvents, currentWorld ) 699 | 700 | else 701 | ( currentEvents, currentWorld ) 702 | 703 | ( CueBall, Cushion ) -> 704 | if not frozenCue then 705 | ( EightBall.cueHitWall time :: currentEvents, currentWorld ) 706 | 707 | else 708 | ( currentEvents, currentWorld ) 709 | 710 | _ -> 711 | ( currentEvents, currentWorld ) 712 | ) 713 | ( events, simulatedWorld ) 714 | contacts 715 | in 716 | simulateWithEvents (frame - 1) time newWorld newEvents 717 | 718 | else 719 | ( world, events ) 720 | 721 | 722 | {-| Find the frozen balls, that are touching the walls 723 | -} 724 | frozenBalls : World Id -> Set Int 725 | frozenBalls world = 726 | List.foldl 727 | (\contact frozen -> 728 | let 729 | ( b1, b2 ) = 730 | Contact.bodies contact 731 | in 732 | case ( Body.data b1, Body.data b2 ) of 733 | ( Cushion, Numbered ball ) -> 734 | Set.insert (EightBall.ballNumber ball) frozen 735 | 736 | ( Numbered ball, Cushion ) -> 737 | Set.insert (EightBall.ballNumber ball) frozen 738 | 739 | _ -> 740 | frozen 741 | ) 742 | Set.empty 743 | (World.contacts world) 744 | 745 | 746 | {-| Find out if the cue ball is touching the wall. 747 | -} 748 | frozenCueBall : World Id -> Bool 749 | frozenCueBall world = 750 | List.any 751 | (\contact -> 752 | let 753 | ( b1, b2 ) = 754 | Contact.bodies contact 755 | in 756 | case ( Body.data b1, Body.data b2 ) of 757 | ( Cushion, CueBall ) -> 758 | True 759 | 760 | ( CueBall, Cushion ) -> 761 | True 762 | 763 | _ -> 764 | False 765 | ) 766 | (World.contacts world) 767 | 768 | 769 | 770 | -- VIEW 771 | 772 | 773 | view : Dict Int (Texture Color) -> Texture Float -> Table -> Rectangle2d Pixels ScreenCoordinates -> Model -> Html Msg 774 | view ballTextures roughnessTexture table window model = 775 | let 776 | sunlight = 777 | Scene3d.Light.directional (Scene3d.Light.castsShadows True) 778 | { direction = Direction3d.xyZ (Angle.degrees 135) (Angle.degrees -60) 779 | , intensity = Illuminance.lux 2000 780 | , chromaticity = Scene3d.Light.daylight 781 | } 782 | 783 | lamp n = 784 | Scene3d.Light.point Scene3d.Light.neverCastsShadows 785 | { position = Point3d.xyz (Length.meters ((n - 2) * 0.8)) Quantity.zero (Length.meters 0.4) 786 | , chromaticity = Scene3d.Light.fluorescent 787 | , intensity = LuminousFlux.lumens 2500 788 | } 789 | 790 | environmentalLighting = 791 | Scene3d.Light.soft 792 | { upDirection = Direction3d.positiveZ 793 | , chromaticity = Scene3d.Light.fluorescent 794 | , intensityAbove = Illuminance.lux 400 795 | , intensityBelow = Illuminance.lux 300 796 | } 797 | 798 | camera3d = 799 | Camera.camera3d model.camera 800 | 801 | clipDepth = 802 | Length.meters 0.1 803 | 804 | inactiveColor = 805 | Color.rgb255 130 130 130 806 | 807 | entities = 808 | List.map 809 | (bodyToEntity roughnessTexture ballTextures table) 810 | (World.bodies model.world) 811 | 812 | dimensions = 813 | window 814 | |> Rectangle2d.dimensions 815 | |> Tuple.mapBoth Quantity.round Quantity.round 816 | 817 | entitiesWithUI = 818 | case model.state of 819 | PlacingBall (OnTable spawn position) poolWithBallInHand -> 820 | let 821 | highlightArea = 822 | case poolWithBallInHand of 823 | BehindHeadString _ -> 824 | Table.areaBehindTheHeadStringEntity 825 | 826 | Anywhere _ -> 827 | Scene3d.nothing 828 | 829 | baseColor = 830 | if spawn == CanPlace then 831 | Material.constant Color.white 832 | 833 | else 834 | Material.constant inactiveColor 835 | 836 | cueBall = 837 | Ball.entity baseColor roughnessTexture 838 | |> Scene3d.placeIn (Frame3d.atPoint position) 839 | in 840 | cueBall :: highlightArea :: entities 841 | 842 | PlacingBall OutsideOfTable (BehindHeadString _) -> 843 | Table.areaBehindTheHeadStringEntity :: entities 844 | 845 | Shooting _ cue _ -> 846 | let 847 | axis = 848 | cueAxis (cueBallPosition model.world) (Camera.azimuth model.camera) cue 849 | 850 | color = 851 | if Cue.canShoot model.world axis then 852 | Color.white 853 | 854 | else 855 | inactiveColor 856 | in 857 | Cue.entity camera3d clipDepth color axis :: entities 858 | 859 | _ -> 860 | entities 861 | in 862 | Html.div 863 | [ Html.Attributes.style "position" "absolute" 864 | , Html.Attributes.style "left" "0" 865 | , Html.Attributes.style "top" "0" 866 | , Html.Attributes.style "cursor" (currentCursor model.state) 867 | , Html.Events.preventDefaultOn "wheel" 868 | (Json.Decode.map 869 | (\deltaY -> ( MouseWheel deltaY, True )) 870 | (Json.Decode.field "deltaY" Json.Decode.float) 871 | ) 872 | ] 873 | [ Scene3d.custom 874 | { dimensions = dimensions 875 | , antialiasing = Scene3d.multisampling 876 | , camera = camera3d 877 | , entities = entitiesWithUI 878 | , lights = Scene3d.fiveLights environmentalLighting sunlight (lamp 1) (lamp 2) (lamp 3) 879 | , exposure = Scene3d.exposureValue 10 880 | , whiteBalance = Scene3d.Light.daylight 881 | , clipDepth = clipDepth 882 | , background = Scene3d.backgroundColor Color.black 883 | , toneMapping = Scene3d.noToneMapping 884 | } 885 | , viewShootingStrength window model 886 | ] 887 | 888 | 889 | bodyToEntity : Material.Texture Float -> Dict Int (Material.Texture Color) -> Table -> Body Id -> Entity WorldCoordinates 890 | bodyToEntity roughnessTexture ballTextures table body = 891 | Scene3d.placeIn (Body.frame body) <| 892 | case Body.data body of 893 | Numbered ball -> 894 | let 895 | baseColor = 896 | Dict.get (EightBall.ballNumber ball) ballTextures 897 | |> Maybe.withDefault (Material.constant Color.black) 898 | in 899 | Ball.entity baseColor roughnessTexture 900 | 901 | CueBall -> 902 | Ball.entity (Material.constant Color.white) roughnessTexture 903 | 904 | Bodies.Table -> 905 | table.entity 906 | 907 | _ -> 908 | Scene3d.nothing 909 | 910 | 911 | viewShootingStrength : Rectangle2d Pixels ScreenCoordinates -> Model -> Html Msg 912 | viewShootingStrength window { state, time } = 913 | case state of 914 | Shooting _ { shootPressedAt } _ -> 915 | case shootPressedAt of 916 | Nothing -> 917 | Html.text "" 918 | 919 | Just startTime -> 920 | let 921 | progressHeight = 922 | shootingStrength startTime time * (barHeight - 4) 923 | 924 | height = 925 | window 926 | |> Rectangle2d.dimensions 927 | |> Tuple.second 928 | |> Pixels.inPixels 929 | 930 | barHeight = 931 | height * 0.6 932 | 933 | barBottom = 934 | (height - barHeight) / 2 935 | in 936 | Html.div [] 937 | [ Html.div 938 | [ Html.Attributes.style "position" "absolute" 939 | , Html.Attributes.style "right" "50px" 940 | , Html.Attributes.style "bottom" (String.fromFloat barBottom ++ "px") 941 | , Html.Attributes.style "width" "40px" 942 | , Html.Attributes.style "height" (String.fromFloat barHeight ++ "px") 943 | , Html.Attributes.style "border" "2px solid #fff" 944 | , Html.Attributes.style "border-radius" "10px" 945 | ] 946 | [] 947 | , Html.div 948 | [ Html.Attributes.style "position" "absolute" 949 | , Html.Attributes.style "right" "54px" 950 | , Html.Attributes.style "bottom" (String.fromFloat (barBottom + 4) ++ "px") 951 | , Html.Attributes.style "width" "36px" 952 | , Html.Attributes.style "background" "#fff" 953 | , Html.Attributes.style "border-radius" "6px" 954 | , Html.Attributes.style "height" (String.fromFloat progressHeight ++ "px") 955 | ] 956 | [] 957 | ] 958 | 959 | _ -> 960 | Html.text "" 961 | 962 | 963 | currentCursor : State -> String 964 | currentCursor state = 965 | case state of 966 | PlacingBall (OnTable _ _) _ -> 967 | "none" 968 | 969 | Shooting (TargetingCueBall (Just _)) _ _ -> 970 | "pointer" 971 | 972 | Shooting (ElevatingCue _) _ _ -> 973 | "ns-resize" 974 | 975 | Simulating _ _ -> 976 | "wait" 977 | 978 | _ -> 979 | "default" 980 | 981 | 982 | currentPlayer : State -> String 983 | currentPlayer state = 984 | let 985 | currentPlayer_ = 986 | case state of 987 | PlacingBall _ (BehindHeadString pool) -> 988 | EightBall.currentPlayer pool 989 | 990 | Shooting _ _ pool -> 991 | EightBall.currentPlayer pool 992 | 993 | Simulating _ pool -> 994 | EightBall.currentPlayer pool 995 | 996 | PlacingBall _ (Anywhere pool) -> 997 | EightBall.currentPlayer pool 998 | 999 | GameOver winner _ -> 1000 | winner 1001 | in 1002 | case currentPlayer_ of 1003 | EightBall.Player1 -> 1004 | "Player 1" 1005 | 1006 | EightBall.Player2 -> 1007 | "Player 2" 1008 | 1009 | 1010 | currentTarget : State -> String 1011 | currentTarget state = 1012 | let 1013 | currentTarget_ = 1014 | case state of 1015 | PlacingBall _ (BehindHeadString pool) -> 1016 | EightBall.currentTarget pool 1017 | 1018 | Shooting _ _ pool -> 1019 | EightBall.currentTarget pool 1020 | 1021 | Simulating _ pool -> 1022 | EightBall.currentTarget pool 1023 | 1024 | PlacingBall _ (Anywhere pool) -> 1025 | EightBall.currentTarget pool 1026 | 1027 | GameOver _ pool -> 1028 | EightBall.currentTarget pool 1029 | in 1030 | case currentTarget_ of 1031 | EightBall.OpenTable -> 1032 | "Open Table" 1033 | 1034 | EightBall.Solids -> 1035 | "Solids" 1036 | 1037 | EightBall.Stripes -> 1038 | "Stripes" 1039 | 1040 | EightBall.EightBall -> 1041 | "8-Ball" 1042 | 1043 | 1044 | 1045 | -- SUBSCRIPTIONS 1046 | 1047 | 1048 | subscriptions : Model -> Sub Msg 1049 | subscriptions _ = 1050 | Sub.batch 1051 | [ Browser.Events.onKeyDown (decodeKey ShootPressed) 1052 | , Browser.Events.onKeyUp (decodeKey ShootReleased) 1053 | , Browser.Events.onAnimationFrame Tick 1054 | , Browser.Events.onMouseDown (decodeMouse MouseDown) 1055 | , Browser.Events.onMouseMove (decodeMouse MouseMove) 1056 | , Browser.Events.onMouseUp (Json.Decode.succeed MouseUp) 1057 | ] 1058 | 1059 | 1060 | decodeMouse : (Point2d Pixels ScreenCoordinates -> Msg) -> Json.Decode.Decoder Msg 1061 | decodeMouse msg = 1062 | Json.Decode.map2 (\x y -> msg (Point2d.pixels x y)) 1063 | (Json.Decode.field "pageX" Json.Decode.float) 1064 | (Json.Decode.field "pageY" Json.Decode.float) 1065 | 1066 | 1067 | decodeKey : Msg -> Json.Decode.Decoder Msg 1068 | decodeKey msg = 1069 | Json.Decode.andThen 1070 | (\key -> 1071 | if key == " " then 1072 | Json.Decode.succeed msg 1073 | 1074 | else 1075 | Json.Decode.fail "" 1076 | ) 1077 | (Json.Decode.field "key" Json.Decode.string) 1078 | -------------------------------------------------------------------------------- /src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (main) 2 | 3 | import Browser 4 | import Browser.Dom 5 | import Browser.Events 6 | import Camera exposing (ScreenCoordinates) 7 | import Color exposing (Color) 8 | import Dict exposing (Dict) 9 | import Game 10 | import Html exposing (Html) 11 | import Html.Attributes 12 | import Html.Events 13 | import Json.Decode 14 | import Json.Encode 15 | import Pixels exposing (Pixels) 16 | import Rectangle2d exposing (Rectangle2d) 17 | import Scene3d.Material as Material 18 | import Table exposing (Table) 19 | import Task 20 | import WebGL.Texture exposing (defaultOptions) 21 | 22 | 23 | type Model 24 | = Loading LoadingModel 25 | | Loaded LoadedModel 26 | | Failed String 27 | 28 | 29 | type Msg 30 | = WindowResized (Rectangle2d Pixels ScreenCoordinates) 31 | | GotBallTexture Int (Result WebGL.Texture.Error (Material.Texture Color)) 32 | | GotBallRoughnessTexture (Result WebGL.Texture.Error (Material.Texture Float)) 33 | | GotTable (Result String Table) 34 | | RunningMsg Game.Msg 35 | | StartNewGameButtonClicked 36 | 37 | 38 | type alias LoadingModel = 39 | { ballTextures : Dict Int (Material.Texture Color) 40 | , roughnessTexture : Maybe (Material.Texture Float) 41 | , table : Maybe Table 42 | , window : Maybe (Rectangle2d Pixels ScreenCoordinates) 43 | , assetsPath : String 44 | } 45 | 46 | 47 | type alias LoadedModel = 48 | { ballTextures : Dict Int (Material.Texture Color) 49 | , roughnessTexture : Material.Texture Float 50 | , table : Table 51 | , window : Rectangle2d Pixels ScreenCoordinates 52 | , assetsPath : String 53 | , game : Game.Model 54 | } 55 | 56 | 57 | main : Program Json.Encode.Value Model Msg 58 | main = 59 | Browser.element 60 | { init = init 61 | , update = \msg model -> ( update msg model, Cmd.none ) 62 | , subscriptions = 63 | \model -> 64 | Sub.batch 65 | [ Browser.Events.onResize 66 | (\width height -> 67 | WindowResized 68 | (Rectangle2d.with 69 | { x1 = Pixels.pixels 0 70 | , y1 = Pixels.float (toFloat height) 71 | , x2 = Pixels.float (toFloat width) 72 | , y2 = Pixels.pixels 0 73 | } 74 | ) 75 | ) 76 | , case model of 77 | Loaded m -> 78 | Sub.map RunningMsg (Game.subscriptions m.game) 79 | 80 | _ -> 81 | Sub.none 82 | ] 83 | , view = view 84 | } 85 | 86 | 87 | type alias Flags = 88 | { assetsPath : Maybe String 89 | } 90 | 91 | 92 | flagsDecoder : Json.Decode.Decoder Flags 93 | flagsDecoder = 94 | Json.Decode.map Flags 95 | assetsPathDecoder 96 | 97 | 98 | assetsPathDecoder : Json.Decode.Decoder (Maybe String) 99 | assetsPathDecoder = 100 | Json.Decode.maybe <| 101 | Json.Decode.field "assetsPath" Json.Decode.string 102 | 103 | 104 | init : Json.Encode.Value -> ( Model, Cmd Msg ) 105 | init unsafeFlags = 106 | let 107 | flags = 108 | unsafeFlags 109 | |> Json.Decode.decodeValue flagsDecoder 110 | |> Result.withDefault { assetsPath = Nothing } 111 | 112 | assetsPath = 113 | Maybe.withDefault "/public/" flags.assetsPath 114 | in 115 | ( Loading 116 | { window = Nothing 117 | , roughnessTexture = Nothing 118 | , table = Nothing 119 | , ballTextures = Dict.empty 120 | , assetsPath = assetsPath 121 | } 122 | , Cmd.batch 123 | [ Cmd.batch 124 | (List.map 125 | (\number -> 126 | Material.loadWith 127 | { defaultOptions | minify = WebGL.Texture.linear } 128 | (assetsPath ++ "img/balls/" ++ String.fromInt number ++ ".png") 129 | |> Task.attempt (GotBallTexture number) 130 | ) 131 | (List.range 1 15) 132 | ) 133 | , Task.attempt GotBallRoughnessTexture (Material.load (assetsPath ++ "img/balls/roughness.jpg")) 134 | , Task.attempt GotTable 135 | (Table.load 136 | { colorTexture = assetsPath ++ "img/table/color.png" 137 | , roughnessTexture = assetsPath ++ "img/table/roughness.png" 138 | , metallicTexture = assetsPath ++ "img/table/metallic.png" 139 | , mesh = assetsPath ++ "/billiard-table.obj.txt" 140 | } 141 | ) 142 | , Task.perform 143 | (\{ viewport } -> 144 | WindowResized 145 | (Rectangle2d.with 146 | { x1 = Pixels.pixels 0 147 | , y1 = Pixels.pixels viewport.height 148 | , x2 = Pixels.pixels viewport.width 149 | , y2 = Pixels.pixels 0 150 | } 151 | ) 152 | ) 153 | Browser.Dom.getViewport 154 | ] 155 | ) 156 | 157 | 158 | view : Model -> Html Msg 159 | view model = 160 | case model of 161 | Loaded { game, roughnessTexture, table, ballTextures, window, assetsPath } -> 162 | Html.div 163 | [] 164 | [ Html.map RunningMsg 165 | (Game.view ballTextures roughnessTexture table window game) 166 | , viewCurrentStatus game assetsPath 167 | ] 168 | 169 | Loading _ -> 170 | Html.text "Loading..." 171 | 172 | Failed error -> 173 | Html.text error 174 | 175 | 176 | 177 | -- View Current Status 178 | 179 | 180 | viewCurrentStatus : Game.Model -> String -> Html Msg 181 | viewCurrentStatus gameModel assetsPath = 182 | Html.div 183 | [ Html.Attributes.style "position" "absolute" 184 | , Html.Attributes.style "bottom" "0" 185 | , Html.Attributes.style "left" "50%" -- To center absolute content. 186 | ] 187 | [ Html.node "style" 188 | [] 189 | [ Html.text (fontStyle assetsPath) ] 190 | , case gameModel.state of 191 | Game.GameOver _ _ -> 192 | viewGameOver gameModel 193 | 194 | _ -> 195 | Html.div statusStyle 196 | [ Html.text (Game.currentPlayer gameModel.state) 197 | , Html.text " - " 198 | , Html.text (Game.currentTarget gameModel.state) 199 | ] 200 | ] 201 | 202 | 203 | statusStyle : List (Html.Attribute Msg) 204 | statusStyle = 205 | [ -- To center within absolute container. 206 | Html.Attributes.style "position" "relative" 207 | , Html.Attributes.style "left" "-50%" 208 | , Html.Attributes.style "text-align" "center" 209 | 210 | -- Color 211 | , Html.Attributes.style "background-color" "#121517" 212 | , Html.Attributes.style "color" "#eef" 213 | 214 | -- Border/Edges 215 | , Html.Attributes.style "border-radius" "10px 10px 0 0" 216 | , Html.Attributes.style "box-shadow" "0 4px 12px 0 rgba(0, 0, 0, 0.15)" 217 | 218 | -- Font 219 | , Html.Attributes.style "font-family" "Teko" 220 | , Html.Attributes.style "font-size" "40px" 221 | 222 | -- Other 223 | , Html.Attributes.style "opacity" "0.9" 224 | , Html.Attributes.style "padding" "15px 25px 10px 25px" 225 | ] 226 | 227 | 228 | viewGameOver : Game.Model -> Html Msg 229 | viewGameOver gameModel = 230 | Html.button 231 | (statusStyle 232 | ++ [ Html.Attributes.style "border" "none" 233 | , Html.Attributes.style "cursor" "pointer" 234 | , Html.Events.onClick StartNewGameButtonClicked 235 | ] 236 | ) 237 | [ Html.text (Game.currentPlayer gameModel.state) 238 | , Html.text " won!" 239 | , Html.div 240 | [ Html.Attributes.style "color" "rgba(86, 186, 79, 0.7)" 241 | ] 242 | [ Html.text "Play again?" 243 | ] 244 | ] 245 | 246 | 247 | fontStyle : String -> String 248 | fontStyle path = 249 | """ 250 | @font-face { 251 | font-family: 'Teko'; 252 | src: url('""" ++ path ++ """font/Teko-Medium.woff2') format('woff2'), 253 | url('""" ++ path ++ """font/Teko-Medium.woff') format('woff'); 254 | font-weight: 500; 255 | font-style: normal; 256 | font-display: block; 257 | } 258 | """ 259 | 260 | 261 | 262 | -- Update 263 | 264 | 265 | update : Msg -> Model -> Model 266 | update msg model = 267 | case ( msg, model ) of 268 | ( WindowResized window, Loading loadingModel ) -> 269 | loadComplete { loadingModel | window = Just window } 270 | 271 | ( WindowResized window, Loaded loadedModel ) -> 272 | Loaded { loadedModel | window = window } 273 | 274 | ( GotBallTexture n maybeTexture, Loading loadingModel ) -> 275 | case maybeTexture of 276 | Ok texture -> 277 | loadComplete 278 | { loadingModel 279 | | ballTextures = Dict.insert n texture loadingModel.ballTextures 280 | } 281 | 282 | Err _ -> 283 | Failed "Failed to load ball texture" 284 | 285 | ( GotBallRoughnessTexture maybeTexture, Loading loadingModel ) -> 286 | case maybeTexture of 287 | Ok texture -> 288 | loadComplete 289 | { loadingModel 290 | | roughnessTexture = Just texture 291 | } 292 | 293 | Err _ -> 294 | Failed "Failed to load roughness texture" 295 | 296 | ( GotTable maybeTable, Loading loadingModel ) -> 297 | case maybeTable of 298 | Ok table -> 299 | loadComplete 300 | { loadingModel 301 | | table = Just table 302 | } 303 | 304 | Err error -> 305 | Failed ("Failed to load table mesh: " ++ error) 306 | 307 | ( RunningMsg runningMsg, Loaded loadedModel ) -> 308 | let 309 | newGame = 310 | Game.update loadedModel.window runningMsg loadedModel.game 311 | in 312 | Loaded { loadedModel | game = newGame } 313 | 314 | ( StartNewGameButtonClicked, Loaded loadedModel ) -> 315 | Loaded { loadedModel | game = Game.initial loadedModel.table } 316 | 317 | _ -> 318 | model 319 | 320 | 321 | loadComplete : LoadingModel -> Model 322 | loadComplete model = 323 | if Dict.size model.ballTextures == 15 then 324 | Maybe.map3 325 | (\roughnessTexture table window -> 326 | Loaded 327 | { ballTextures = model.ballTextures 328 | , table = table 329 | , assetsPath = model.assetsPath 330 | , window = window 331 | , roughnessTexture = roughnessTexture 332 | , game = Game.initial table 333 | } 334 | ) 335 | model.roughnessTexture 336 | model.table 337 | model.window 338 | |> Maybe.withDefault (Loading model) 339 | 340 | else 341 | Loading model 342 | -------------------------------------------------------------------------------- /src/Table.elm: -------------------------------------------------------------------------------- 1 | module Table exposing 2 | ( Table, load 3 | , footSpot, areaBallInHand, areaBehindTheHeadString, areaBehindTheHeadStringEntity 4 | ) 5 | 6 | {-| elm-obj-file is used to decode various objects from the obj file. 7 | 8 | - Colliders for the table body prefixed with `Table-*` 9 | - Colliders for the cushions body prefixed with `Cushions-*` 10 | - Collider for the pockets body: `Pockets` 11 | - Mesh used for rendering: `Billiard-Table` 12 | 13 | The Billiard Table model is designed by Kolja Wilcke 14 | 15 | @docs Table, load 16 | 17 | 18 | # Dimensions 19 | 20 | @docs footSpot, areaBallInHand, areaBehindTheHeadString, areaBehindTheHeadStringEntity 21 | 22 | -} 23 | 24 | import Ball 25 | import Bodies exposing (Id(..)) 26 | import Color 27 | import Direction3d 28 | import Frame3d 29 | import Http 30 | import Length exposing (Length, Meters) 31 | import Obj.Decode exposing (Decoder) 32 | import Physics.Body as Body exposing (Body) 33 | import Physics.Coordinates exposing (BodyCoordinates, WorldCoordinates) 34 | import Physics.Material 35 | import Physics.Shape as Shape 36 | import Point2d exposing (Point2d) 37 | import Point3d 38 | import Quantity 39 | import Rectangle2d 40 | import Rectangle3d exposing (Rectangle3d) 41 | import Scene3d exposing (Entity) 42 | import Scene3d.Material as Material 43 | import Scene3d.Mesh 44 | import SketchPlane3d 45 | import Task exposing (Task) 46 | 47 | 48 | {-| The visual entity and the collider bodies used in simulation 49 | -} 50 | type alias Table = 51 | { bodies : List (Body Id) 52 | , entity : Entity BodyCoordinates 53 | } 54 | 55 | 56 | {-| Load the table from the obj file and texture files 57 | -} 58 | load : { colorTexture : String, roughnessTexture : String, metallicTexture : String, mesh : String } -> Task String Table 59 | load urls = 60 | Http.task 61 | { method = "get" 62 | , headers = [] 63 | , body = Http.emptyBody 64 | , url = urls.mesh 65 | , resolver = 66 | Http.stringResolver 67 | (\resp -> 68 | case resp of 69 | Http.GoodStatus_ _ str -> 70 | Obj.Decode.decodeString Length.meters tableDecoder str 71 | 72 | _ -> 73 | Err "Failed to load mesh" 74 | ) 75 | , timeout = Nothing 76 | } 77 | |> Task.andThen 78 | (\fn -> 79 | Task.map3 80 | (\colorTexture _ metallicTexture -> 81 | fn 82 | (Material.texturedPbr 83 | { baseColor = colorTexture 84 | , roughness = Material.constant 0.8 -- roughnessTexture 85 | , metallic = metallicTexture 86 | } 87 | ) 88 | ) 89 | (Material.loadWith Material.nearestNeighborFiltering urls.colorTexture) 90 | (Material.load urls.roughnessTexture) 91 | (Material.load urls.metallicTexture) 92 | |> Task.mapError (\_ -> "Failed to load texture") 93 | ) 94 | 95 | 96 | tableDecoder : Decoder (Material.Textured BodyCoordinates -> Table) 97 | tableDecoder = 98 | Obj.Decode.map4 99 | (\tableConvexes cushionsConvexes pocketsConvex visual -> 100 | let 101 | mesh = 102 | Scene3d.Mesh.texturedFaces visual 103 | 104 | height = 105 | 0.75 106 | 107 | bodies = 108 | [ Body.plane Floor 109 | -- distance from the floor until the top of the table 110 | |> Body.moveTo (Point3d.meters 0 0 -height) 111 | , Body.compound (List.map Shape.unsafeConvex tableConvexes) Bodies.Table 112 | |> Body.withMaterial 113 | (Physics.Material.custom 114 | { friction = 0.8 115 | , bounciness = 0 116 | } 117 | ) 118 | , Body.compound (List.map Shape.unsafeConvex cushionsConvexes) Cushion 119 | |> Body.withMaterial 120 | (Physics.Material.custom 121 | { friction = 0.1 122 | , bounciness = 0.8 123 | } 124 | ) 125 | , Body.compound [ Shape.unsafeConvex pocketsConvex ] Pocket 126 | ] 127 | in 128 | \material -> 129 | { bodies = bodies 130 | , entity = 131 | Scene3d.group 132 | [ Scene3d.meshWithShadow material mesh (Scene3d.Mesh.shadow mesh) 133 | , -- floor 134 | Scene3d.quad 135 | (Material.matte (Color.rgb255 46 52 54)) 136 | (Point3d.meters -15 -15 -height) 137 | (Point3d.meters 15 -15 -height) 138 | (Point3d.meters 15 15 -height) 139 | (Point3d.meters -15 15 -height) 140 | ] 141 | } 142 | ) 143 | (startsWith "Table-" (Obj.Decode.trianglesIn Frame3d.atOrigin)) 144 | (startsWith "Cushions-" (Obj.Decode.trianglesIn Frame3d.atOrigin)) 145 | (Obj.Decode.object "Pockets" (Obj.Decode.trianglesIn Frame3d.atOrigin)) 146 | (Obj.Decode.filter 147 | (\{ object } -> 148 | object 149 | |> Maybe.map (String.startsWith "Billiard-") 150 | |> Maybe.withDefault False 151 | ) 152 | (Obj.Decode.texturedFacesIn Frame3d.atOrigin) 153 | ) 154 | 155 | 156 | startsWith : String -> Decoder a -> Decoder (List a) 157 | startsWith prefix decoder = 158 | Obj.Decode.objectNames 159 | |> Obj.Decode.andThen 160 | (\names -> 161 | names 162 | |> List.filter (String.startsWith prefix) 163 | |> List.map (\name -> Obj.Decode.object name decoder) 164 | |> Obj.Decode.combine 165 | ) 166 | 167 | 168 | 169 | -- DIMENSIONS 170 | 171 | 172 | length : Length 173 | length = 174 | Length.meters 2.26 175 | 176 | 177 | width : Length 178 | width = 179 | Length.meters 1.24 180 | 181 | 182 | {-| The foot spot is the place where you “spot the ball”, it is also 183 | the place where the top object ball is placed when racking a game 184 | -} 185 | footSpot : Point2d Meters WorldCoordinates 186 | footSpot = 187 | Point2d.xy 188 | (Quantity.half (Quantity.half length)) 189 | Quantity.zero 190 | 191 | 192 | {-| Anywhere on the table. This where the cue ball should be placed after it goes in a pocket 193 | or after the failure to hit the object ball. 194 | -} 195 | areaBallInHand : Rectangle3d Meters WorldCoordinates 196 | areaBallInHand = 197 | let 198 | xOffset = 199 | Quantity.half length |> Quantity.minus Ball.radius 200 | 201 | yOffset = 202 | Quantity.half width |> Quantity.minus Ball.radius 203 | in 204 | Rectangle3d.on SketchPlane3d.xy 205 | (Rectangle2d.from 206 | (Point2d.xy (Quantity.negate xOffset) (Quantity.negate yOffset)) 207 | (Point2d.xy xOffset yOffset) 208 | ) 209 | |> Rectangle3d.translateIn Direction3d.z (Length.millimeters 1) 210 | 211 | 212 | {-| The area where you break from, and where you must place the cue ball after a scratch. 213 | -} 214 | areaBehindTheHeadString : Rectangle3d Meters WorldCoordinates 215 | areaBehindTheHeadString = 216 | let 217 | yOffset = 218 | Quantity.half width |> Quantity.minus Ball.radius 219 | 220 | xMin = 221 | Quantity.half length |> Quantity.minus Ball.radius |> Quantity.negate 222 | 223 | xMax = 224 | Quantity.half (Quantity.half length) |> Quantity.negate 225 | in 226 | Rectangle3d.on SketchPlane3d.xy 227 | (Rectangle2d.from 228 | (Point2d.xy xMin (Quantity.negate yOffset)) 229 | (Point2d.xy xMax yOffset) 230 | ) 231 | |> Rectangle3d.translateIn Direction3d.z (Length.millimeters 1) 232 | 233 | 234 | {-| Highlight the area behind the head string when the ball should be placed there 235 | -} 236 | areaBehindTheHeadStringEntity : Entity WorldCoordinates 237 | areaBehindTheHeadStringEntity = 238 | case Rectangle3d.vertices areaBehindTheHeadString of 239 | [ v1, v2, v3, v4 ] -> 240 | Scene3d.quad 241 | (Material.nonmetal 242 | { baseColor = Color.rgb255 131 146 34 243 | , roughness = 1 244 | } 245 | ) 246 | v1 247 | v2 248 | v3 249 | v4 250 | 251 | _ -> 252 | Scene3d.nothing 253 | -------------------------------------------------------------------------------- /tests/EightBallTests.elm: -------------------------------------------------------------------------------- 1 | module EightBallTests exposing (..) 2 | 3 | import EightBall 4 | import Expect 5 | import Test exposing (..) 6 | import Time 7 | 8 | 9 | suite : Test 10 | suite = 11 | describe "Pool" 12 | [ describe "view" 13 | [ describe "currentScore" 14 | [ test "no events sent, score is 0-0" 15 | (\_ -> 16 | let 17 | nextAction = 18 | EightBall.start 19 | |> EightBall.rack (Time.millisToPosix 0) 20 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 21 | |> EightBall.playerShot [] 22 | in 23 | case nextAction of 24 | EightBall.IllegalBreak pool -> 25 | pool 26 | |> EightBall.currentScore 27 | |> Expect.equal 28 | { player1 = 0 29 | , player2 = 0 30 | } 31 | 32 | other -> 33 | Expect.fail <| 34 | "Should be EightBall.IllegalBreak, but found this instead:\n" 35 | ++ Debug.toString other 36 | ) 37 | , test "a ball is pocketed and target balls are decided, score is 1-0" 38 | (\_ -> 39 | let 40 | nextAction = 41 | EightBall.start 42 | |> EightBall.rack (Time.millisToPosix 0) 43 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 44 | |> EightBall.playerShot 45 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 46 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 47 | ] 48 | in 49 | case nextAction of 50 | EightBall.NextShot pool -> 51 | pool 52 | |> EightBall.currentScore 53 | |> Expect.equal 54 | { player1 = 1 55 | , player2 = 0 56 | } 57 | 58 | other -> 59 | Expect.fail <| 60 | "Should be EightBall.NextShot, but found this instead:\n" 61 | ++ Debug.toString other 62 | ) 63 | , test "several balls are pocketed, score is 3-5" 64 | (\_ -> 65 | let 66 | nextAction = 67 | EightBall.start 68 | |> EightBall.rack (Time.millisToPosix 0) 69 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 70 | |> EightBall.playerShot 71 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 72 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 73 | ] 74 | |> andKeepShooting 75 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.twoBall 76 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.threeBall 77 | , EightBall.ballFellInPocket (Time.millisToPosix 3) EightBall.fiveBall 78 | ] 79 | |> andKeepShooting [] 80 | -- Player 2 starts shooting 81 | |> andKeepShooting 82 | [ EightBall.cueHitBall (Time.millisToPosix 5) EightBall.nineBall 83 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.nineBall 84 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.tenBall 85 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.elevenBall 86 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.twelveBall 87 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.thirteenBall 88 | ] 89 | in 90 | case nextAction of 91 | EightBall.NextShot pool -> 92 | pool 93 | |> EightBall.currentScore 94 | |> Expect.equal 95 | { player1 = 3 96 | , player2 = 5 97 | } 98 | 99 | other -> 100 | Expect.fail <| 101 | "Should be EightBall.NextShot, but found this instead:\n" 102 | ++ Debug.toString other 103 | ) 104 | ] 105 | ] 106 | , describe "update" 107 | [ describe "playerShot" 108 | [ test "after player shoots cue hits nothing, next players turn" 109 | (\_ -> 110 | let 111 | nextAction = 112 | EightBall.start 113 | |> EightBall.rack (Time.millisToPosix 0) 114 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 115 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 116 | |> andKeepShooting [] 117 | |> andKeepShooting [] 118 | in 119 | case nextAction of 120 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 121 | pool 122 | |> EightBall.currentPlayer 123 | |> Expect.equal EightBall.Player2 124 | 125 | other -> 126 | Expect.fail <| 127 | "Should be EightBall.PlayersFault, but found this instead:\n" 128 | ++ Debug.toString other 129 | ) 130 | , test "after player shoots cue hits ball, but doesn't pocket it, next players turn" 131 | (\_ -> 132 | let 133 | nextAction = 134 | EightBall.start 135 | |> EightBall.rack (Time.millisToPosix 0) 136 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 137 | -- Player 1 has legal break 138 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 139 | -- Player 2 misses 140 | |> andKeepShooting [] 141 | -- Player 1 misses 142 | |> andKeepShooting 143 | [ EightBall.cueHitBall (Time.millisToPosix 0) EightBall.twoBall 144 | , EightBall.ballHitWall (Time.millisToPosix 1) EightBall.twoBall 145 | ] 146 | in 147 | case nextAction of 148 | EightBall.NextShot pool -> 149 | pool 150 | |> EightBall.currentPlayer 151 | |> Expect.equal EightBall.Player2 152 | 153 | other -> 154 | Expect.fail <| 155 | "Should be EightBall.NextShot, but found this instead:\n" 156 | ++ Debug.toString other 157 | ) 158 | , test "after player shoots cue hits nothing, and next player hits nothing, back to first" 159 | (\_ -> 160 | let 161 | nextAction = 162 | EightBall.start 163 | |> EightBall.rack (Time.millisToPosix 0) 164 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 165 | -- Player 1 has legal break 166 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 167 | -- Player 2 misses 168 | |> andKeepShooting [] 169 | -- Player 1 misses 170 | |> andKeepShooting [] 171 | -- Player 2 misses 172 | |> andKeepShooting [] 173 | in 174 | case nextAction of 175 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 176 | pool 177 | |> EightBall.currentPlayer 178 | |> Expect.equal EightBall.Player1 179 | 180 | other -> 181 | Expect.fail <| 182 | "Should be EightBall.PlayersFault, but found this instead:\n" 183 | ++ Debug.toString other 184 | ) 185 | , test "after player shoots cue and pockets a ball, that group becomes the player's target" 186 | (\_ -> 187 | let 188 | nextAction = 189 | EightBall.start 190 | |> EightBall.rack (Time.millisToPosix 0) 191 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 192 | |> EightBall.playerShot 193 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 194 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 195 | ] 196 | in 197 | case nextAction of 198 | EightBall.NextShot pool -> 199 | pool 200 | |> Expect.all 201 | [ EightBall.currentTarget >> Expect.equal EightBall.Solids 202 | , EightBall.currentPlayer >> Expect.equal EightBall.Player1 203 | ] 204 | 205 | other -> 206 | Expect.fail <| 207 | "Should be EightBall.NextShot, but found this instead:\n" 208 | ++ Debug.toString other 209 | ) 210 | , test "after player shoots cue and pockets two stripes, then that player's target will become stripes" 211 | (\_ -> 212 | let 213 | nextAction = 214 | EightBall.start 215 | |> EightBall.rack (Time.millisToPosix 0) 216 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 217 | |> EightBall.playerShot 218 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fifteenBall 219 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.tenBall 220 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fifteenBall 221 | ] 222 | in 223 | case nextAction of 224 | EightBall.NextShot pool -> 225 | pool 226 | |> EightBall.currentTarget 227 | |> Expect.equal EightBall.Stripes 228 | 229 | other -> 230 | Expect.fail <| 231 | "Should be EightBall.NextShot, but found this instead:\n" 232 | ++ Debug.toString other 233 | ) 234 | , test "after player shoots cue and pockets a solid and two strips, table is still open" 235 | (\_ -> 236 | let 237 | nextAction = 238 | EightBall.start 239 | |> EightBall.rack (Time.millisToPosix 0) 240 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 241 | |> EightBall.playerShot 242 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 243 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 244 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.nineBall 245 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.tenBall 246 | ] 247 | in 248 | case nextAction of 249 | EightBall.NextShot pool -> 250 | pool 251 | |> EightBall.currentTarget 252 | |> Expect.equal EightBall.OpenTable 253 | 254 | other -> 255 | Expect.fail <| 256 | "Should be EightBall.NextShot, but found this instead:\n" 257 | ++ Debug.toString other 258 | ) 259 | , test "after player shoots cue and pockets a ball but also scratches, table is still open" 260 | (\_ -> 261 | let 262 | nextAction = 263 | EightBall.start 264 | |> EightBall.rack (Time.millisToPosix 0) 265 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 266 | |> EightBall.playerShot 267 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 268 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 269 | , EightBall.scratch (Time.millisToPosix 1) 270 | ] 271 | in 272 | case nextAction of 273 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 274 | pool 275 | |> Expect.all 276 | [ EightBall.currentTarget >> Expect.equal EightBall.OpenTable 277 | , EightBall.currentPlayer >> Expect.equal EightBall.Player2 278 | ] 279 | 280 | other -> 281 | Expect.fail <| 282 | "Should be EightBall.PlayersFault, but found this instead:\n" 283 | ++ Debug.toString other 284 | ) 285 | , test "after player shoots cue and pockets all of their target balls, then on the next shot targeting the 8-ball, it's still their shot!" 286 | (\_ -> 287 | let 288 | nextAction = 289 | EightBall.start 290 | |> EightBall.rack (Time.millisToPosix 0) 291 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 292 | |> EightBall.playerShot 293 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 294 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 295 | ] 296 | |> andKeepShooting 297 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 298 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.twoBall 299 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.threeBall 300 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fourBall 301 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fiveBall 302 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.sixBall 303 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.sevenBall 304 | ] 305 | in 306 | case nextAction of 307 | EightBall.NextShot pool -> 308 | pool 309 | |> Expect.all 310 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player1 311 | , EightBall.currentTarget >> Expect.equal EightBall.EightBall 312 | ] 313 | 314 | other -> 315 | Expect.fail <| 316 | "Should be EightBall.NextShot, but found this instead:\n" 317 | ++ Debug.toString other 318 | ) 319 | , test "after player shoots cue and pockets all of their solid balls, then on the next shot targeting the 8-ball, it's still their shot!" 320 | (\_ -> 321 | let 322 | nextAction = 323 | EightBall.start 324 | |> EightBall.rack (Time.millisToPosix 0) 325 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 326 | |> EightBall.playerShot 327 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 328 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 329 | ] 330 | |> andKeepShooting 331 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 332 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.twoBall 333 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.threeBall 334 | ] 335 | |> andKeepShooting 336 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 337 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fourBall 338 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fiveBall 339 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.sixBall 340 | ] 341 | |> andKeepShooting 342 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.sevenBall 343 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.sevenBall 344 | ] 345 | in 346 | case nextAction of 347 | EightBall.NextShot pool -> 348 | pool 349 | |> Expect.all 350 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player1 351 | , EightBall.currentTarget >> Expect.equal EightBall.EightBall 352 | ] 353 | 354 | other -> 355 | Expect.fail <| 356 | "Should be EightBall.NextShot, but found this instead:\n" 357 | ++ Debug.toString other 358 | ) 359 | , test "after player shoots cue and pockets all of their striped balls, then on the next shot targeting the 8-ball, it's still their shot!" 360 | (\_ -> 361 | let 362 | nextAction = 363 | EightBall.start 364 | |> EightBall.rack (Time.millisToPosix 0) 365 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 366 | |> EightBall.playerShot 367 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.nineBall 368 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.nineBall 369 | ] 370 | |> andKeepShooting 371 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fifteenBall 372 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fifteenBall 373 | ] 374 | |> andKeepShooting 375 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.tenBall 376 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.tenBall 377 | ] 378 | |> andKeepShooting 379 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.elevenBall 380 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.elevenBall 381 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.twelveBall 382 | ] 383 | |> andKeepShooting 384 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.thirteenBall 385 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.thirteenBall 386 | ] 387 | |> andKeepShooting 388 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fourteenBall 389 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fourteenBall 390 | ] 391 | in 392 | case nextAction of 393 | EightBall.NextShot pool -> 394 | pool 395 | |> Expect.all 396 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player1 397 | , EightBall.currentTarget >> Expect.equal EightBall.EightBall 398 | ] 399 | 400 | other -> 401 | Expect.fail <| 402 | "Should be EightBall.NextShot, but found this instead:\n" 403 | ++ Debug.toString other 404 | ) 405 | , test "after player shoots cue and pockets all of their balls, then hits 8-ball without scratching, they win!" 406 | (\_ -> 407 | let 408 | nextAction = 409 | EightBall.start 410 | |> EightBall.rack (Time.millisToPosix 0) 411 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 412 | |> EightBall.playerShot 413 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 414 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 415 | ] 416 | |> andKeepShooting 417 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 418 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.twoBall 419 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.threeBall 420 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fourBall 421 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.fiveBall 422 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.sixBall 423 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.sevenBall 424 | ] 425 | |> andKeepShooting 426 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.eightBall 427 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.eightBall 428 | ] 429 | in 430 | case nextAction of 431 | EightBall.GameOver _ { winner } -> 432 | Expect.equal winner EightBall.Player1 433 | 434 | other -> 435 | Expect.fail <| 436 | "Should be EightBall.GameOver, but found this instead:\n" 437 | ++ Debug.toString other 438 | ) 439 | , test "after player shoots back and forth, then one finishes all of their target, then hits 8-ball without scratching, they win!" 440 | (\_ -> 441 | let 442 | nextAction = 443 | EightBall.start 444 | |> EightBall.rack (Time.millisToPosix 0) 445 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 446 | -- Player 1 has legal break 447 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 448 | -- Player 2 449 | |> andKeepShooting 450 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 451 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 452 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.threeBall 453 | , EightBall.ballFellInPocket (Time.millisToPosix 6) EightBall.fourBall 454 | , EightBall.ballFellInPocket (Time.millisToPosix 7) EightBall.fiveBall 455 | , EightBall.ballFellInPocket (Time.millisToPosix 8) EightBall.sixBall 456 | ] 457 | -- Player 2 misses 458 | |> andKeepShooting 459 | [ EightBall.cueHitBall (Time.millisToPosix 10) EightBall.oneBall 460 | ] 461 | -- Player 1 shoots again 462 | |> andKeepShooting 463 | [ EightBall.cueHitBall (Time.millisToPosix 111) EightBall.nineBall 464 | , EightBall.ballFellInPocket (Time.millisToPosix 115) EightBall.nineBall 465 | ] 466 | -- Player 1 misses 467 | |> andKeepShooting 468 | [ EightBall.cueHitBall (Time.millisToPosix 1200) EightBall.tenBall 469 | ] 470 | -- Player 2 finishes off target group 471 | |> andKeepShooting 472 | [ EightBall.cueHitBall (Time.millisToPosix 1205) EightBall.sevenBall 473 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.sevenBall 474 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.oneBall 475 | ] 476 | -- Player 2 makes 8-ball 477 | |> andKeepShooting 478 | [ EightBall.cueHitBall (Time.millisToPosix 1600) EightBall.eightBall 479 | , EightBall.ballFellInPocket (Time.millisToPosix 1800) EightBall.eightBall 480 | ] 481 | in 482 | case nextAction of 483 | EightBall.GameOver _ { winner } -> 484 | Expect.equal winner EightBall.Player2 485 | 486 | other -> 487 | Expect.fail <| 488 | "Should be EightBall.GameOver, but found this instead:\n" 489 | ++ Debug.toString other 490 | ) 491 | , test "after player finishes all of their target, then hits 8-ball but scratches, they lose :(" 492 | (\_ -> 493 | let 494 | nextAction = 495 | EightBall.start 496 | |> EightBall.rack (Time.millisToPosix 0) 497 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 498 | -- Player 1 has legal break 499 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 500 | -- Player 2 501 | |> andKeepShooting 502 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 503 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 504 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.threeBall 505 | , EightBall.ballFellInPocket (Time.millisToPosix 6) EightBall.fourBall 506 | , EightBall.ballFellInPocket (Time.millisToPosix 7) EightBall.fiveBall 507 | , EightBall.ballFellInPocket (Time.millisToPosix 8) EightBall.sixBall 508 | ] 509 | -- Player 2 misses 510 | |> andKeepShooting 511 | [ EightBall.cueHitBall (Time.millisToPosix 10) EightBall.oneBall 512 | ] 513 | -- Player 1 shoots again 514 | |> andKeepShooting 515 | [ EightBall.cueHitBall (Time.millisToPosix 111) EightBall.nineBall 516 | , EightBall.ballFellInPocket (Time.millisToPosix 115) EightBall.nineBall 517 | ] 518 | -- Player 1 misses 519 | |> andKeepShooting 520 | [ EightBall.cueHitBall (Time.millisToPosix 1200) EightBall.tenBall 521 | ] 522 | -- Player 2 finishes off target group 523 | |> andKeepShooting 524 | [ EightBall.cueHitBall (Time.millisToPosix 1205) EightBall.sevenBall 525 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.sevenBall 526 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.oneBall 527 | ] 528 | -- Player 2 makes 8-ball, but then scratches 529 | |> andKeepShooting 530 | [ EightBall.cueHitBall (Time.millisToPosix 1600) EightBall.eightBall 531 | , EightBall.ballFellInPocket (Time.millisToPosix 1800) EightBall.eightBall 532 | , EightBall.scratch (Time.millisToPosix 1700) 533 | ] 534 | in 535 | case nextAction of 536 | EightBall.GameOver _ { winner } -> 537 | Expect.equal winner EightBall.Player1 538 | 539 | other -> 540 | Expect.fail <| 541 | "Should be EightBall.GameOver, but found this instead:\n" 542 | ++ Debug.toString other 543 | ) 544 | , test "after player finishes all of their target, then hits another ball before pocketing the 8-ball, they lose :(" 545 | (\_ -> 546 | let 547 | nextAction = 548 | EightBall.start 549 | |> EightBall.rack (Time.millisToPosix 0) 550 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 551 | -- Player 1 has legal break 552 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 553 | -- Player 2 554 | |> andKeepShooting 555 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 556 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 557 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.threeBall 558 | , EightBall.ballFellInPocket (Time.millisToPosix 6) EightBall.fourBall 559 | , EightBall.ballFellInPocket (Time.millisToPosix 7) EightBall.fiveBall 560 | , EightBall.ballFellInPocket (Time.millisToPosix 8) EightBall.sixBall 561 | ] 562 | -- Player 2 misses 563 | |> andKeepShooting 564 | [ EightBall.cueHitBall (Time.millisToPosix 10) EightBall.oneBall 565 | ] 566 | -- Player 1 shoots again 567 | |> andKeepShooting 568 | [ EightBall.cueHitBall (Time.millisToPosix 111) EightBall.nineBall 569 | , EightBall.ballFellInPocket (Time.millisToPosix 115) EightBall.nineBall 570 | ] 571 | -- Player 1 misses 572 | |> andKeepShooting 573 | [ EightBall.cueHitBall (Time.millisToPosix 1200) EightBall.tenBall 574 | ] 575 | -- Player 2 finishes off target group 576 | |> andKeepShooting 577 | [ EightBall.cueHitBall (Time.millisToPosix 1205) EightBall.sevenBall 578 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.sevenBall 579 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.oneBall 580 | ] 581 | -- Player 2 makes 8-ball, but hit the 7-ball first! 582 | |> andKeepShooting 583 | [ EightBall.cueHitBall (Time.millisToPosix 1600) EightBall.sevenBall 584 | , EightBall.ballFellInPocket (Time.millisToPosix 1800) EightBall.eightBall 585 | ] 586 | in 587 | case nextAction of 588 | EightBall.GameOver _ { winner } -> 589 | Expect.equal winner EightBall.Player1 590 | 591 | other -> 592 | Expect.fail <| 593 | "Should be EightBall.GameOver, but found this instead:\n" 594 | ++ Debug.toString other 595 | ) 596 | , test "after player shoots the 8-ball early (before they have finished all of their target balls), they lose :(" 597 | (\_ -> 598 | let 599 | nextAction = 600 | EightBall.start 601 | |> EightBall.rack (Time.millisToPosix 0) 602 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 603 | -- Player 1 has legal break 604 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 605 | -- Player 2 606 | |> andKeepShooting 607 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 608 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 609 | ] 610 | -- Player 2 misses 611 | |> andKeepShooting 612 | [ EightBall.cueHitBall (Time.millisToPosix 10) EightBall.oneBall 613 | ] 614 | -- Player 1 shoots again and accidentally hits the 8-ball in early. 615 | |> andKeepShooting 616 | [ EightBall.cueHitBall (Time.millisToPosix 111) EightBall.nineBall 617 | , EightBall.ballFellInPocket (Time.millisToPosix 115) EightBall.eightBall 618 | ] 619 | in 620 | case nextAction of 621 | EightBall.GameOver _ { winner } -> 622 | Expect.equal winner EightBall.Player2 623 | 624 | other -> 625 | Expect.fail <| 626 | "Should be EightBall.GameOver, but found this instead:\n" 627 | ++ Debug.toString other 628 | ) 629 | ] 630 | , describe "legal break" 631 | [ test "if player does not get 4 balls to a wall, it's a re-rack and break for the other player" 632 | (\_ -> 633 | let 634 | nextAction = 635 | EightBall.start 636 | |> EightBall.rack (Time.millisToPosix 0) 637 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 638 | |> EightBall.playerShot 639 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 640 | ] 641 | in 642 | case nextAction of 643 | EightBall.IllegalBreak pool -> 644 | pool 645 | |> Expect.all 646 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 647 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 648 | ] 649 | 650 | other -> 651 | Expect.fail <| 652 | "Should be EightBall.IllegalBreak, but found this instead:\n" 653 | ++ Debug.toString other 654 | ) 655 | , test "if player does not get 4 balls to a wall and the next player too, back to the first to break" 656 | (\_ -> 657 | let 658 | nextAction = 659 | EightBall.start 660 | |> EightBall.rack (Time.millisToPosix 0) 661 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 662 | |> EightBall.playerShot 663 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 664 | ] 665 | |> andRebreak [] 666 | in 667 | case nextAction of 668 | EightBall.IllegalBreak pool -> 669 | pool 670 | |> Expect.all 671 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player1 672 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 673 | ] 674 | 675 | other -> 676 | Expect.fail <| 677 | "Should be EightBall.IllegalBreak, but found this instead:\n" 678 | ++ Debug.toString other 679 | ) 680 | , test "if player does not get 4 balls to a wall and the next player too, back to the first to break, from game" 681 | (\_ -> 682 | {- 683 | [{ event = Racked, when = Posix 0 }, 684 | { event = BallPlacedBehindHeadString, when = Posix 1609440921470 }, 685 | { event = Shot [], when = Posix 1609440921470 }, 686 | { event = Racked, when = Posix 1609440936665 }, 687 | { event = BallPlacedBehindHeadString, when = Posix 1609440940067 }] 688 | -} 689 | let 690 | initialBreak = 691 | EightBall.start 692 | |> EightBall.rack (Time.millisToPosix 0) 693 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 1609440921470) 694 | |> EightBall.playerShot [] 695 | 696 | secondBreak = 697 | case initialBreak of 698 | EightBall.NextShot _ -> 699 | initialBreak 700 | 701 | EightBall.PlayersFault _ -> 702 | initialBreak 703 | 704 | EightBall.GameOver _ _ -> 705 | initialBreak 706 | 707 | EightBall.IllegalBreak pool -> 708 | pool 709 | |> EightBall.rack (Time.millisToPosix 1609440936665) 710 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 1609440940067) 711 | |> EightBall.playerShot [] 712 | in 713 | case secondBreak of 714 | EightBall.IllegalBreak pool -> 715 | pool 716 | |> Expect.all 717 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player1 718 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 719 | ] 720 | 721 | other -> 722 | Expect.fail <| 723 | "Should be EightBall.IllegalBreak, but found this instead:\n" 724 | ++ Debug.toString other 725 | ) 726 | ] 727 | , describe "legal hit" 728 | [ test "if player has solids but shoots a stripe first, the other player gets ball-in-hand" 729 | (\_ -> 730 | let 731 | nextAction = 732 | EightBall.start 733 | |> EightBall.rack (Time.millisToPosix 0) 734 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 735 | |> EightBall.playerShot 736 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 737 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.oneBall 738 | ] 739 | -- Player 1 is now solids, but they hit the 9-ball! 740 | |> andKeepShooting 741 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.nineBall 742 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 743 | ] 744 | in 745 | case nextAction of 746 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 747 | pool 748 | |> Expect.all 749 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 750 | , EightBall.currentTarget >> Expect.equal EightBall.Stripes 751 | ] 752 | 753 | other -> 754 | Expect.fail <| 755 | "Should be EightBall.PlayersFault, but found this instead:\n" 756 | ++ Debug.toString other 757 | ) 758 | , test "if player has stripes but shoots a solid first, the other player gets ball-in-hand" 759 | (\_ -> 760 | let 761 | nextAction = 762 | EightBall.start 763 | |> EightBall.rack (Time.millisToPosix 0) 764 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 765 | |> EightBall.playerShot 766 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.nineBall 767 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.nineBall 768 | ] 769 | -- Player 1 is now stripes, but they hit the 2-ball! 770 | |> andKeepShooting 771 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.twoBall 772 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 773 | ] 774 | in 775 | case nextAction of 776 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 777 | pool 778 | |> Expect.all 779 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 780 | , EightBall.currentTarget >> Expect.equal EightBall.Solids 781 | ] 782 | 783 | other -> 784 | Expect.fail <| 785 | "Should be EightBall.PlayersFault, but found this instead:\n" 786 | ++ Debug.toString other 787 | ) 788 | , test "if player is targeting the 8-ball but shoots any other ball first, the other player gets ball-in-hand" 789 | (\_ -> 790 | let 791 | nextAction = 792 | EightBall.start 793 | |> EightBall.rack (Time.millisToPosix 0) 794 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 795 | -- Player 1 has legal break 796 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 797 | -- Player 2 798 | |> andKeepShooting 799 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.fiveBall 800 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.twoBall 801 | , EightBall.ballFellInPocket (Time.millisToPosix 5) EightBall.threeBall 802 | , EightBall.ballFellInPocket (Time.millisToPosix 6) EightBall.fourBall 803 | , EightBall.ballFellInPocket (Time.millisToPosix 7) EightBall.fiveBall 804 | , EightBall.ballFellInPocket (Time.millisToPosix 8) EightBall.sixBall 805 | ] 806 | -- Player 2 misses 807 | |> andKeepShooting 808 | [ EightBall.cueHitBall (Time.millisToPosix 10) EightBall.oneBall 809 | ] 810 | -- Player 1 shoots again 811 | |> andKeepShooting 812 | [ EightBall.cueHitBall (Time.millisToPosix 111) EightBall.nineBall 813 | , EightBall.ballFellInPocket (Time.millisToPosix 115) EightBall.nineBall 814 | ] 815 | -- Player 1 misses 816 | |> andKeepShooting 817 | [ EightBall.cueHitBall (Time.millisToPosix 1200) EightBall.tenBall 818 | ] 819 | -- Player 2 finishes off target group 820 | |> andKeepShooting 821 | [ EightBall.cueHitBall (Time.millisToPosix 1205) EightBall.sevenBall 822 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.sevenBall 823 | , EightBall.ballFellInPocket (Time.millisToPosix 1500) EightBall.oneBall 824 | ] 825 | -- Player 2 accidentally hits the wrong ball first. 826 | |> andKeepShooting 827 | [ EightBall.cueHitBall (Time.millisToPosix 1600) EightBall.sevenBall 828 | ] 829 | in 830 | case nextAction of 831 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 832 | pool 833 | |> Expect.all 834 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player1 835 | , EightBall.currentTarget >> Expect.equal EightBall.Stripes 836 | ] 837 | 838 | other -> 839 | Expect.fail <| 840 | "Should be EightBall.PlayersFault, but found this instead:\n" 841 | ++ Debug.toString other 842 | ) 843 | , test "if player does not make contact with a ball in their target group, the other player gets ball-in-hand" 844 | (\_ -> 845 | let 846 | nextAction = 847 | EightBall.start 848 | |> EightBall.rack (Time.millisToPosix 0) 849 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 850 | -- Player 1 has legal break 851 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 852 | -- Player 2 misses 853 | |> andKeepShooting [] 854 | -- Player 1 misses 855 | |> andKeepShooting [] 856 | in 857 | case nextAction of 858 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 859 | pool 860 | |> Expect.all 861 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 862 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 863 | ] 864 | 865 | other -> 866 | Expect.fail <| 867 | "Should be EightBall.PlayersFault, but found this instead:\n" 868 | ++ Debug.toString other 869 | ) 870 | , test "if player hits a ball in their target group but does not hit a wall after, the other player gets ball-in-hand" 871 | (\_ -> 872 | let 873 | nextAction = 874 | EightBall.start 875 | |> EightBall.rack (Time.millisToPosix 0) 876 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 877 | -- Player 1 has legal break 878 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 879 | -- Player 2 misses 880 | |> andKeepShooting [] 881 | -- Player 1 misses 882 | |> andKeepShooting 883 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 884 | 885 | -- No wall hit. 886 | ] 887 | in 888 | case nextAction of 889 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 890 | pool 891 | |> Expect.all 892 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 893 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 894 | ] 895 | 896 | other -> 897 | Expect.fail <| 898 | "Should be EightBall.PlayersFault, but found this instead:\n" 899 | ++ Debug.toString other 900 | ) 901 | , test "if player hits the cue into a wall then into a ball in their target group, the other player gets ball-in-hand" 902 | (\_ -> 903 | let 904 | nextAction = 905 | EightBall.start 906 | |> EightBall.rack (Time.millisToPosix 0) 907 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 908 | -- Player 1 has legal break 909 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 910 | -- Player 2 misses 911 | |> andKeepShooting [] 912 | |> andKeepShooting 913 | [ EightBall.cueHitWall (Time.millisToPosix 1) 914 | , EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 915 | ] 916 | in 917 | case nextAction of 918 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 919 | pool 920 | |> Expect.all 921 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 922 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 923 | ] 924 | 925 | other -> 926 | Expect.fail <| 927 | "Should be EightBall.PlayersFault, but found this instead:\n" 928 | ++ Debug.toString other 929 | ) 930 | , test "if player hits a ball in their target group and then the target hits a wall after, the other player does not get ball-in-hand" 931 | (\_ -> 932 | let 933 | nextAction = 934 | EightBall.start 935 | |> EightBall.rack (Time.millisToPosix 0) 936 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 937 | -- Player 1 has legal break 938 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 939 | -- Player 2 misses 940 | |> andKeepShooting [] 941 | |> andKeepShooting 942 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 943 | , EightBall.ballHitWall (Time.millisToPosix 1) EightBall.oneBall 944 | ] 945 | in 946 | case nextAction of 947 | EightBall.NextShot pool -> 948 | pool 949 | |> Expect.all 950 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 951 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 952 | ] 953 | 954 | other -> 955 | Expect.fail <| 956 | "Should be EightBall.NextShot, but found this instead:\n" 957 | ++ Debug.toString other 958 | ) 959 | , test "if player hits a ball in their target group and then the cue ball hits a wall after, the other player does not get ball-in-hand" 960 | (\_ -> 961 | let 962 | nextAction = 963 | EightBall.start 964 | |> EightBall.rack (Time.millisToPosix 0) 965 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 966 | -- Player 1 has legal break 967 | |> EightBall.playerShot (legalBreakNonePocketed (Time.millisToPosix 0)) 968 | -- Player 2 misses 969 | |> andKeepShooting [] 970 | |> andKeepShooting 971 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 972 | , EightBall.cueHitWall (Time.millisToPosix 1) 973 | ] 974 | in 975 | case nextAction of 976 | EightBall.NextShot pool -> 977 | pool 978 | |> Expect.all 979 | [ EightBall.currentPlayer >> Expect.equal EightBall.Player2 980 | , EightBall.currentTarget >> Expect.equal EightBall.OpenTable 981 | ] 982 | 983 | other -> 984 | Expect.fail <| 985 | "Should be EightBall.NextShot, but found this instead:\n" 986 | ++ Debug.toString other 987 | ) 988 | ] 989 | , describe "ballPlacedInHand" 990 | [ test "when player scratches, the other player must place ball in hand before continuing to shoot" 991 | (\_ -> 992 | let 993 | nextAction = 994 | EightBall.start 995 | |> EightBall.rack (Time.millisToPosix 0) 996 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 997 | |> EightBall.playerShot 998 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 999 | , EightBall.scratch (Time.millisToPosix 789) 1000 | ] 1001 | in 1002 | case nextAction of 1003 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 1004 | pool 1005 | |> EightBall.currentPlayer 1006 | |> Expect.equal EightBall.Player2 1007 | 1008 | other -> 1009 | Expect.fail <| 1010 | "Should be EightBall.PlayersFault, but found this instead:\n" 1011 | ++ Debug.toString other 1012 | ) 1013 | , test "when player scratches and next player places ball in hand, they may continue to shoot" 1014 | (\_ -> 1015 | let 1016 | nextAction = 1017 | EightBall.start 1018 | |> EightBall.rack (Time.millisToPosix 0) 1019 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 1020 | |> EightBall.playerShot 1021 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 1022 | , EightBall.scratch (Time.millisToPosix 789) 1023 | ] 1024 | in 1025 | case nextAction of 1026 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 1027 | pool 1028 | |> EightBall.placeBallInHand (Time.millisToPosix 800) 1029 | |> EightBall.currentPlayer 1030 | |> Expect.equal EightBall.Player2 1031 | 1032 | other -> 1033 | Expect.fail <| 1034 | "Should be EightBall.PlayersFault, but found this instead:\n" 1035 | ++ Debug.toString other 1036 | ) 1037 | ] 1038 | , describe "ballOffTable" 1039 | [ test "when player hits a non-8-ball off the table on the break, the next player must place ball in hand before continuing to shoot" 1040 | (\_ -> 1041 | let 1042 | nextAction = 1043 | EightBall.start 1044 | |> EightBall.rack (Time.millisToPosix 0) 1045 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 1046 | |> EightBall.playerShot 1047 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 1048 | , EightBall.ballOffTable (Time.millisToPosix 2) EightBall.oneBall 1049 | , EightBall.ballFellInPocket (Time.millisToPosix 3) EightBall.thirteenBall 1050 | ] 1051 | in 1052 | case nextAction of 1053 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 1054 | pool 1055 | |> EightBall.currentPlayer 1056 | |> Expect.equal EightBall.Player2 1057 | 1058 | other -> 1059 | Expect.fail <| 1060 | "Should be EightBall.PlayersFault, but found this instead:\n" 1061 | ++ Debug.toString other 1062 | ) 1063 | , test "when player hits a non-8-ball off the table after the break, the next player must place ball in hand before continuing to shoot" 1064 | (\_ -> 1065 | let 1066 | nextAction = 1067 | EightBall.start 1068 | |> EightBall.rack (Time.millisToPosix 0) 1069 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 1070 | |> EightBall.playerShot 1071 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 1072 | , EightBall.ballFellInPocket (Time.millisToPosix 3) EightBall.thirteenBall 1073 | ] 1074 | |> andKeepShooting 1075 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 1076 | , EightBall.ballOffTable (Time.millisToPosix 2) EightBall.oneBall 1077 | ] 1078 | in 1079 | case nextAction of 1080 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 1081 | pool 1082 | |> EightBall.currentPlayer 1083 | |> Expect.equal EightBall.Player2 1084 | 1085 | other -> 1086 | Expect.fail <| 1087 | "Should be EightBall.PlayersFault, but found this instead:\n" 1088 | ++ Debug.toString other 1089 | ) 1090 | , test "when player hits the 8-ball off the table on the break, the 8-ball is spotted and the next player must place ball in hand before continuing to shoot" 1091 | (\_ -> 1092 | let 1093 | nextAction = 1094 | EightBall.start 1095 | |> EightBall.rack (Time.millisToPosix 0) 1096 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 1097 | |> EightBall.playerShot 1098 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 1099 | , EightBall.ballOffTable (Time.millisToPosix 2) EightBall.eightBall 1100 | , EightBall.ballFellInPocket (Time.millisToPosix 3) EightBall.thirteenBall 1101 | ] 1102 | in 1103 | case nextAction of 1104 | EightBall.PlayersFault (EightBall.SpotEightBall pool) -> 1105 | pool 1106 | |> EightBall.currentPlayer 1107 | |> Expect.equal EightBall.Player2 1108 | 1109 | other -> 1110 | Expect.fail <| 1111 | "Should be EightBall.PlayersFault, but found this instead:\n" 1112 | ++ Debug.toString other 1113 | ) 1114 | , test "when player hits the 8-ball off the table AFTER the break, the player loses" 1115 | (\_ -> 1116 | let 1117 | nextAction = 1118 | EightBall.start 1119 | |> EightBall.rack (Time.millisToPosix 0) 1120 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix 0) 1121 | |> EightBall.playerShot 1122 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.oneBall 1123 | , EightBall.ballFellInPocket (Time.millisToPosix 1) EightBall.oneBall 1124 | ] 1125 | |> andKeepShooting 1126 | [ EightBall.cueHitBall (Time.millisToPosix 1) EightBall.twoBall 1127 | , EightBall.ballFellInPocket (Time.millisToPosix 2) EightBall.threeBall 1128 | , EightBall.ballFellInPocket (Time.millisToPosix 3) EightBall.fiveBall 1129 | ] 1130 | |> andKeepShooting 1131 | [ EightBall.ballOffTable (Time.millisToPosix 2) EightBall.eightBall 1132 | , EightBall.ballFellInPocket (Time.millisToPosix 3) EightBall.thirteenBall 1133 | ] 1134 | in 1135 | case nextAction of 1136 | EightBall.GameOver _ { winner } -> 1137 | Expect.equal winner EightBall.Player2 1138 | 1139 | other -> 1140 | Expect.fail <| 1141 | "Should be EightBall.GameOver, but found this instead:\n" 1142 | ++ Debug.toString other 1143 | ) 1144 | ] 1145 | ] 1146 | ] 1147 | 1148 | 1149 | andKeepShooting : List ( Time.Posix, EightBall.ShotEvent ) -> EightBall.WhatHappened -> EightBall.WhatHappened 1150 | andKeepShooting shotEvents ruling = 1151 | let 1152 | -- Could instead expose `EightBall.lastEventTime` for consistency. 1153 | lastEventTime = 1154 | shotEvents 1155 | |> List.map (\( time, _ ) -> time) 1156 | |> List.sortBy (Time.toMillis Time.utc) 1157 | |> List.reverse 1158 | |> List.head 1159 | |> Maybe.withDefault (Time.millisToPosix 0) 1160 | in 1161 | case ruling of 1162 | EightBall.NextShot pool -> 1163 | EightBall.playerShot shotEvents pool 1164 | 1165 | EightBall.PlayersFault (EightBall.PlaceBallInHand pool) -> 1166 | pool 1167 | |> EightBall.placeBallInHand lastEventTime 1168 | |> EightBall.playerShot shotEvents 1169 | 1170 | EightBall.PlayersFault (EightBall.SpotEightBall pool) -> 1171 | pool 1172 | |> EightBall.spotEightBall lastEventTime 1173 | |> EightBall.placeBallBehindHeadstring lastEventTime 1174 | |> EightBall.playerShot shotEvents 1175 | 1176 | EightBall.GameOver _ _ -> 1177 | ruling 1178 | 1179 | EightBall.IllegalBreak _ -> 1180 | ruling 1181 | 1182 | 1183 | andRebreak : List ( Time.Posix, EightBall.ShotEvent ) -> EightBall.WhatHappened -> EightBall.WhatHappened 1184 | andRebreak shotEvents ruling = 1185 | let 1186 | -- Could instead expose `EightBall.lastEventTime` for consistency. 1187 | lastEventTime = 1188 | shotEvents 1189 | |> List.map (\( time, _ ) -> time) 1190 | |> List.sortBy (Time.toMillis Time.utc) 1191 | |> List.reverse 1192 | |> List.head 1193 | |> Maybe.withDefault (Time.millisToPosix 0) 1194 | in 1195 | case ruling of 1196 | EightBall.NextShot _ -> 1197 | ruling 1198 | 1199 | EightBall.PlayersFault _ -> 1200 | ruling 1201 | 1202 | EightBall.GameOver _ _ -> 1203 | ruling 1204 | 1205 | EightBall.IllegalBreak pool -> 1206 | pool 1207 | |> EightBall.rack lastEventTime 1208 | |> EightBall.placeBallBehindHeadstring (Time.millisToPosix (Time.posixToMillis lastEventTime + 1)) 1209 | |> EightBall.playerShot shotEvents 1210 | 1211 | 1212 | legalBreakNonePocketed : Time.Posix -> List ( Time.Posix, EightBall.ShotEvent ) 1213 | legalBreakNonePocketed when = 1214 | [ EightBall.cueHitBall when EightBall.oneBall 1215 | , EightBall.ballHitWall when EightBall.oneBall 1216 | , EightBall.ballHitWall when EightBall.fifteenBall 1217 | , EightBall.ballHitWall when EightBall.thirteenBall 1218 | , EightBall.ballHitWall when EightBall.fiveBall 1219 | ] 1220 | --------------------------------------------------------------------------------