Implement basic board types/functions

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

src/Types.hs

@@ -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)

src/Types/BoardPosition.hs

@@ -0,0 +1,3 @@
+module Types.BoardPosition where
+
+type BoardPosition = (Int, Int)

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]

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