Compare commits

..

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

19 changed files with 184 additions and 357 deletions

1
.gitignore vendored
View file

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

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 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 :: IO ()
main = W.run $ App.start main = putStrLn "hi"

View file

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

79
flake.lock generated
View file

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

View file

@ -3,8 +3,6 @@
inputs = { inputs = {
nixpkgs.url = "github:nixos/nixpkgs?ref=nixos-unstable"; nixpkgs.url = "github:nixos/nixpkgs?ref=nixos-unstable";
ghc-wasm-meta.url = "gitlab:haskell-wasm/ghc-wasm-meta?host=gitlab.haskell.org";
flake-compat = { flake-compat = {
url = "github:NixOS/flake-compat"; url = "github:NixOS/flake-compat";
flake = false; flake = false;
@ -12,19 +10,11 @@
}; };
outputs = outputs =
{ { self, nixpkgs, ... }:
self,
nixpkgs,
ghc-wasm-meta,
...
}:
let let
pkgs = import nixpkgs { system = "x86_64-linux"; }; pkgs = nixpkgs.legacyPackages.x86_64-linux;
in 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;
};
}; };
} }

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 license: BSD3
author: skulk author: skulk
language: GHC2021
ghc-options: "-Wall" ghc-options: "-Wall"
dependencies: dependencies:
- base - "base == 4.*"
- random - random
- array - array
- text - text
@ -31,10 +30,6 @@ default-extensions:
- OverloadedLabels - OverloadedLabels
- NamedFieldPuns - NamedFieldPuns
- TypeOperators - TypeOperators
- BlockArguments
- OverloadedStrings
build-type: Simple
library: library:
source-dirs: source-dirs:
@ -44,27 +39,11 @@ executable:
source-dirs: source-dirs:
- app - app
main: Main.hs 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: tests:
numberspec-test: numberspec-test:
main: "Main.hs" main: "Main.hs"
ghc-options: "-O0" ghc-options: "-threaded -O0"
source-dirs: source-dirs:
- test - test

View file

@ -1,58 +1,20 @@
{ {
callPackage,
haskellPackages, haskellPackages,
haskell, haskell,
zlib, zlib,
watchexec, watchexec,
wasm32-wasi-cabal,
wasm32-wasi-ghc,
writeShellApplication,
nodejs,
pkg-config,
python3,
fetchFromGitHub,
}: }:
let haskellPackages.developPackage {
# 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"; name = "numbersquare";
root = ./.; root = ./.;
overrides = _: _: {
ghc-wasm-compat =
haskellPackages.callCabal2nix "ghc-wasm-compat" "${ghc-wasm-compat-src}/ghc-wasm-compat"
{ };
};
modifier = modifier =
let let
addBuildTools = addBuildTools =
drv: drv:
haskell.lib.addBuildTools drv ( haskell.lib.addBuildTools drv (
[ [ watchexec ]
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; [ ++ (with haskellPackages; [
fourmolu fourmolu
happy
haskell-language-server haskell-language-server
cabal-install cabal-install
hpack hpack
@ -64,16 +26,4 @@ let
addExtraLibraries = drv: haskell.lib.addExtraLibraries drv [ zlib ]; addExtraLibraries = drv: haskell.lib.addExtraLibraries drv [ zlib ];
in in
drv: addExtraLibraries (addBuildTools drv); 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
'';
})

View file

@ -1,19 +1 @@
module Game where 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 where
newCells = cells // map (,Nothing) (range (topLeft, bottomRight)) 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} = selectCheck topLeft bottomRight board@MkGameBoard{gameMode} =
check gameMode (select topLeft bottomRight board) check gameMode (select topLeft bottomRight board)

View file

@ -8,6 +8,7 @@ import Data.Bifunctor (Bifunctor (first))
import Data.Kind (Type) import Data.Kind (Type)
import Display import Display
import System.Random.Stateful (Random (randomR), RandomGen) import System.Random.Stateful (Random (randomR), RandomGen)
import Types.BoardPosition
{- | The type of game that is being played. {- | 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 class (Display (Tile t), Show (Tile t), Eq (Tile t), Eq t, Show t) => GameMode t where
data Tile t :: Type data Tile t :: Type
check :: t -> [Tile t] -> Maybe Int check :: t -> [Tile t] -> Bool
gen :: (RandomGen g) => t -> g -> (Tile t, g) gen :: (RandomGen g) => t -> g -> (Tile t, g)
data SumTo = MkSumTo Int data SumTo = MkSumTo Int
@ -27,8 +28,8 @@ data SumTo = MkSumTo Int
instance GameMode SumTo where instance GameMode SumTo where
data Tile SumTo = IntTile Int deriving (Eq, Show) data Tile SumTo = IntTile Int deriving (Eq, Show)
check (MkSumTo n) [] = if n == 0 then Just 0 else Nothing check (MkSumTo n) [] = n == 0
check (MkSumTo n) lst = if n == sum (map toInt lst) then Just (length lst) else Nothing check (MkSumTo n) lst = n == sum (map toInt lst)
where where
toInt (IntTile a) = a toInt (IntTile a) = a
gen (MkSumTo n) = first IntTile . randomR (1, n) 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 let (initialBoard, nextRng) = newRandomBoard gmode 10 10 rng
playerStates = S.fromList $ map (\n -> MkPlayerState{name = n, score = 0}) playerInfos playerStates = S.fromList $ map (\n -> MkPlayerState{name = n, score = 0}) playerInfos
in (MkGameState initialBoard playerStates, nextRng) 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,20 +4,13 @@
module Spec where module Spec where
import Data.Array (array, elems) import Data.Array (array, elems)
import Data.Sequence qualified as S
import Display (displayText) import Display (displayText)
import Game
import Optics
import Test.Hspec import Test.Hspec
import Types.BoardAction
import Types.GameBoard import Types.GameBoard
import Types.GameMode (SumTo (MkSumTo), Tile (IntTile)) import Types.GameMode (SumTo (MkSumTo), Tile (IntTile))
import Types.GameState
import Types.Player
spec :: Spec spec :: Spec
spec = do spec = describe "gameboard" do
describe "gameboard" do
let tiles = let tiles =
array array
((0, 0), (1, 1)) ((0, 0), (1, 1))
@ -32,37 +25,9 @@ spec = do
displayText gameBoard `shouldBe` "1 2 \n3 4 \n" displayText gameBoard `shouldBe` "1 2 \n3 4 \n"
it "validates a move" do it "validates a move" do
selectCheck (0, 0) (1, 1) gameBoard `shouldBe` Just 4 selectCheck (0, 0) (1, 1) gameBoard `shouldBe` True
selectCheck (0, 0) (0, 1) gameBoard `shouldBe` Nothing selectCheck (0, 0) (0, 1) gameBoard `shouldBe` False
it "clears properly" do it "clears properly" do
let cleared = clear (0, 0) (0, 1) gameBoard let cleared = clear (0, 0) (0, 1) gameBoard
elems (cells cleared) `shouldBe` [Nothing, Nothing, Just $ IntTile 3, Just $ IntTile 4] 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