diff --git a/.gitignore b/.gitignore index f2fc71b..9081533 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ dist-newstyle .direnv -*.cabal \ No newline at end of file +*.cabal +cabal.project.local diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ae11e0f --- /dev/null +++ b/Makefile @@ -0,0 +1,15 @@ + +all: out/numbersquare.wasm out/ghc_wasm_jsffi.js + +numbersquare.cabal: package.yaml + hpack + +out/numbersquare.wasm: app/*.hs src/*.hs numbersquare.cabal + wasm32-wasi-cabal install --installdir=out --overwrite-policy=always + +out/ghc_wasm_jsffi.js: out/numbersquare.wasm + $(shell wasm32-wasi-ghc --print-libdir)/post-link.mjs -i out/numbersquare.wasm -o out/ghc_wasm_jsffi.js + +.PHONY: clean +clean: + rm -rf dist-newstyle out/numbersquare.wasm out/ghc_wasm_jsffi.js diff --git a/README.org b/README.org new file mode 100644 index 0000000..95c146f --- /dev/null +++ b/README.org @@ -0,0 +1,9 @@ +#+TITLE: Number Square + +* Number Square + +This is supposed to be a clone of [[https://www.gamesaien.com/game/fruit_box_a/][apple game]] (aka Fruit Box), with a +couple of enhancements: + +- multiple game modes +- multiplayer diff --git a/app/App.hs b/app/App.hs new file mode 100644 index 0000000..d5592c3 --- /dev/null +++ b/app/App.hs @@ -0,0 +1,19 @@ +module App where + +import Reflex +import Reflex.Dom.Core + +import Language.Javascript.JSaddle + +testWidget :: + ( DomBuilder t m + , DomBuilderSpace m ~ GhcjsDomSpace + , MonadHold t m + , PostBuild t m + ) => + m () +testWidget = elAttr "div" ("class" =: "content") do + text "hello, world!" + +start :: JSM () +start = mainWidget testWidget diff --git a/app/Main.hs b/app/Main.hs index 1dc21a2..7e21299 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,4 +1,12 @@ +{-# LANGUAGE CPP #-} + module Main (main) where +import App qualified +import Language.Javascript.JSaddle +import Language.Javascript.JSaddle.Wasm qualified as W + +foreign export javascript "hs_start" main :: IO () + main :: IO () -main = putStrLn "hi" +main = W.run $ App.start diff --git a/cabal.project b/cabal.project index 4ae0262..47cdaea 100644 --- a/cabal.project +++ b/cabal.project @@ -1,2 +1,4 @@ packages: ./numbersquare.cabal tests: True + +index-state: 2025-10-11T08:08:38Z diff --git a/flake.lock b/flake.lock index c6c4490..8805c35 100644 --- a/flake.lock +++ b/flake.lock @@ -16,13 +16,68 @@ "type": "github" } }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "ghc-wasm-meta": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + }, + "locked": { + "host": "gitlab.haskell.org", + "lastModified": 1775305067, + "narHash": "sha256-KFWRYVYPgsXu51stX/7/416qc31HFltfQiHPc6nEmH0=", + "owner": "haskell-wasm", + "repo": "ghc-wasm-meta", + "rev": "60098a5076557e327b326a1a3ba3b5fb4fec1e49", + "type": "gitlab" + }, + "original": { + "host": "gitlab.haskell.org", + "owner": "haskell-wasm", + "repo": "ghc-wasm-meta", + "type": "gitlab" + } + }, "nixpkgs": { "locked": { - "lastModified": 1777268161, - "narHash": "sha256-bxrdOn8SCOv8tN4JbTF/TXq7kjo9ag4M+C8yzzIRYbE=", + "lastModified": 1774399958, + "narHash": "sha256-Q+g1Np4wyNYpylt8RFM8UprAmyRoA3q3EZj7lQV+ZuQ=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "735a15e91bcb1b3e0883a91d3c9dfd4475d1bc54", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-25.11-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1777954456, + "narHash": "sha256-hGdgeU2Nk87RAuZyYjyDjFL6LK7dAZN5RE9+hrDTkDU=", "owner": "nixos", "repo": "nixpkgs", - "rev": "1c3fe55ad329cbcb28471bb30f05c9827f724c76", + "rev": "549bd84d6279f9852cae6225e372cc67fb91a4c1", "type": "github" }, "original": { @@ -35,7 +90,23 @@ "root": { "inputs": { "flake-compat": "flake-compat", - "nixpkgs": "nixpkgs" + "ghc-wasm-meta": "ghc-wasm-meta", + "nixpkgs": "nixpkgs_2" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" } } }, diff --git a/flake.nix b/flake.nix index afba6cb..285e15f 100644 --- a/flake.nix +++ b/flake.nix @@ -3,6 +3,8 @@ inputs = { nixpkgs.url = "github:nixos/nixpkgs?ref=nixos-unstable"; + ghc-wasm-meta.url = "gitlab:haskell-wasm/ghc-wasm-meta?host=gitlab.haskell.org"; + flake-compat = { url = "github:NixOS/flake-compat"; flake = false; @@ -10,11 +12,19 @@ }; outputs = - { self, nixpkgs, ... }: + { + self, + nixpkgs, + ghc-wasm-meta, + ... + }: let - pkgs = nixpkgs.legacyPackages.x86_64-linux; + pkgs = import nixpkgs { system = "x86_64-linux"; }; in { - devShells.x86_64-linux.default = pkgs.callPackage ./shell.nix { }; + devShells.x86_64-linux.default = pkgs.callPackage ./shell.nix { + wasm32-wasi-cabal = ghc-wasm-meta.packages.x86_64-linux.wasm32-wasi-cabal-9_12; + wasm32-wasi-ghc = ghc-wasm-meta.packages.x86_64-linux.wasm32-wasi-ghc-9_12; + }; }; } diff --git a/numbersquare.cabal b/numbersquare.cabal deleted file mode 100644 index 799db3b..0000000 --- a/numbersquare.cabal +++ /dev/null @@ -1,118 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.38.3. --- --- see: https://github.com/sol/hpack - -name: numbersquare -version: 0.1.0 -synopsis: a game where you number square -description: a game where you number square -category: Games -author: skulk -maintainer: skulk -license: BSD3 -license-file: LICENSE -build-type: Simple - -library - exposed-modules: - Game - Types.BoardAction - Types.BoardPosition - Types.GameBoard - Types.GameMode - Types.GameState - Types.Player - other-modules: - Paths_numbersquare - hs-source-dirs: - src - default-extensions: - ImportQualifiedPost - DataKinds - FlexibleInstances - MultiParamTypeClasses - TypeFamilies - UndecidableInstances - OverloadedLabels - NamedFieldPuns - TypeOperators - ghc-options: -Wall - build-depends: - array - , base ==4.* - , binary - , containers - , display - , extra - , mtl - , optics - , random - , text - default-language: Haskell2010 - -executable numbersquare - main-is: Main.hs - other-modules: - Paths_numbersquare - hs-source-dirs: - app - default-extensions: - ImportQualifiedPost - DataKinds - FlexibleInstances - MultiParamTypeClasses - TypeFamilies - UndecidableInstances - OverloadedLabels - NamedFieldPuns - TypeOperators - ghc-options: -Wall - build-depends: - array - , base ==4.* - , binary - , containers - , display - , extra - , mtl - , optics - , random - , text - default-language: Haskell2010 - -test-suite numberspec-test - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Spec - Paths_numbersquare - hs-source-dirs: - test - default-extensions: - ImportQualifiedPost - DataKinds - FlexibleInstances - MultiParamTypeClasses - TypeFamilies - UndecidableInstances - OverloadedLabels - NamedFieldPuns - TypeOperators - ghc-options: -Wall -threaded -O0 - build-depends: - QuickCheck - , array - , base ==4.* - , binary - , containers - , display - , extra - , hspec >=2.1.8 - , mtl - , numbersquare - , optics - , random - , text - default-language: Haskell2010 diff --git a/out/.gitignore b/out/.gitignore new file mode 100644 index 0000000..8ec536e --- /dev/null +++ b/out/.gitignore @@ -0,0 +1,2 @@ +*.wasm +ghc_wasm_jsffi.js \ No newline at end of file diff --git a/out/index.html b/out/index.html new file mode 100644 index 0000000..c13272c --- /dev/null +++ b/out/index.html @@ -0,0 +1,12 @@ + + + + WASM test + + + + + + + + diff --git a/out/index.js b/out/index.js new file mode 100644 index 0000000..99b5e82 --- /dev/null +++ b/out/index.js @@ -0,0 +1,28 @@ +import { WASI, OpenFile, File, ConsoleStdout } from "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.3.0/dist/index.js"; +import ghc_wasm_jsffi from "./ghc_wasm_jsffi.js" + +const args = []; +const env = ["GHCRTS=-H64m"]; +const fds = [ + new OpenFile(new File([])), // stdin + ConsoleStdout.lineBuffered((msg) => console.log(`[WASI stdout] ''${msg}`)), + ConsoleStdout.lineBuffered((msg) => console.warn(`[WASI stderr] ''${msg}`)), +]; +const options = { debug: false }; +const wasi = new WASI(args, env, fds, options); + +let __exports = {}; + +const { instance } = await WebAssembly.instantiateStreaming( + fetch("numbersquare.wasm"), + { + ghc_wasm_jsffi: ghc_wasm_jsffi(__exports), + wasi_snapshot_preview1: wasi.wasiImport, + } +); + +Object.assign(__exports, instance.exports); + +wasi.initialize(instance); +console.log(instance) +await instance.exports.hs_start(globalThis.example); diff --git a/package.yaml b/package.yaml index 05e7b0d..f35c41d 100644 --- a/package.yaml +++ b/package.yaml @@ -6,10 +6,11 @@ description: "a game where you number square" license: BSD3 author: skulk +language: GHC2021 ghc-options: "-Wall" dependencies: - - "base == 4.*" + - base - random - array - text @@ -30,6 +31,10 @@ default-extensions: - OverloadedLabels - NamedFieldPuns - TypeOperators + - BlockArguments + - OverloadedStrings + +build-type: Simple library: source-dirs: @@ -39,11 +44,27 @@ executable: source-dirs: - app main: Main.hs + dependencies: + - base + - reflex + - reflex-dom-core + - "ghcjs-dom == 0.9.*" + - jsaddle + - jsaddle-wasm + - ghc-experimental + when: + - condition: arch(wasm32) + ghc-options: + -no-hs-main + -optl-mexec-model=reactor + "-optl-Wl,--export=hs_start" + cpp-options: + -DWASM tests: numberspec-test: main: "Main.hs" - ghc-options: "-threaded -O0" + ghc-options: "-O0" source-dirs: - test diff --git a/shell.nix b/shell.nix index 00a07b7..4babaa2 100644 --- a/shell.nix +++ b/shell.nix @@ -1,29 +1,79 @@ { + callPackage, haskellPackages, haskell, zlib, watchexec, + wasm32-wasi-cabal, + wasm32-wasi-ghc, + writeShellApplication, + nodejs, + pkg-config, + python3, + fetchFromGitHub, }: -haskellPackages.developPackage { - name = "numbersquare"; - root = ./.; - modifier = - let - addBuildTools = - drv: - haskell.lib.addBuildTools drv ( - [ watchexec ] - ++ (with haskellPackages; [ - fourmolu - haskell-language-server - cabal-install - hpack - ghcid - cabal-fmt - hoogle - ]) - ); - addExtraLibraries = drv: haskell.lib.addExtraLibraries drv [ zlib ]; - in - drv: addExtraLibraries (addBuildTools drv); -} +let + # TODO: this information is duplicated at the bottom. need to fix that. + ghc-wasm-compat-rev = "ef21ada9436046c7b118314d0c73752253ec58e1"; + ghc-wasm-compat-src = fetchFromGitHub { + owner = "konn"; + repo = "ghc-wasm-earthly"; + rev = ghc-wasm-compat-rev; + hash = "sha256-oUf7HFLNxBZ/roFRe5q7Sz0D0ZRygu8prxEYoYuhSU8="; + }; +in +let + shell = haskellPackages.developPackage { + name = "numbersquare"; + root = ./.; + overrides = _: _: { + ghc-wasm-compat = + haskellPackages.callCabal2nix "ghc-wasm-compat" "${ghc-wasm-compat-src}/ghc-wasm-compat" + { }; + }; + modifier = + let + addBuildTools = + drv: + haskell.lib.addBuildTools drv ( + [ + watchexec + wasm32-wasi-cabal + wasm32-wasi-ghc + nodejs + pkg-config + (writeShellApplication { + name = "dev-server"; + text = '' + python -m http.server -d ./out + ''; + runtimeInputs = [ python3 ]; + }) + ] + ++ (with haskellPackages; [ + fourmolu + happy + haskell-language-server + cabal-install + hpack + ghcid + cabal-fmt + hoogle + ]) + ); + addExtraLibraries = drv: haskell.lib.addExtraLibraries drv [ zlib ]; + in + drv: addExtraLibraries (addBuildTools drv); + }; +in +shell.overrideAttrs (old: { + shellHook = (old.shellHook or "") + '' + cat > cabal.project.local < PlayerIndex -> BoardAction -> GameState mode -> GameState mode +makeMove (MkPlayerIndex idx) (SelectSquare topLeft bottomRight) state@MkGameState{board} = + let tiles = select topLeft bottomRight board + gMode = gameMode board + transform = + case check gMode tiles of + Just score -> + over (#players % (ix idx) % #score) (+ score) + -- invalid move, do nothing + Nothing -> id + in transform state diff --git a/src/Types/GameBoard.hs b/src/Types/GameBoard.hs index 8e158fc..da81c41 100644 --- a/src/Types/GameBoard.hs +++ b/src/Types/GameBoard.hs @@ -27,7 +27,7 @@ clear topLeft bottomRight gBoard@MkGameBoard{cells} = gBoard{cells = newCells} where newCells = cells // map (,Nothing) (range (topLeft, bottomRight)) -selectCheck :: (GameMode mode) => BoardPosition -> BoardPosition -> GameBoard mode -> Bool +selectCheck :: (GameMode mode) => BoardPosition -> BoardPosition -> GameBoard mode -> Maybe Int selectCheck topLeft bottomRight board@MkGameBoard{gameMode} = check gameMode (select topLeft bottomRight board) diff --git a/src/Types/GameMode.hs b/src/Types/GameMode.hs index 994837b..976b1e5 100644 --- a/src/Types/GameMode.hs +++ b/src/Types/GameMode.hs @@ -8,7 +8,6 @@ import Data.Bifunctor (Bifunctor (first)) import Data.Kind (Type) import Display import System.Random.Stateful (Random (randomR), RandomGen) -import Types.BoardPosition {- | The type of game that is being played. @@ -19,7 +18,7 @@ that sums up to 'n'. -} class (Display (Tile t), Show (Tile t), Eq (Tile t), Eq t, Show t) => GameMode t where data Tile t :: Type - check :: t -> [Tile t] -> Bool + check :: t -> [Tile t] -> Maybe Int gen :: (RandomGen g) => t -> g -> (Tile t, g) data SumTo = MkSumTo Int @@ -28,8 +27,8 @@ data SumTo = MkSumTo Int instance GameMode SumTo where data Tile SumTo = IntTile Int deriving (Eq, Show) - check (MkSumTo n) [] = n == 0 - check (MkSumTo n) lst = n == sum (map toInt lst) + check (MkSumTo n) [] = if n == 0 then Just 0 else Nothing + check (MkSumTo n) lst = if n == sum (map toInt lst) then Just (length lst) else Nothing where toInt (IntTile a) = a gen (MkSumTo n) = first IntTile . randomR (1, n) diff --git a/src/Types/GameState.hs b/src/Types/GameState.hs index a342625..6f70477 100644 --- a/src/Types/GameState.hs +++ b/src/Types/GameState.hs @@ -26,12 +26,3 @@ newGame gmode playerInfos rng = let (initialBoard, nextRng) = newRandomBoard gmode 10 10 rng playerStates = S.fromList $ map (\n -> MkPlayerState{name = n, score = 0}) playerInfos in (MkGameState initialBoard playerStates, nextRng) - -makeMove :: (GameMode mode) => PlayerIndex -> BoardAction -> GameState mode -> GameState mode -makeMove (MkPlayerIndex idx) (SelectSquare topLeft bottomRight) state@MkGameState{board} = - let tiles = select topLeft bottomRight board - gMode = gameMode board - in if check gMode tiles - then - over (#players % (ix idx) % #score) (+ 1) state - else state diff --git a/test/Spec.hs b/test/Spec.hs index 01c162e..78a9381 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,30 +4,65 @@ module Spec where import Data.Array (array, elems) +import Data.Sequence qualified as S import Display (displayText) +import Game +import Optics import Test.Hspec +import Types.BoardAction import Types.GameBoard import Types.GameMode (SumTo (MkSumTo), Tile (IntTile)) +import Types.GameState +import Types.Player spec :: Spec -spec = describe "gameboard" do - let tiles = - array - ((0, 0), (1, 1)) - [ ((0, 0), Just $ IntTile 1) - , ((0, 1), Just $ IntTile 2) - , ((1, 0), Just $ IntTile 3) - , ((1, 1), Just $ IntTile 4) - ] - gameBoard = MkGameBoard{width = 2, height = 2, gameMode = MkSumTo 10, cells = tiles} +spec = do + describe "gameboard" do + let tiles = + array + ((0, 0), (1, 1)) + [ ((0, 0), Just $ IntTile 1) + , ((0, 1), Just $ IntTile 2) + , ((1, 0), Just $ IntTile 3) + , ((1, 1), Just $ IntTile 4) + ] + gameBoard = MkGameBoard{width = 2, height = 2, gameMode = MkSumTo 10, cells = tiles} - it "displays correctly" do - displayText gameBoard `shouldBe` "1 2 \n3 4 \n" + it "displays correctly" do + displayText gameBoard `shouldBe` "1 2 \n3 4 \n" - it "validates a move" do - selectCheck (0, 0) (1, 1) gameBoard `shouldBe` True - selectCheck (0, 0) (0, 1) gameBoard `shouldBe` False + it "validates a move" do + selectCheck (0, 0) (1, 1) gameBoard `shouldBe` Just 4 + selectCheck (0, 0) (0, 1) gameBoard `shouldBe` Nothing - it "clears properly" do - let cleared = clear (0, 0) (0, 1) gameBoard - elems (cells cleared) `shouldBe` [Nothing, Nothing, Just $ IntTile 3, Just $ IntTile 4] + it "clears properly" do + let cleared = clear (0, 0) (0, 1) gameBoard + elems (cells cleared) `shouldBe` [Nothing, Nothing, Just $ IntTile 3, Just $ IntTile 4] + + describe "player moves" do + let tiles = + array + ((0, 0), (1, 1)) + [ ((0, 0), Just $ IntTile 5) + , ((0, 1), Just $ IntTile 5) + , ((1, 0), Just $ IntTile 1) + , ((1, 1), Just $ IntTile 2) + ] + gameBoard = MkGameBoard{width = 2, height = 2, gameMode = MkSumTo 10, cells = tiles} + initialState = MkGameState{board = gameBoard, players = S.fromList [MkPlayerState (MkPlayerName "P1") 0]} + + it "increases score if sum equals target" do + let action = SelectSquare (0, 0) (0, 1) + newState = makeMove (MkPlayerIndex 0) action initialState + + preview (#players % ix 0 % #score) newState `shouldBe` Just 2 + + it "does not increase score if sum does not equal target" do + let invalidAction = SelectSquare (0, 0) (1, 0) + newState = makeMove (MkPlayerIndex 0) invalidAction initialState + preview (#players % ix 0 % #score) newState `shouldBe` Just 0 + + it "does not change anything if invalid player index is provided" do + let action = SelectSquare (0, 0) (0, 1) + newState = makeMove (MkPlayerIndex 99) action initialState + preview (#players % ix 99 % #score) newState `shouldBe` Nothing