From 0fe8205ed9cd54505330f1cbd72d3c445a1d1e91 Mon Sep 17 00:00:00 2001 From: Sidharth Kulkarni Date: Sat, 2 May 2026 18:00:08 -0700 Subject: [PATCH] Implement basic board types/functions --- package.yaml | 10 +++++-- src/Game.hs | 13 ++++---- src/Types.hs | 19 ------------ src/Types/BoardPosition.hs | 3 ++ src/Types/GameBoard.hs | 61 ++++++++++++++++++++++++++++++++++++++ src/Types/GameMode.hs | 37 +++++++++++++++++++++++ test/Main.hs | 7 +++++ test/Spec.hs | 25 ++++++++++++---- 8 files changed, 140 insertions(+), 35 deletions(-) delete mode 100644 src/Types.hs create mode 100644 src/Types/BoardPosition.hs create mode 100644 src/Types/GameBoard.hs create mode 100644 src/Types/GameMode.hs create mode 100644 test/Main.hs diff --git a/package.yaml b/package.yaml index 34028cc..bdc8f17 100644 --- a/package.yaml +++ b/package.yaml @@ -13,6 +13,10 @@ dependencies: - random - array - text + - mtl + - extra + - display + - binary library: source-dirs: @@ -24,13 +28,13 @@ executable: main: Main.hs tests: - spec: - main: "Spec.hs" + numberspec-test: + main: "Main.hs" ghc-options: "-threaded -O0" source-dirs: - - src - test dependencies: - hspec >= 2.1.8 - QuickCheck + - numbersquare diff --git a/src/Game.hs b/src/Game.hs index 441a2e4..6b0bd67 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -1,7 +1,8 @@ module Game where import Data.Text -import Types +import Types.GameBoard +import Types.GameMode (GameMode) newtype PlayerName = MkPlayerName Text deriving (Eq, Show, Ord) @@ -12,14 +13,10 @@ data PlayerState = MkPlayerState } deriving (Eq, Show) -data GameState = MkGameState - { board :: GameBoard +data GameState mode = MkGameState + { board :: GameBoard mode , players :: PlayerState } - deriving (Eq, Show) -newRandomBoard :: Int -> Int -> IO GameBoard -newRandomBoard width height = undefined - -newGame :: [PlayerName] -> IO GameState +newGame :: (GameMode mode) => mode -> [PlayerName] -> IO (GameState mode) newGame = undefined diff --git a/src/Types.hs b/src/Types.hs deleted file mode 100644 index cd2871d..0000000 --- a/src/Types.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - -module Types where - -import Data.Array -import Data.Array.Base (genArray) - -data GameBoard = MkGameBoard - { width :: Int - , height :: Int - , board :: Array (Int, Int) (Maybe Int) - } - deriving (Show, Eq) - -mkEmptyBoard :: Int -> Int -> GameBoard -mkEmptyBoard width height = MkGameBoard{width, height, board} - where - board :: Array (Int, Int) (Maybe Int) - board = genArray ((0, 0), (width - 1, height - 1)) (const Nothing) diff --git a/src/Types/BoardPosition.hs b/src/Types/BoardPosition.hs new file mode 100644 index 0000000..ba2a855 --- /dev/null +++ b/src/Types/BoardPosition.hs @@ -0,0 +1,3 @@ +module Types.BoardPosition where + +type BoardPosition = (Int, Int) diff --git a/src/Types/GameBoard.hs b/src/Types/GameBoard.hs new file mode 100644 index 0000000..6f8b23d --- /dev/null +++ b/src/Types/GameBoard.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module Types.GameBoard where + +import Data.Array +import Data.Binary.Builder (append) +import Data.Maybe (mapMaybe) +import Display (Display, display) +import System.Random.Stateful (RandomGen) +import Types.BoardPosition +import Types.GameMode + +data GameBoard mode = MkGameBoard + { width :: Int + , height :: Int + , board :: Array BoardPosition (Maybe (Tile mode)) + , gameMode :: mode + } + +clear :: (GameMode mode) => GameBoard mode -> BoardPosition -> BoardPosition -> Bool +clear = undefined + +selectCheck :: (GameMode mode) => GameBoard mode -> BoardPosition -> BoardPosition -> Bool +selectCheck board@MkGameBoard{gameMode} topLeft bottomRight = + check gameMode (select board topLeft bottomRight) + +select :: (GameMode mode) => GameBoard mode -> BoardPosition -> BoardPosition -> [Tile mode] +select MkGameBoard{board} topLeft bottomRight = + mapMaybe (board !) (range (topLeft, bottomRight)) + +-- TODO: rewrite this with monadic RNG +newRandomBoard :: (RandomGen g, GameMode mode) => g -> mode -> Int -> Int -> (GameBoard mode, g) +newRandomBoard rng gameMode width height = + (MkGameBoard{width, height, gameMode, board = array (low, high) cellAssocList}, nextRng) + where + low = (0, 0) + high = (width - 1, height - 1) + (cellAssocList, nextRng) = + foldl' + ( \(cur, rng') -> \ix -> + let (res, next) = gen gameMode rng' in ((ix, Just res) : cur, next) + ) + ([], rng) + ixs + ixs = range (low, high) + +instance (Display (Tile mode)) => Display (GameBoard mode) where + display MkGameBoard{width, height, board} = + foldl' (\c -> \row -> c `append` displayRow row `append` "\n") "" [0 .. height - 1] + where + displayCell row col = case board ! (row, col) of Nothing -> " "; Just t -> display t + displayRow row = + foldl' + ( \c -> \col -> + c `append` (displayCell row col) `append` " " + ) + "" + [0 .. width - 1] diff --git a/src/Types/GameMode.hs b/src/Types/GameMode.hs new file mode 100644 index 0000000..712292d --- /dev/null +++ b/src/Types/GameMode.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Types.GameMode where + +import Data.Bifunctor (Bifunctor (first)) +import Data.Kind (Type) +import Display +import System.Random.Stateful (Random (randomR), RandomGen) + +{- | The type of game that is being played. + +This typeclass carries information about how to check whether a set +of elements satisfies the condition for a valid move. For example, +in the 'SumTo n' mode, a valid move is a set of elements (Ints) +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 + gen :: (RandomGen g) => t -> g -> (Tile t, g) + +data SumTo = MkSumTo Int + deriving (Show, Eq) + +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) + where + toInt (IntTile a) = a + gen (MkSumTo n) = first IntTile . randomR (1, n) + +instance Display (Tile SumTo) where + display (IntTile x) = display x diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..2cef9db --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Spec +import Test.Hspec + +main :: IO () +main = hspec spec diff --git a/test/Spec.hs b/test/Spec.hs index 514babd..43b348d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,24 @@ -module Main where +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +module Spec where + +import Data.Array (array) +import Display (Display (display), displayText) import Test.Hspec +import Types.GameBoard +import Types.GameMode (SumTo (MkSumTo), Tile (IntTile)) spec :: Spec -spec = undefined - -main :: IO () -main = hspec spec +spec = describe "gameboard" do + it "displays correctly" 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, board = tiles} + displayText gameBoard `shouldBe` "1 2 \n3 4 \n"