Compare commits

..

No commits in common. "77ee0c0abb384cdedc9b922d969e817558a79bde" and "c8e43990ed105d1ec43ab5d705078976281b9aeb" have entirely different histories.

19 changed files with 184 additions and 357 deletions

3
.gitignore vendored
View file

@ -1,4 +1,3 @@
dist-newstyle
.direnv
*.cabal
cabal.project.local
*.cabal

View file

@ -1,15 +0,0 @@
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

View file

@ -1,9 +0,0 @@
#+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

View file

@ -1,19 +0,0 @@
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

View file

@ -1,12 +1,4 @@
{-# 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 = W.run $ App.start
main = putStrLn "hi"

View file

@ -1,4 +1,2 @@
packages: ./numbersquare.cabal
tests: True
index-state: 2025-10-11T08:08:38Z

79
flake.lock generated
View file

@ -16,68 +16,13 @@
"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": 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=",
"lastModified": 1777268161,
"narHash": "sha256-bxrdOn8SCOv8tN4JbTF/TXq7kjo9ag4M+C8yzzIRYbE=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "549bd84d6279f9852cae6225e372cc67fb91a4c1",
"rev": "1c3fe55ad329cbcb28471bb30f05c9827f724c76",
"type": "github"
},
"original": {
@ -90,23 +35,7 @@
"root": {
"inputs": {
"flake-compat": "flake-compat",
"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"
"nixpkgs": "nixpkgs"
}
}
},

View file

@ -3,8 +3,6 @@
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;
@ -12,19 +10,11 @@
};
outputs =
{
self,
nixpkgs,
ghc-wasm-meta,
...
}:
{ self, nixpkgs, ... }:
let
pkgs = import nixpkgs { system = "x86_64-linux"; };
pkgs = nixpkgs.legacyPackages.x86_64-linux;
in
{
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;
};
devShells.x86_64-linux.default = pkgs.callPackage ./shell.nix { };
};
}

118
numbersquare.cabal Normal file
View file

@ -0,0 +1,118 @@
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

2
out/.gitignore vendored
View file

@ -1,2 +0,0 @@
*.wasm
ghc_wasm_jsffi.js

View file

@ -1,12 +0,0 @@
<!DOCTYPE HTML>
<html lang="en">
<head>
<title>WASM test</title>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
</head>
<body>
<script src="./index.js" type="module"></script>
</body>
</html>

View file

@ -1,28 +0,0 @@
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);

View file

@ -6,11 +6,10 @@ description: "a game where you number square"
license: BSD3
author: skulk
language: GHC2021
ghc-options: "-Wall"
dependencies:
- base
- "base == 4.*"
- random
- array
- text
@ -31,10 +30,6 @@ default-extensions:
- OverloadedLabels
- NamedFieldPuns
- TypeOperators
- BlockArguments
- OverloadedStrings
build-type: Simple
library:
source-dirs:
@ -44,27 +39,11 @@ 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: "-O0"
ghc-options: "-threaded -O0"
source-dirs:
- test

View file

@ -1,79 +1,29 @@
{
callPackage,
haskellPackages,
haskell,
zlib,
watchexec,
wasm32-wasi-cabal,
wasm32-wasi-ghc,
writeShellApplication,
nodejs,
pkg-config,
python3,
fetchFromGitHub,
}:
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 <<EOF
source-repository-package
type: git
location: https://github.com/konn/ghc-wasm-earthly
tag: ${ghc-wasm-compat-rev}
subdir: ghc-wasm-compat
EOF
'';
})
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);
}

View file

@ -1,19 +1 @@
module Game where
import Optics
import Types.BoardAction
import Types.GameBoard
import Types.GameMode
import Types.GameState
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
transform =
case check gMode tiles of
Just score ->
over (#players % (ix idx) % #score) (+ score)
-- invalid move, do nothing
Nothing -> id
in transform state

View file

@ -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 -> Maybe Int
selectCheck :: (GameMode mode) => BoardPosition -> BoardPosition -> GameBoard mode -> Bool
selectCheck topLeft bottomRight board@MkGameBoard{gameMode} =
check gameMode (select topLeft bottomRight board)

View file

@ -8,6 +8,7 @@ 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.
@ -18,7 +19,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] -> Maybe Int
check :: t -> [Tile t] -> Bool
gen :: (RandomGen g) => t -> g -> (Tile t, g)
data SumTo = MkSumTo Int
@ -27,8 +28,8 @@ data SumTo = MkSumTo Int
instance GameMode SumTo where
data Tile SumTo = IntTile Int deriving (Eq, Show)
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
check (MkSumTo n) [] = n == 0
check (MkSumTo n) lst = n == sum (map toInt lst)
where
toInt (IntTile a) = a
gen (MkSumTo n) = first IntTile . randomR (1, n)

View file

@ -26,3 +26,12 @@ 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

View file

@ -4,65 +4,30 @@
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 = 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}
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}
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` Just 4
selectCheck (0, 0) (0, 1) gameBoard `shouldBe` Nothing
it "validates a move" do
selectCheck (0, 0) (1, 1) gameBoard `shouldBe` True
selectCheck (0, 0) (0, 1) gameBoard `shouldBe` False
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
it "clears properly" do
let cleared = clear (0, 0) (0, 1) gameBoard
elems (cells cleared) `shouldBe` [Nothing, Nothing, Just $ IntTile 3, Just $ IntTile 4]