boardgame (empty) → 0.0.0.1
raw patch · 20 files changed
+2330/−0 lines, 20 filesdep +aesondep +asterius-preludedep +basesetup-changed
Dependencies added: aeson, asterius-prelude, base, boardgame, containers, scientific, vector
Files
- CHANGELOG.md +0/−0
- LICENSE +22/−0
- Setup.hs +2/−0
- boardgame.cabal +73/−0
- executable/ArithmeticProgressionGame.hs +59/−0
- executable/ConnectFour.hs +111/−0
- executable/Cross.hs +106/−0
- executable/Gale.hs +85/−0
- executable/Havannah.hs +82/−0
- executable/Hex.hs +158/−0
- executable/MNKGame.hs +102/−0
- executable/Main.hs +96/−0
- executable/ShannonSwitchingGame.hs +204/−0
- executable/TicTacToe.hs +96/−0
- executable/Y.hs +89/−0
- executable/Yavalath.hs +84/−0
- src/Boardgame.hs +451/−0
- src/Boardgame/ColoredGraph.hs +396/−0
- src/Boardgame/Web.hs +110/−0
- tests/BoardgameTest.hs +4/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,22 @@+MIT License + +Copyright (c) 2021 Jennifer Krogh, Mattias Mattsson, Emma Pettersson, +Simon Sundqvist, Carl Wiede, and Mårten Åsberg + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ boardgame.cabal view
@@ -0,0 +1,73 @@+cabal-version: >=1.10 +name: boardgame +version: 0.0.0.1 +synopsis: Modeling boardgames +description: + A library with the basis for modeling and playing boardgames. Comes with + built-in functions for playing games through a web interface (requires WASM + compilation). +homepage: https://github.com/Boardgame-DSL/boardgame +bug-reports: https://github.com/Boardgame-DSL/boardgame/issues +license: MIT +license-file: LICENSE +maintainer: Mårten Åsberg <marten.asberg@outlook.com> +category: Model, Game +build-type: Simple +extra-source-files: CHANGELOG.md + +flag wasm + description: Eanbles builds targeting WASM. + default: False + manual: True + +library + exposed-modules: Boardgame, Boardgame.ColoredGraph + build-depends: + base >= 4.12 && < 5.0 + , containers >= 0.5 && < 0.7 + hs-source-dirs: src + default-language: Haskell2010 + if flag(wasm) + exposed-modules: Boardgame.Web + build-depends: + aeson >= 1.4 && < 1.6 + , asterius-prelude == 0.0.1 + , scientific >= 0.3 && < 0.4 + CPP-options: "-DWASM" + +executable boardgame + main-is: Main.hs + other-modules: + ArithmeticProgressionGame + , ConnectFour + , Cross + , Gale + , Havannah + , Hex + , MNKGame + , ShannonSwitchingGame + , TicTacToe + , Y + , Yavalath + build-depends: + base >= 4.12 && < 5.0 + , boardgame + , containers >= 0.5 && < 0.7 + hs-source-dirs: executable + default-language: Haskell2010 + if flag(wasm) + build-depends: + aeson >= 1.4 && < 1.6 + , vector >= 0.12 && < 0.13 + CPP-options: "-DWASM" + +test-suite boardgame-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: BoardgameTest.hs + build-depends: base >= 4.12 && < 5.0 + +source-repository head + type: git + location: git://github.com/Boardgame-DSL/boardgame.git
+ executable/ArithmeticProgressionGame.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module ArithmeticProgressionGame where + +import Data.List (intercalate) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , patternMatchingGameOver + ) + +#ifdef WASM +import Data.Aeson ( + ToJSON(..) + , object + , (.=) + ) +#endif + +------------------------------------------------------------------------------- +-- * Arithmetic Progression Game +------------------------------------------------------------------------------- + +data ArithmeticProgressionGame = ArithmeticProgressionGame Int [Position] + +createArithmeticProgressionGame :: Int -> Int -> Maybe ArithmeticProgressionGame +createArithmeticProgressionGame n k = if k < n + then Just $ ArithmeticProgressionGame k (replicate n Empty) + else Nothing + +instance Show ArithmeticProgressionGame where + show (ArithmeticProgressionGame _ ps) = (\(is, ps) -> intercalate "," is ++ "\n" ++ intercalate "," ps) $ + unzip $ zipWith (\i p -> (pad $ show i, pad $ showP p)) [1..] ps + where + showP Empty = " _" + showP (Occupied Player1) = " \ESC[34mO\ESC[0m" + showP (Occupied Player2) = " \ESC[31mX\ESC[0m" + pad x = replicate (3 - length x) ' ' ++ x + +#ifdef WASM +instance ToJSON ArithmeticProgressionGame where + toJSON (ArithmeticProgressionGame n ps) = object [ + "n" .= toJSON n + , "positions" .= toJSON ps + ] +#endif + +instance PositionalGame ArithmeticProgressionGame Int where + positions (ArithmeticProgressionGame _ l) = l + getPosition (ArithmeticProgressionGame _ l) i = if i <= length l then Just $ l !! (i - 1) else Nothing + setPosition (ArithmeticProgressionGame k l) i p = if i <= length l + then Just $ ArithmeticProgressionGame k (take (i - 1) l ++ p : drop i l) + else Nothing + gameOver a@(ArithmeticProgressionGame k l) = let n = length l + in patternMatchingGameOver (filter (all (<= n)) $ concat [[take k [i,i+j..] | j <- [1..n-i]] | i <- [1..n]]) a
+ executable/ConnectFour.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module ConnectFour where + +import Prelude hiding (lookup) + +import Data.Map ( + Map + , lookup + , member + , adjust + ) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , mapPosition + , criteria + , isOccupied + , nextPlayer + , drawIf + , symmetric + , unless + , player1WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , values + , mapValues + , mapEdges + , filterValues + , rectOctGraph + , inARow + , filterEdges + ) + +#ifdef WASM +import Data.Aeson ( + ToJSON(..) + , object + , (.=) + ) +#endif + +------------------------------------------------------------------------------- +-- * Connect Four +------------------------------------------------------------------------------- + +data ConnectFour = ConnectFour Int (ColoredGraph (Int, Int) Position String) + +instance Show ConnectFour where + show (ConnectFour k b) = show b + +#ifdef WASM +instance ToJSON ConnectFour where + toJSON (ConnectFour k b) = object [ + "k" .= toJSON k + , "board" .= toJSON b + ] +#endif + +instance PositionalGame ConnectFour (Int, Int) where + positions (ConnectFour k b) = values b + getPosition (ConnectFour k b) c = fst <$> lookup c b + setPosition (ConnectFour k b) c p = if member c b + then Just $ ConnectFour k $ adjust (\(_, xs) -> (p, xs)) c b + else Nothing + makeMove = cfMove + + gameOver (ConnectFour k b) = criterion b + where + criterion = + drawIf (all isOccupied . values) `unless` -- It's a draw if all tiles are owned. + -- Here we say that in any position where one player wins, + -- the other player would win instead if the pieces were swapped. + symmetric (mapValues $ mapPosition nextPlayer) + -- Player1 wins if there are k or more pieces in a row in any direction. + (criteria (player1WinsWhen . inARow (>=k) <$> directions) . filterValues (== Occupied Player1)) + + directions = ["vertical", "horizontal", "diagonal1", "diagonal2"] + +-- Restrict move for Connect Four. +-- Move is only valid if the positon is empty and the position below is occupied. +cfMove :: ConnectFour -> Player -> (Int, Int) -> Maybe ConnectFour +cfMove a p coord = case getPosition a coord of + -- If we are at bottom row, we can place the piece there. + Just Empty -> if ((fst coord) == 0) + then setPosition a coord (Occupied p) + -- Not at bottom row, check to see if position below has been filled. + else case getPosition a ((fst coord) -1, snd coord) of + Just Empty -> Nothing + _ -> setPosition a coord (Occupied p) + _ -> Nothing + +emptyConnectFour :: Int -> Int -> Int -> ConnectFour +emptyConnectFour m n k = ConnectFour k $ mapEdges dirName $ rectOctGraph m n + where + dirName (1,0) = "horizontal" + dirName (-1,0) = "horizontal" + dirName (0,-1) = "vertical" + dirName (0,1) = "vertical" + dirName (1,-1) = "diagonal1" + dirName (-1,1) = "diagonal1" + dirName (1,1) = "diagonal2" + dirName (-1,-1) = "diagonal2"
+ executable/Cross.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Cross where + +import Data.List (intersect) +import Prelude hiding (lookup) + +import Data.Map ( + Map + , elems + , keys + , lookup + , member + , adjust + ) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , mapPosition + , isOccupied + , takeEmptyMakeMove + , nextPlayer + , drawIf + , criteria + , symmetric + , unless + , player1LosesWhen + , player1WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , values + , mapValues + , anyConnections + , filterValues + , filterG + , hexHexGraph + ) + +#ifdef WASM +import Data.Aeson (ToJSON(..)) +#endif + +------------------------------------------------------------------------------- +-- * Cross +------------------------------------------------------------------------------- + +newtype Cross = Cross (ColoredGraph (Int, Int) Position (Int, Int)) + +instance Show Cross where + show (Cross b) = show b + +#ifdef WASM +instance ToJSON Cross where + toJSON (Cross b) = toJSON b +#endif + +instance PositionalGame Cross (Int, Int) where + positions (Cross b) = values b + getPosition (Cross b) c = fst <$> lookup c b + setPosition (Cross b) c p = if member c b + then Just $ Cross $ adjust (\(_, xs) -> (p, xs)) c b + else Nothing + makeMove = takeEmptyMakeMove + + gameOver (Cross b) = criterion b + where + criterion = + drawIf (all isOccupied . values) `unless` -- It's a draw if all tiles are owned. + -- Here we say that in any position where one player wins, + -- the other player would win instead if the pieces were swapped. + symmetric (mapValues $ mapPosition nextPlayer) + (criteria (player1LosesWhen <$> -- you lose if you have connected 2 opposite sides. + [ anyConnections (==2) [side1, side4] . filterValues (== Occupied Player1) + , anyConnections (==2) [side2, side5] . filterValues (== Occupied Player1) + , anyConnections (==2) [side3, side6] . filterValues (== Occupied Player1) + ]) `unless` + criteria (player1WinsWhen <$> -- you win if you have connected 3 non-adjacent sides. + [ anyConnections (==3) [side1, side3, side5] . filterValues (== Occupied Player1) + , anyConnections (==3) [side2, side4, side6] . filterValues (== Occupied Player1) + ])) + + dirs = + [ (1, 0) + , (1, -1) + , (0, -1) + , (-1, 0) + , (-1, 1) + , (0, 1) + ] + emptyNeighbours xs = keys $ filterG (null . intersect xs . elems . snd) b + + side1 = emptyNeighbours [dirs !! 0, dirs !! 1] + side2 = emptyNeighbours [dirs !! 1, dirs !! 2] + side3 = emptyNeighbours [dirs !! 2, dirs !! 3] + side4 = emptyNeighbours [dirs !! 3, dirs !! 4] + side5 = emptyNeighbours [dirs !! 4, dirs !! 5] + side6 = emptyNeighbours [dirs !! 5, dirs !! 0] + +emptyCross :: Int -> Cross +emptyCross = Cross . hexHexGraph
+ executable/Gale.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Gale where + +import Data.Graph as Graph (Graph, buildG, path) +import Data.List (intercalate) +import Data.Maybe (fromJust, mapMaybe) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + ) + +import ShannonSwitchingGame +#ifdef WASM +import Data.Aeson (ToJSON(..)) +#endif + +------------------------------------------------------------------------------- +-- * Gale +------------------------------------------------------------------------------- + +newtype Gale = Gale ShannonSwitchingGameCG + +emptyGale :: Gale +emptyGale = Gale $ createEmptyShannonSwitchingGameCG connections (-1) (-2) + where + connections = mapMaybe galeCoordinatesToId [(x, y) | x <- [0..8], y <- [0..8]] + +galeCoordinatesToId :: (Int, Int) -> Maybe (Int, Int) +galeCoordinatesToId (x, y) | even x && even y = Just (if x == 0 then -1 else x + y * 4 - 2, if x == 8 then -2 else x + y * 4) + | odd x && odd y = Just (x + (y - 1) * 4 - 1, x + (y - 1) * 4 + 7) + | otherwise = Nothing + +-- 0 1 2 3 4 5 6 7 8 +-- ╔═══╦═══╦═══╦═══╗ +-- 0┌ ┬ ┬ ┬ ┬ ┐ +-- 1│ ╠ ╬ ╬ ╬ ╣ │ +-- 2├ ┼ ┼ ┼ ┼ ┤ +-- 3│ ╠ ╬ ╬ ╬ ╣ │ +-- 4├ ┼ ┼ ┼ ┼ ┤ +-- 5│ ╠ ╬ ╬ ╬ ╣ │ +-- 6├ ┼ ┼ ┼ ┼ ┤ +-- 7│ ╠ ╬ ╬ ╬ ╣ │ +-- 8└ ┴ ┴ ┴ ┴ ┘ +-- ╚═══╩═══╩═══╩═══╝ +instance Show Gale where + show g = intercalate "\n" [ + " 0 1 2 3 4 5 6 7 8 " + , " \ESC[31m╔═══╦═══╦═══╦═══╗\ESC[0m " + , "0\ESC[34m┌" ++ intercalate "\ESC[34m┬" (row 0) ++ "\ESC[34m┐\ESC[0m" + , "1\ESC[34m│ \ESC[31m╠" ++ intercalate "\ESC[31m╬" (row 1) ++ "\ESC[31m╣ \ESC[34m│\ESC[0m" + , "2\ESC[34m├" ++ intercalate "\ESC[34m┼" (row 2) ++ "\ESC[34m┤\ESC[0m" + , "3\ESC[34m│ \ESC[31m╠" ++ intercalate "\ESC[31m╬" (row 3) ++ "\ESC[31m╣ \ESC[34m│\ESC[0m" + , "4\ESC[34m├" ++ intercalate "\ESC[34m┼" (row 4) ++ "\ESC[34m┤\ESC[0m" + , "5\ESC[34m│ \ESC[31m╠" ++ intercalate "\ESC[31m╬" (row 5) ++ "\ESC[31m╣ \ESC[34m│\ESC[0m" + , "6\ESC[34m├" ++ intercalate "\ESC[34m┼" (row 6) ++ "\ESC[34m┤\ESC[0m" + , "7\ESC[34m│ \ESC[31m╠" ++ intercalate "\ESC[31m╬" (row 7) ++ "\ESC[31m╣ \ESC[34m│\ESC[0m" + , "8\ESC[34m└" ++ intercalate "\ESC[34m┴" (row 8) ++ "\ESC[34m┘\ESC[0m" + , " \ESC[31m╚═══╩═══╩═══╩═══╝\ESC[0m " + ] + where + -- "Shows" the elements of the given row + row y = mapMaybe (\x -> flip showP y <$> getPosition g (x, y)) [0..8] + showP (Occupied Player1) y + | even y = "\ESC[34m───" + | otherwise = " \ESC[34m│ " + showP (Occupied Player2) y + | even y = " \ESC[31m║ " + | otherwise = "\ESC[31m═══" + showP Empty _ = " " + +#ifdef WASM +instance ToJSON Gale where + toJSON (Gale b) = toJSON b +#endif + +instance PositionalGame Gale (Int, Int) where + getPosition (Gale b) coords = galeCoordinatesToId coords >>= getPosition b + positions (Gale b) = positions b + setPosition (Gale b) coords p = Gale <$> (galeCoordinatesToId coords >>= flip (setPosition b) p) + gameOver (Gale b) = gameOver b
+ executable/Havannah.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Havannah where + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , mapPosition + , isOccupied + , nextPlayer + , drawIf + , criteria + , symmetric + , unless + , player1WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , values + , anyConnections + , mapValues + , filterValues + , filterG + , components + , hexHexGraph + , mapEdges + , inARow + , coloredGraphVertexPositions + , coloredGraphSetVertexPosition + , coloredGraphGetVertexPosition + ) + +#ifdef WASM +import Data.Aeson (ToJSON(..)) +#endif + +------------------------------------------------------------------------------- +-- * Havannah +------------------------------------------------------------------------------- + +newtype Havannah = Havannah (ColoredGraph (Int, Int) Position ()) + deriving (ColoredGraphTransformer (Int, Int) Position ()) + +instance Show Havannah where + show (Havannah b) = show b + +#ifdef WASM +instance ToJSON Havannah where + toJSON (Havannah b) = toJSON b +#endif + +instance PositionalGame Havannah (Int, Int) where + positions = coloredGraphVertexPositions + getPosition = coloredGraphGetVertexPosition + setPosition = coloredGraphSetVertexPosition + gameOver (Havannah b) = criterion b + where + criterion = + drawIf (all isOccupied . values) `unless` -- It's a draw if all tiles are owned. + -- Here we say that in any position where one player wins, + -- the other player would win instead if the pieces were swapped. + symmetric (mapValues $ mapPosition nextPlayer) + (criteria (player1WinsWhen <$> -- Player1 wins if any of these 3 criteria are satisfied. + -- Player1 has connected 2 corners. + [ anyConnections (>=2) corners . filterValues (== Occupied Player1) + -- player1 has connecteed 3 edges (excluding the corners). + , anyConnections (>=3) edges . filterValues (== Occupied Player1) + -- player1 has surrounded other tiles such that they can't reach the border. + , anyConnections (==0) border . filterValues (/= Occupied Player1) + ])) + corners = components $ filterG ((==3) . length . snd) b + edges = components $ filterG ((==4) . length . snd) b + border = corners ++ edges + +emptyHavannah :: Int -> Havannah +emptyHavannah = Havannah . mapEdges (const ()) . hexHexGraph
+ executable/Hex.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module Hex where + +import Data.List (intercalate) + +import Data.Map ( + Map + , lookup + , adjust + , member + ) + +import Prelude hiding (lookup) +import Data.Maybe (fromJust) + +#ifdef WASM +import Data.Aeson ( + ToJSON(..) + , object + , (.=) + ) +#endif + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , takeEmptyMakeMove + , criteria + , makerBreakerGameOver + , player1WinsWhen + , player2WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , paraHexGraph + , values + , anyConnections + , filterValues + , filterG + , winningSetPaths + , coloredGraphVertexPositions + , coloredGraphGetVertexPosition + , coloredGraphSetVertexPosition + ) + +------------------------------------------------------------------------------- +-- * Hex +------------------------------------------------------------------------------- + +data Hex = Hex Int (ColoredGraph (Int, Int) Position (Int, Int)) + +instance Show Hex where + show (Hex n b) = + replicate (2*(n-1)) ' ' ++ concat (replicate n " _ ") ++ "\n" + ++ + intercalate "\n" [intercalate "\n" (gridShowLine (Hex n b) r) | r <- [0..n-1]] + ++ + "\n" ++ concat (replicate n " \\_/") + +#ifdef WASM +instance ToJSON Hex where + toJSON (Hex n b) = object [ + "n" .= toJSON n + , "board" .= toJSON b + ] +#endif + +gridShowLine :: Hex -> Int -> [String] +gridShowLine (Hex n b) y = [rowOffset ++ tileTop ++ [x | y/=0, x <- " /"] + ,rowOffset ++ "| " ++ intercalate " | " (map (\x -> showP $ fst $ fromJust $ lookup (x, n-1-y) b) [0..(n-1)]) ++ " |" + ] where + showP (Occupied Player1) = "1" + showP (Occupied Player2) = "2" + showP Empty = " " + rowOffset = replicate (2*(n-y-1)) ' ' + tileTop = concat $ replicate n " / \\" + +instance ColoredGraphTransformer (Int, Int) Position (Int, Int) Hex where + toColoredGraph (Hex n b) = b + fromColoredGraph (Hex n _) = Hex n + +instance PositionalGame Hex (Int, Int) where + positions = coloredGraphVertexPositions + getPosition = coloredGraphGetVertexPosition + setPosition = coloredGraphSetVertexPosition + gameOver (Hex n b) = criterion b + where + criterion = + criteria + -- There is a connection between 2 components, the left and right. + [ player1WinsWhen (anyConnections (==2) [left, right]) . filterValues (==Occupied Player1) + -- There is a connection between 2 components, the top and bottom. + , player2WinsWhen (anyConnections (==2) [top, bottom]) . filterValues (==Occupied Player2) + ] + left = [(0, i) | i <- [0..n-1]] + right = [(n-1,i) | i <- [0..n-1]] + top = [(i, 0) | i <- [0..n-1]] + bottom = [(i,n-1) | i <- [0..n-1]] + +emptyHex :: Int -> Hex +emptyHex n = Hex n $ paraHexGraph n + +------------------------------------------------------------------------------- +-- * Hex2 +------------------------------------------------------------------------------- + +data Hex2 = Hex2 Int (ColoredGraph (Int, Int) Position (Int, Int)) + +instance Show Hex2 where + show (Hex2 n b) = + replicate (2*(n-1)) ' ' ++ concat (replicate n " _ ") ++ "\n" + ++ + intercalate "\n" [intercalate "\n" (gridShowLine2 (Hex2 n b) r) | r <- [0..n-1]] + ++ + "\n" ++ concat (replicate n " \\_/") + +#ifdef WASM +instance ToJSON Hex2 where + toJSON (Hex2 n b) = object [ + "n" .= toJSON n + , "board" .= toJSON b + ] +#endif + +gridShowLine2 :: Hex2 -> Int -> [String] +gridShowLine2 (Hex2 n b) y = [rowOffset ++ tileTop ++ [x | y/=0, x <- " /"] + ,rowOffset ++ "| " ++ intercalate " | " (map (\x -> showP $ fst $ fromJust $ lookup (x, n-1-y) b) [0..(n-1)]) ++ " |" + ] where + showP (Occupied Player1) = "1" + showP (Occupied Player2) = "2" + showP Empty = " " + rowOffset = replicate (2*(n-y-1)) ' ' + tileTop = concat $ replicate n " / \\" + +instance PositionalGame Hex2 (Int, Int) where + positions (Hex2 n b) = values b + getPosition (Hex2 n b) c = fst <$> lookup c b + setPosition (Hex2 n b) c p = if member c b + then Just $ Hex2 n $ adjust (\(_, xs) -> (p, xs)) c b + else Nothing + makeMove = takeEmptyMakeMove + gameOver (Hex2 n b) = makerBreakerGameOver (allWinningHexPaths n) (Hex2 n b) + +allWinningHexPaths :: Int -> [[(Int, Int)]] +allWinningHexPaths n = winningSetPaths (paraHexGraph n) left right + where + left = [(0, i) | i <- [0..n-1]] + right = [(n-1,i) | i <- [0..n-1]] + +emptyHex2 :: Int -> Hex2 +emptyHex2 n = Hex2 n $ paraHexGraph n
+ executable/MNKGame.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +module MNKGame where + +import Data.Map ( + Map + , lookup + , member + , adjust + ) + +import Prelude hiding (lookup) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , mapPosition + , criteria + , isOccupied + , nextPlayer + , drawIf + , symmetric + , unless + , player1WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , values + , mapValues + , mapEdges + , filterValues + , rectOctGraph + , inARow + , filterEdges + , coloredGraphVertexPositions + , coloredGraphGetVertexPosition + , coloredGraphSetVertexPosition + ) + +#ifdef WASM +import Data.Aeson ( + ToJSON(..) + , object + , (.=) + ) +#endif + +------------------------------------------------------------------------------- +-- * mnk-game +------------------------------------------------------------------------------- + +data MNKGame = MNKGame Int (ColoredGraph (Int, Int) Position String) + +instance Show MNKGame where + show (MNKGame k b) = show b + +#if WASM +instance ToJSON MNKGame where + toJSON (MNKGame k b) = object [ + "k" .= toJSON k + , "board" .= toJSON b + ] +#endif + +instance ColoredGraphTransformer (Int, Int) Position String MNKGame where + toColoredGraph (MNKGame n b) = b + fromColoredGraph (MNKGame n _) = MNKGame n + +instance PositionalGame MNKGame (Int, Int) where + positions = coloredGraphVertexPositions + getPosition = coloredGraphGetVertexPosition + setPosition = coloredGraphSetVertexPosition + gameOver (MNKGame k b) = criterion b + where + criterion = + drawIf (all isOccupied . values) `unless` -- It's a draw if all tiles are owned. + -- Here we say that in any position where one player wins, + -- the other player would win instead if the pieces were swapped. + symmetric (mapValues $ mapPosition nextPlayer) + -- Player1 wins if there are k or more pieces in a row in any direction. + (criteria (player1WinsWhen . inARow (>=k) <$> directions) . filterValues (== Occupied Player1)) + + + directions = ["vertical", "horizontal", "diagonal1", "diagonal2"] + +emptyMNKGame :: Int -> Int -> Int -> MNKGame +emptyMNKGame m n k = MNKGame k $ mapEdges dirName $ rectOctGraph m n + where + dirName (1,0) = "horizontal" + dirName (-1,0) = "horizontal" + dirName (0,-1) = "vertical" + dirName (0,1) = "vertical" + dirName (1,-1) = "diagonal1" + dirName (-1,1) = "diagonal1" + dirName (1,1) = "diagonal2" + dirName (-1,-1) = "diagonal2"
+ executable/Main.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-} + +module Main where + +import Boardgame (playIO) + +import System.IO (hFlush, stdout) + +#ifdef WASM +import Data.Maybe (fromJust) +import Boardgame.Web (addWebGame, webReady) +#endif + +-- Import all board games +import ArithmeticProgressionGame +import ConnectFour +import Cross +import Gale +import Havannah +import Hex +import MNKGame +import ShannonSwitchingGame +import TicTacToe +import Y +import Yavalath + +------------------------------------------------------------------------------- +-- * CLI interactions +------------------------------------------------------------------------------- + +#ifdef WASM +main :: IO () +main = do + addWebGame "TicTacToe" emptyTicTacToe + addWebGame "Arithmetic Progression Game" $ fromJust $ createArithmeticProgressionGame 35 5 + addWebGame "Shannon Switching Game" $ createShannonSwitchingGame 5 + addWebGame "Gale" emptyGale + addWebGame "Hex" $ emptyHex 5 + addWebGame "Havannah" $ emptyHavannah 8 + addWebGame "Yavalath" $ emptyYavalath 8 + addWebGame "Y" $ emptyY 8 + addWebGame "Cross" $ emptyCross 8 + addWebGame "Hex (Alternative Version)" $ emptyHex2 5 + addWebGame "TicTacToe (Alternative Version)" $ emptyMNKGame 3 3 3 + addWebGame "Connect Four" $ emptyConnectFour 6 7 4 + addWebGame "Shannon Switching Game (On a ColoredGraph)" $ wikipediaReplica + webReady +#else +main :: IO () +main = do + putStrLn "1: TicTacToe" + putStrLn "2: Arithmetic Progression Game" + putStrLn "3: Shannon Switching Game" + putStrLn "4: Gale" + putStrLn "5: Hex" + putStrLn "6: Havannah" + putStrLn "7: Yavalath" + putStrLn "8: Y" + putStrLn "9: Cross" + putStrLn "10: Hex (Alternative Version)" + putStrLn "11: TicTacToe (Alternative Version)" + putStrLn "12: Connect Four" + putStrLn "13: Shannon Switching Game (On a ColoredGraph)" + putStr "What do you want to play? " + hFlush stdout + choice <- read <$> getLine + putStr "\ESC[2J" + hFlush stdout + case choice of + 1 -> playIO emptyTicTacToe + 2 -> playAPG + 3 -> playIO $ createShannonSwitchingGame 5 + 4 -> playIO emptyGale + 5 -> playIO $ emptyHex 5 + 6 -> playIO $ emptyHavannah 8 + 7 -> playIO $ emptyYavalath 8 + 8 -> playIO $ emptyY 8 + 9 -> playIO $ emptyCross 8 + 10 -> playIO $ emptyHex2 5 + 11 -> playIO $ emptyMNKGame 3 3 3 + 12 -> playIO $ emptyConnectFour 6 7 4 + 13 -> playIO wikipediaReplica + _ -> putStrLn "Invalid choice!" + +playAPG :: IO () +playAPG = do + putStr "n: " + hFlush stdout + n <- read <$> getLine + putStr "k: " + hFlush stdout + k <- read <$> getLine + case createArithmeticProgressionGame n k of + Just a -> playIO a + Nothing -> putStrLn "Not valid input (n < k)" +#endif
+ executable/ShannonSwitchingGame.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module ShannonSwitchingGame where + +import Data.Graph as Graph (Graph, buildG, path) + +import Data.List ( + find + , findIndex + , intercalate + , subsequences + , sortOn + ) + +import Data.Map ( + Map + , fromList + , insert + , alter + , empty + , assocs + , keys + ) + +import Data.Maybe ( + fromJust + , isJust + , isNothing + , mapMaybe + ) + +import Boardgame ( + Player(..) + , Position(..) + , Outcome(..) + , PositionalGame(..) + , isOccupied + , ifNotThen + , player1WinsWhen + , player1LosesWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , anyConnections + , edgePath + , mapEdges + , filterEdges + , coloredGraphEdgePositions + , coloredGraphGetEdgePosition + , coloredGraphSetBidirectedEdgePosition + ) + +#ifdef WASM +import Data.Aeson ( + ToJSON(..) + , object + , (.=) + ) +#endif + +------------------------------------------------------------------------------- +-- * Shannon Switching Game +------------------------------------------------------------------------------- + +newtype ShannonSwitchingGame = ShannonSwitchingGame (Int, [((Int, Int), Position)]) + +-- | Creates a list of all edges, input n gives n*n graph +gridEdges :: Int -> [((Int, Int), Position)] +gridEdges n = + concat [[((j+i*n,(j+1)+i*n), Empty), ((j+i*n,j+(i+1)*n), Empty)] | i <- [0..n-2], j <- [0..n-2]] ++ + [(((n-1)+i*n, (n-1)+(i+1)*n), Empty) | i <- [0..n-2]] ++ + [((i+(n-1)*n, (i+1)+(n-1)*n), Empty) | i <- [0..n-2]] + +createShannonSwitchingGame :: Int -> ShannonSwitchingGame +createShannonSwitchingGame n = ShannonSwitchingGame (n, gridEdges n) + +-- o───o---o +-- ║ │ : +-- o═══o═══o +-- ║ │ : +-- o───o───o +instance Show ShannonSwitchingGame where + show a@(ShannonSwitchingGame (n, l)) = intercalate "\n" ([concat ["o" ++ showH (fromJust $ getPosition a (i+j*n, (i+1)+j*n)) | i <- [0 .. n - 2]] + ++ "o\n" ++ concat [showV (fromJust $ getPosition a (i+j*n, i+(j+1)*n)) ++ " " | i <- [0 .. n - 2]] ++ showV (fromJust $ getPosition a ((n-1)+j*n, (n-1)+(j+1)*n) ) | + j <- [0 .. n - 2]] + ++ [concat ["o" ++ showH (fromJust $ getPosition a (i+(n-1)*n, (i+1)+(n-1)*n)) | i <- [0 .. n - 2]] ++ "o"]) + where + showH (Occupied Player1) = "\ESC[34m───\ESC[0m" + showH (Occupied Player2) = "\ESC[31m───\ESC[0m" + showH Empty = "───" + showV (Occupied Player1) = "\ESC[34m│\ESC[0m" + showV (Occupied Player2) = "\ESC[31m│\ESC[0m" + showV Empty = "│" + +#ifdef WASM +instance ToJSON ShannonSwitchingGame where + toJSON (ShannonSwitchingGame (n, ps)) = object [ + "n" .= toJSON n + , "positions" .= toJSON ps + ] +#endif + +instance PositionalGame ShannonSwitchingGame (Int, Int) where + positions (ShannonSwitchingGame (_, l)) = map snd l + getPosition (ShannonSwitchingGame (_, l)) c = snd <$> find ((== c) . fst) l + setPosition (ShannonSwitchingGame (n, l)) c p = case findIndex ((== c) . fst) l of + Just i -> Just $ ShannonSwitchingGame (n, take i l ++ (c, p) : drop (i + 1) l) + Nothing -> Nothing + gameOver (ShannonSwitchingGame (n, l)) + | path g 0 (n * n - 1) = Just (Win Player1, []) + | path g (n - 1) (n * n - n) = Just (Win Player2, []) + | all (isOccupied . snd) l = Just (Draw, []) + | otherwise = Nothing + where + g = buildG (0, n * n - 1) (map fst $ filter ((== Occupied Player1) . snd) l) + +------------------------------------------------------------------------------- +-- * Shannon Switching Game (On a ColoredGraph) +------------------------------------------------------------------------------- + +-- Operates under the invariant that all edges in 'graph' are bi-directional +-- and their values are in sync. +data ShannonSwitchingGameCG = ShannonSwitchingGameCG { + start :: Int + , goal :: Int + , graph :: ColoredGraph Int () Position + } + deriving (Show) + +#if WASM +instance ToJSON ShannonSwitchingGameCG where + toJSON ShannonSwitchingGameCG{ start, goal, graph } = + object [ + "start" .= start + , "goal" .= goal + , "graph" .= graph + ] +#endif + +instance ColoredGraphTransformer Int () Position ShannonSwitchingGameCG where + toColoredGraph = graph + fromColoredGraph ssg graph = ssg{ graph } + +instance PositionalGame ShannonSwitchingGameCG (Int, Int) where + positions = coloredGraphEdgePositions + getPosition = coloredGraphGetEdgePosition + setPosition = coloredGraphSetBidirectedEdgePosition + gameOver ShannonSwitchingGameCG{ start, goal, graph } = + ifNotThen (player1WinsWhen winPath) (player1LosesWhen losePath) graph + where + winPath = fmap edgePath . anyConnections (==2) [[start], [goal]] . filterEdges (== Occupied Player1) + losePath g = do + -- Gets the (from, to) coordinates of edges Occupied by Player2 + let cut = assocs (filterEdges (== Occupied Player2) g) >>= \(f, (_, ts)) -> mapMaybe (\t -> if f <= t then Just (f, t) else Nothing) $ keys ts + -- Get all subsequences from shortest to longest + let ss = sortOn length $ subsequences cut + -- A ColoredGraph where all edges Occupied by Player2 are cleared + let clearedG = mapEdges (\case Occupied Player2 -> Empty; p -> p) g + -- Returns the first subsequence (the shortest) that successfully + -- prevent Player1 from winning + find (losePathTest . foldl (\g c -> fromJust $ coloredGraphSetBidirectedEdgePosition g c (Occupied Player2)) clearedG) ss + losePathTest = isNothing . anyConnections (==2) [[start], [goal]] . filterEdges (/= Occupied Player2) + +createEmptyShannonSwitchingGameCG :: [(Int, Int)] -> Int -> Int -> ShannonSwitchingGameCG +createEmptyShannonSwitchingGameCG pairs start goal = ShannonSwitchingGameCG{ + start + , goal + , graph = foldl addPathToMap empty $ pairs >>= (\(from, to) -> [(from, to), (to, from)]) + } + where + addPathToMap m (from, to) = alter updateOrInsert from m + where + updateOrInsert existing = case existing of + Just (a, edges) -> Just (a, insert to Empty edges) + Nothing -> Just ((), fromList [(to, Empty)]) + +-- Creates a 'ShannonSwitchingGameCG' on a graph like the one from Wikipedia. +-- https://en.wikipedia.org/wiki/Shannon_switching_game#/media/File:Shannon_game_graph.svg +wikipediaReplica :: ShannonSwitchingGameCG +wikipediaReplica = createEmptyShannonSwitchingGameCG connections 0 3 + where + connections = [ + (0, 1) + , (0, 4) + , (0, 7) + , (1, 2) + , (1, 5) + , (2, 3) + , (4, 5) + , (4, 6) + , (4, 7) + , (5, 3) + , (5, 6) + , (6, 3) + , (7, 6) + ]
+ executable/TicTacToe.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} + +module TicTacToe where + +import Data.List (intercalate) + +import Data.Map ( + Map + , insert + , member + , elems + , lookup + , (!) + , fromDistinctAscList + ) + +import Prelude hiding (lookup) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , patternMatchingGameOver + ) + +#ifdef WASM +import qualified Data.Vector as V (fromList) +import Data.Aeson ( + ToJSON(..) + , Value(Array) + ) +#endif + +------------------------------------------------------------------------------- +-- * TicTacToe +------------------------------------------------------------------------------- + +newtype TicTacToe = TicTacToe (Map (Integer, Integer) Position) + +-- Creates an empty TicTacToe board with coordinates `(0..2, 0..2)` +emptyTicTacToe :: TicTacToe +emptyTicTacToe = TicTacToe $ + fromDistinctAscList $ + zip + [(x, y) | x <- [0..2], y <- [0..2]] + (repeat Empty) + +instance Show TicTacToe where + show (TicTacToe b) = intercalate "\n" [ + "╔═══╤═══╤═══╗" + , "║ " ++ intercalate " │ " (row 0) ++ " ║" + , "╟───┼───┼───╢" + , "║ " ++ intercalate " │ " (row 1) ++ " ║" + , "╟───┼───┼───╢" + , "║ " ++ intercalate " │ " (row 2) ++ " ║" + , "╚═══╧═══╧═══╝" + ] + where + -- "Shows" the elements of the given row + row y = map (\x -> showP $ b ! (x, y)) [0..2] + showP (Occupied Player1) = "\ESC[34mo\ESC[0m" + showP (Occupied Player2) = "\ESC[31mx\ESC[0m" + showP Empty = " " + +#ifdef WASM +-- Converts the game to a JSON array with three arrays with three integers +-- each. The integers correspond to +-- 0 → Nothing, +-- 1 → Just Player1, and +-- 2 → Just Player2. +instance ToJSON TicTacToe where + toJSON (TicTacToe b) = Array $ V.fromList $ map row [0..2] + where + row y = Array $ V.fromList $ map (\x -> toJSON $ b ! (x, y)) [0..2] +#endif + +instance PositionalGame TicTacToe (Integer, Integer) where + -- Just looks up the coordinate in the underlying Map + getPosition (TicTacToe b) = flip lookup b + -- Just returns the elements in the underlying Map + positions (TicTacToe b) = elems b + -- If the underlying Map has the given coordinate, update it with the given player + setPosition (TicTacToe b) c p = if member c b then Just $ TicTacToe $ insert c p b else Nothing + -- "Creates" a `gameOver` function by supplying all the winning "patterns" + gameOver = patternMatchingGameOver [ + [(0, 0), (0, 1), (0, 2)] + , [(1, 0), (1, 1), (1, 2)] + , [(2, 0), (2, 1), (2, 2)] + , [(0, 0), (1, 0), (2, 0)] + , [(0, 1), (1, 1), (2, 1)] + , [(0, 2), (1, 2), (2, 2)] + , [(0, 0), (1, 1), (2, 2)] + , [(2, 0), (1, 1), (0, 2)] + ]
+ executable/Y.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Y where + +import Prelude hiding (lookup) + +import Data.Map ( + Map + , elems + , keys + , lookup + , member + , adjust + ) + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , mapPosition + , takeEmptyMakeMove + , nextPlayer + , symmetric + , player1WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , values + , anyConnections + , mapValues + , filterValues + , filterG + , triHexGraph + ) + +#ifdef WASM +import Data.Aeson (ToJSON(..)) +#endif + +------------------------------------------------------------------------------- +-- * Y +------------------------------------------------------------------------------- + +newtype Y = Y (ColoredGraph (Int, Int) Position (Int, Int)) + +instance Show Y where + show (Y b) = show b + +#ifdef WASM +instance ToJSON Y where + toJSON (Y b) = toJSON b +#endif + +instance PositionalGame Y (Int, Int) where + positions (Y b) = values b + getPosition (Y b) c = fst <$> lookup c b + setPosition (Y b) c p = if member c b + then Just $ Y $ adjust (\(_, xs) -> (p, xs)) c b + else Nothing + makeMove = takeEmptyMakeMove + + gameOver (Y b) = criterion b + where + criterion = + -- Here we say that in any position where one player wins, + -- the other player would win instead if the pieces were swapped. + symmetric (mapValues $ mapPosition nextPlayer) $ + player1WinsWhen $ anyConnections (==3) [side1, side2, side3] . filterValues (== Occupied Player1) + + dirs :: [(Int, Int)] + dirs = + [ (1, 0) + , (1, -1) + , (0, -1) + , (-1, 0) + , (-1, 1) + , (0, 1) + ] + emptyNeighbour x = keys $ filterG (notElem x . elems . snd) b + + side1 = emptyNeighbour $ dirs !! 0 + side2 = emptyNeighbour $ dirs !! 2 + side3 = emptyNeighbour $ dirs !! 4 + +emptyY :: Int -> Y +emptyY = Y . triHexGraph
+ executable/Yavalath.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Yavalath where + +import Boardgame ( + Player(..) + , Position(..) + , PositionalGame(..) + , mapPosition + , isOccupied + , nextPlayer + , drawIf + , criteria + , symmetric + , unless + , player1LosesWhen + , player1WinsWhen + ) + +import Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , values + , mapValues + , filterValues + , hexHexGraph + , inARow + , mapEdges + , winningSetPaths + , coloredGraphVertexPositions + , coloredGraphGetVertexPosition + , coloredGraphSetVertexPosition + ) + +#ifdef WASM +import Data.Aeson (ToJSON(..)) +#endif + +------------------------------------------------------------------------------- +-- * Yavalath +------------------------------------------------------------------------------- + +newtype Yavalath = Yavalath (ColoredGraph (Int, Int) Position String) + deriving (ColoredGraphTransformer (Int, Int) Position String) + +instance Show Yavalath where + show (Yavalath b) = show b + +#ifdef WASM +instance ToJSON Yavalath where + toJSON (Yavalath b) = toJSON b +#endif + +instance PositionalGame Yavalath (Int, Int) where + positions = coloredGraphVertexPositions + getPosition = coloredGraphGetVertexPosition + setPosition = coloredGraphSetVertexPosition + gameOver (Yavalath b) = criterion b + where + criterion = + drawIf (all isOccupied . values) `unless` -- It's a draw if all tiles are owned. + -- Here we say that in any position where one player wins, + -- the other player would win instead if the pieces were swapped. + symmetric (mapValues $ mapPosition nextPlayer) + -- Player1 looses if he has 3 in a row but wins if he has 4 or more in a row. + -- It's important we use `unless` here because otherwise we could have conflicting + -- outcomes from having both 3 in a row and 4 in a row at the same time. + (criteria (player1LosesWhen . inARow (==3) <$> directions) . filterValues (== Occupied Player1) `unless` + criteria (player1WinsWhen . inARow (>=4) <$> directions) . filterValues (== Occupied Player1)) + + directions = ["vertical", "diagonal1", "diagonal2"] + +emptyYavalath :: Int -> Yavalath +emptyYavalath = Yavalath . mapEdges dirName . hexHexGraph + where + dirName (1,0) = "vertical" + dirName (-1,0) = "vertical" + dirName (1,-1) = "diagonal1" + dirName (-1,1) = "diagonal1" + dirName (0,-1) = "diagonal2" + dirName (0,1) = "diagonal2"
+ src/Boardgame.hs view
@@ -0,0 +1,451 @@+{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PartialTypeSignatures #-} + +{-| +Module: Boardgame +Description: The main framework for creating boardgames. + +The main framework module for boardgames. Contains the 'PositionalGame' class +implemented by all positional games, and a bunch of helper functions. + +The helper functions range from just that, simple helper functions such as +'player1WinsWhen', to right out implementations of functions in the +'PositionalGame's class, such as the 'takeEmptyMakeMove' functions. + +It also contains some functions for playing games. 'play' is the implementation +agnostic skeleton code that you can use in any context. And 'playIO' uses +'play' to play the games in the terminal. + += TicTacToe as an example + +> -- TicTacToe is a +> newtype TicTacToe = TicTacToe (Map (Integer, Integer) Position) +> +> -- Creates an empty TicTacToe board with coordinates @(0..2, 0..2)@ +> emptyTicTacToe = TicTacToe $ +> fromDistinctAscList $ +> zip +> [(x, y) | x <- [0..2], y <- [0..2]] +> (repeat Empty) +> +> instance Show TicTacToe where +> show (TicTacToe b) = intercalate "\n" [ +> "╔═══╤═══╤═══╗" +> , "║ " ++ intercalate " │ " (row 0) ++ " ║" +> , "╟───┼───┼───╢" +> , "║ " ++ intercalate " │ " (row 1) ++ " ║" +> , "╟───┼───┼───╢" +> , "║ " ++ intercalate " │ " (row 2) ++ " ║" +> , "╚═══╧═══╧═══╝" +> ] +> where +> row y = map (\x -> showP $ b ! (x, y)) [0..2] +> showP (Occupied Player1) = "\ESC[34mo\ESC[0m" +> showP (Occupied Player2) = "\ESC[31mx\ESC[0m" +> showP Empty = " " +> +> instance PositionalGame TicTacToe (Integer, Integer) where +> -- Just looks up the coordinate in the underlying Map +> getPosition (TicTacToe b) = flip lookup b +> -- Just returns the elements in the underlying Map +> positions (TicTacToe b) = elems b +> -- If the underlying Map has the given coordinate, update it with the given player +> setPosition (TicTacToe b) c p = if member c b then Just $ TicTacToe $ insert c p b else Nothing +> -- "Creates" a 'gameOver' function by supplying all the winning "patterns" +> gameOver = patternMatchingGameOver [ +> [(0, 0), (0, 1), (0, 2)] +> , [(1, 0), (1, 1), (1, 2)] +> , [(2, 0), (2, 1), (2, 2)] +> , [(0, 0), (1, 0), (2, 0)] +> , [(0, 1), (1, 1), (2, 1)] +> , [(0, 2), (1, 2), (2, 2)] +> , [(0, 0), (1, 1), (2, 2)] +> , [(2, 0), (1, 1), (0, 2)] +> ] +> -- 'makeMove' is handled by the default implementation 'takeEmptyMakeMove' +> +> -- Plays the game in the terminal, takes @(x, y)@ as input +> main = playIO emptyTicTacToe +-} +module Boardgame ( + Player(..) + , Position(..) + , Outcome(..) + , PositionalGame(..) + , nextPlayer + , mapPosition + , isOccupied + , isEmpty + , mapOutcome + , isWin + , isDraw + , play + , playerToInt + , playIO + , takeEmptyMakeMove + , patternMatchingGameOver + , drawIf + , player1WinsIf + , player2WinsIf + , player1LosesIf + , player2LosesIf + , drawWhen + , player1WinsWhen + , player2WinsWhen + , player1LosesWhen + , player2LosesWhen + , criteria + , symmetric + , unless + , ifNotThen + , makerBreakerGameOver +) where + +import Data.Functor ((<&>)) +import Data.List (find, intercalate, minimumBy, intersect) +import Data.Maybe (isJust, fromJust) +import System.IO (hFlush, stdout) +import Text.Read (readMaybe) +import Control.Monad (join, foldM) +import Control.Applicative ((<|>)) +import Data.Bifunctor (first, Bifunctor (second)) +#ifdef WASM +import Data.Aeson (ToJSON(toJSON), Value(Number, Null)) +import Data.Scientific (fromFloatDigits) +#endif + +-- | Represents one of the two players. +data Player = Player1 | Player2 + deriving (Show, Eq) + +-- | Returns the "next" player in turn. +nextPlayer :: Player -> Player +nextPlayer Player1 = Player2 +nextPlayer Player2 = Player1 + +-- | Turns a 'Player' into an int. 1 or 2 for the player respectively. +playerToInt :: Player -> Int +playerToInt Player1 = 1 +playerToInt Player2 = 2 + +#ifdef WASM +instance ToJSON Player where + toJSON = Number . fromFloatDigits . fromIntegral . playerToInt +#endif + +-- | A 'Position' can either be 'Occupied' by a 'Player' or be 'Empty'. +data Position = Occupied Player | Empty + deriving (Eq, Show) + +#ifdef WASM +instance ToJSON Position where + toJSON (Occupied p) = toJSON p + toJSON Empty = Null +#endif + +-- | Applies the given function to a occupying piece, or does nothing in the case +-- of an 'Empty' 'Position'. +mapPosition :: (Player -> Player) -> Position -> Position +mapPosition f (Occupied p) = Occupied $ f p +mapPosition _ Empty = Empty + +-- | Checks if the position is occupied or not. +isOccupied :: Position -> Bool +isOccupied (Occupied _) = True +isOccupied Empty = False + +-- | Checks if the position is empty or not. +isEmpty :: Position -> Bool +isEmpty (Occupied _) = False +isEmpty Empty = True + +-- | The 'Outcome' of a game. Either a 'Win' for one of the players, or a +-- 'Draw'. +data Outcome = Win Player | Draw + deriving (Eq, Show) + +#ifdef WASM +instance ToJSON Outcome where + toJSON (Win p) = toJSON p + toJSON Draw = Null +#endif + +-- | Applies the given function to a winning player, or does nothing in the +-- case of a draw. +mapOutcome :: (Player -> Player) -> Outcome -> Outcome +mapOutcome f (Win p) = Win $ f p +mapOutcome _ Draw = Draw + +-- | Checks if the outcome is a victory or not. +isWin :: Outcome -> Bool +isWin (Win _) = True +isWin Draw = False + +-- | Checks if the outcome is a draw or not. +isDraw :: Outcome -> Bool +isDraw (Win _) = False +isDraw Draw = True + +-- | A type class for positional games where `a` is the game itself and `c` is +-- its accompanying "coordinate" type. +class PositionalGame a c | a -> c where + -- | Takes the "current" state, a player, and a coordinate. Returns the new + -- state if the move is valid. + -- + -- The default implementation is 'takeEmptyMakeMove'. + makeMove :: a -> Player -> c -> Maybe a + makeMove = takeEmptyMakeMove + -- | Takes the "current" state and checks if the game is over, in which case + -- the victorious player is returned or 'Draw' in case of a draw. + -- + -- > Nothing -- Continue the game + -- > Just (Just p, cs) -- Player p won + -- > Just (Nothing, cs) -- Draw + -- + -- We also return `cs`, a list of coordinates to highlight. + gameOver :: a -> Maybe (Outcome, [c]) + -- | Returns a list of all positions. Not in any particular order. + positions :: a -> [Position] + -- | Returns which player (or Empty) has taken the position at the given + -- coordinate, or 'Nothing' if the given coordinate is invalid. + -- + -- > Nothing -- Invalid position + -- > Occupied Player -- Player p owns this position + -- > Empty -- This position is empty + getPosition :: a -> c -> Maybe Position + -- | Takes the position at the given coordinate for the given player and + -- returns the new state, or 'Nothing' if the given coordinate is invalid. + setPosition :: a -> c -> Position -> Maybe a + +-- | A standard implementation of 'makeMove' for a 'PositionalGame'. +-- Only allows move that "take" empty existing positions. +takeEmptyMakeMove :: PositionalGame a c => a -> Player -> c -> Maybe a +takeEmptyMakeMove a p coord = case getPosition a coord of + Just Empty -> setPosition a coord (Occupied p) + _ -> Nothing + +-- | Returns an implementation of 'gameOver' for a 'PositionalGame' when given +-- a set of winning sets. A player is victorious when they "own" one of the +-- winning sets. The game ends in a draw when all positions on the board are +-- taken. +patternMatchingGameOver :: (Eq c, PositionalGame a c) => [[c]] -> a -> Maybe (Outcome, [c]) +patternMatchingGameOver patterns a = case find (isOccupied . fst) $ (\pat -> (, pat) $ reduceHomogeneousList (fromJust . getPosition a <$> pat)) <$> patterns of + Nothing -> if all isOccupied (positions a) then Just (Draw, []) else Nothing + Just (Occupied winner, coords) -> Just (Win winner, coords) + Just (Empty, coords) -> Just (Draw, coords) + where + -- | Returns an element of the homogeneous list, or 'Empty'. + reduceHomogeneousList :: [Position] -> Position + reduceHomogeneousList [] = Empty + reduceHomogeneousList (x:xs) = if all (== x) xs then x else Empty + +-- | Returns an implementation of 'gameOver' for a 'PositionalGame' when given +-- a set of winning sets. Player1 wins when they "own" one of the winning +-- sets. Player2 wins if Player1 cannot win. +makerBreakerGameOver :: (Eq c, PositionalGame a c) => [[c]] -> a -> Maybe (Outcome, [c]) +makerBreakerGameOver patterns a + | Just coords <- player1won = Just (Win Player1, coords) + | player2won = Just (Win Player2, player2Coords) + | otherwise = Nothing + where + player1won = find (all $ (== Occupied Player1) . fromJust . getPosition a) patterns + player2won = all (any $ (== Occupied Player2) . fromJust . getPosition a) patterns + + -- A minimum set of coordinates which Player2 owns and contain atleast one element in every winning set. + -- This is only valid when `player2won` is `True`. + player2Coords = minimumBy compareLength $ assignments $ filter ((== Occupied Player2) . fromJust . getPosition a) <$> patterns + + -- A lazy version of `comparing length`. + compareLength :: [a] -> [b] -> Ordering + compareLength [] [] = EQ + compareLength (_:_) [] = GT + compareLength [] (_:_) = LT + compareLength (_:xs) (_:ys) = compareLength xs ys + + -- Return all sets which contain atleast one element from every set in the input + -- and avoiding unneccesary elements. + -- This is used to solve the hitting set/set cover problem. + assignments :: Eq c => [[c]] -> [[c]] + assignments = assignments' [] + where + assignments' set [] = [set] + assignments' set (claus:clauses) = if not $ null $ intersect set claus + then assignments' set clauses + else concat $ (\c -> assignments' (c:set) clauses) <$> claus + +-- | Returns an implementation of 'gameOver' for a 'PositionalGame' when given +-- a set of winning sets. Player1 wins if they can avoid "owning" any of the +-- winning sets. Player2 wins if Player1 owns a winning set. +avoiderEnforcerGameOver :: (Eq c, PositionalGame a c) => [[c]] -> a -> Maybe (Outcome, [c]) +avoiderEnforcerGameOver patterns a = first (mapOutcome nextPlayer) <$> makerBreakerGameOver patterns a + +-- | The skeleton code for "playing" any 'PositionalGame'. When given a set of +-- function for communicating the state of the game and moves, a starting +-- state can be applied to play the game. +play :: (Monad m, PositionalGame a c) => + (a -> m ()) + -- ^ Function for outputting the state of the game. + -> (Player -> m ()) + -- ^ Function for communicating which 'Player's turn it is. + -> m c + -- ^ Function for getting a move from a player. + -> m () + -- ^ Function for communicating an invalid move. + -> ((Outcome, [c]) -> m ()) + -- ^ Function for outputting the end result of the game. + -> a + -> m () +play putState putTurn getMove putInvalidMove putGameOver startingState = putState startingState >> putTurn Player1 >> play' startingState Player1 + where + play' s p = getMove <&> makeMove s p >>= \case + Just s' -> putState s' >> case gameOver s' of + Just v -> putGameOver v + Nothing -> (\p' -> putTurn p' >> play' s' p') $ nextPlayer p + Nothing -> putInvalidMove >> play' s p + +-- | Plays a 'PositionalGame' in the console by taking alternating input from +-- the players. Requires that the game is an instance of 'Show' and that its +-- coordinates are instances of 'Read'. +playIO :: (Show a, Show c, Read c, PositionalGame a c) => a -> IO () +playIO = play putState putTurn getMove putInvalidMove putGameOver + where + putState s = putStr "\ESC[s\ESC[0;0H" >> print s >> putStr "\ESC[u" >> hFlush stdout + putTurn p = putStr ("Move for " ++ (case p of + Player1 -> "player 1" + Player2 -> "player 2") ++ ": ") >> hFlush stdout + getMove = getLine <&> readMaybe >>= \case + Just c -> return c + Nothing -> putStr "Invalid input, try again: " >> hFlush stdout >> getMove + putInvalidMove = putStr "Invalid move, try again: " >> hFlush stdout + putGameOver = \case + (Win Player1, p) -> putStrLn "Player 1 won!" >> print p >> hFlush stdout + (Win Player2, p) -> putStrLn "Player 2 won!" >> print p >> hFlush stdout + (Draw, _) -> putStrLn "It's a draw!" >> hFlush stdout + +data CombinedPositionalGames a b i j = CombinedPositionalGames a b + +instance (PositionalGame a i, PositionalGame b j) => PositionalGame (CombinedPositionalGames a b i j) (Either i j) where + makeMove (CombinedPositionalGames x y) player index = case index of + Left i -> flip CombinedPositionalGames y <$> makeMove x player i + Right i -> CombinedPositionalGames x <$> makeMove y player i + gameOver (CombinedPositionalGames x y) = (second (fmap Left) <$> gameOver x) + <|> (second (fmap Right) <$> gameOver y) + positions (CombinedPositionalGames x y) = positions x ++ positions y + getPosition (CombinedPositionalGames x y) = either (getPosition x) (getPosition y) + setPosition (CombinedPositionalGames x y) ij p = case ij of + Left i -> flip CombinedPositionalGames y <$> setPosition x i p + Right j -> CombinedPositionalGames x <$> setPosition y j p + + + + + +-- | If the predicate holds, a winning state for player 1 is returned. If +-- not, a "game running" state is returned. +player1WinsIf :: (a -> Bool) -> a -> Maybe (Outcome, [c]) +player1WinsIf pred x = if pred x + then Just (Win Player1, []) + else Nothing + +-- | A synonym for 'player1WinsIf'. When player 2 loses, player 1 wins. +player2LosesIf :: (a -> Bool) -> a -> Maybe (Outcome, [c]) +player2LosesIf = player1WinsIf + +-- | If the predicate holds, a winning state for player 2 is returned. If +-- not, a "game running" state is returned. +player2WinsIf :: (a -> Bool) -> a -> Maybe (Outcome, [c]) +player2WinsIf pred x = if pred x + then Just (Win Player2, []) + else Nothing + +-- | A synonym for 'player2WinsIf'. When player 1 loses, player 2 wins. +player1LosesIf :: (a -> Bool) -> a -> Maybe (Outcome, [c]) +player1LosesIf = player2WinsIf + +-- | If the predicate holds, a draw state is returned. If not, a "game running" +-- state is returned. +drawIf :: (a -> Bool) -> (a -> Maybe (Outcome, [c])) +drawIf pred x = if pred x + then Just (Draw, []) + else Nothing + +-- | If the predicate holds, a winning state for player 1 is returned. If +-- not, a "game running" state is returned. +player1WinsWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c]) +player1WinsWhen pred x = (Win Player1, ) <$> pred x + +-- | A synonym for 'player1WinsIf'. When player 2 loses, player 1 wins. +player2LosesWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c]) +player2LosesWhen = player1WinsWhen + +-- | If the predicate holds, a winning state for player 2 is returned. If +-- not, a "game running" state is returned. +player2WinsWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c]) +player2WinsWhen pred x = (Win Player2, ) <$> pred x + +-- | A synonym for 'player2WinsIf'. When player 1 loses, player 2 wins. +player1LosesWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c]) +player1LosesWhen = player2WinsWhen + +-- | If the predicate holds, a draw state is returned. If not, a "game running" +-- state is returned. +drawWhen :: (a -> Maybe [c]) -> (a -> Maybe (Outcome, [c])) +drawWhen pred x = (Draw, ) <$> pred x + +-- | Combines two criteria into one where if the first criterion does not +-- return a game over state, the result of the second criterion is used. +ifNotThen :: (a -> Maybe (Outcome, [c])) + -> (a -> Maybe (Outcome, [c])) + -> (a -> Maybe (Outcome, [c])) +ifNotThen crit1 crit2 x = crit1 x <|> crit2 x + +infixl 8 `unless` +-- | Combines two criteria into one where the first criterions result is +-- returned, unless the second criterion returns a game over state. +unless :: (a -> Maybe (Outcome, [c])) + -> (a -> Maybe (Outcome, [c])) + -> (a -> Maybe (Outcome, [c])) +unless = flip ifNotThen + +-- | Combines several criteria into one. If two or more of the criteria returns +-- different game over states, an error is raised. +criteria :: [a -> Maybe (Outcome, [c])] -> a -> Maybe (Outcome, [c]) +criteria = foldl1 ifNotThen + +-- | Create a symmetric game from a game defined for only one player. +symmetric :: (a -> a) -> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c]) +symmetric flipState criterion = criterion `ifNotThen` (fmap (first $ mapOutcome nextPlayer) . criterion . flipState) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ src/Boardgame/ColoredGraph.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} + +{-| +Module: Boardgame.ColoredGraph +Description: A graph library specialized for boardgames. Colored graphs have + colors, or values, on each vertex and each edge. + +This module contains helper functions for games that can be modeled as graphs. + +It contains a few functions for creating graphs of different shapes and with +different properties. 'hexHexGraph', 'paraHexGraph', 'rectOctGraph', and more. + +It also contains a few functions that can automatically implement +'Boardgame.PositionalGame' for most cases. These are named after the function +they implement, prefixed with @coloredGraph@ and the addition of how the +implement them. For example 'coloredGraphGetVertexPosition' and +'coloredGraphSetBidirectedEdgePosition'. +-} +module Boardgame.ColoredGraph ( + ColoredGraph + , ColoredGraphTransformer(..) + , hexHexGraph + , paraHexGraph + , rectOctGraph + , triHexGraph + , completeGraph + , mapValues + , mapEdges + , filterValues + , filterEdges + , filterG + , components + , anyConnections + , edgePath + , inARow + , values + , winningSetPaths + , winningSetPaths' + , coloredGraphVertexPositions + , coloredGraphSetVertexPosition + , coloredGraphGetVertexPosition + , coloredGraphEdgePositions + , coloredGraphGetEdgePosition + , coloredGraphSetEdgePosition + , coloredGraphSetBidirectedEdgePosition +) where + +import Data.Map (Map, mapMaybeWithKey, filterWithKey) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.List ( find, intersect, (\\) ) +import Data.Maybe ( fromJust, isJust, listToMaybe, mapMaybe ) +import Data.Tree (Tree(..), foldTree) +import Control.Monad ((<=<)) +import Data.Bifunctor ( bimap, Bifunctor (first, second) ) +import Boardgame (Position(..)) + + +-- | A Graph with colored vertices and edges. The key of the map is 'i', the +-- "coordinates". The value of the map is a tuple of vertices color 'a', and +-- a list of edges. The edges are tuples of edge color 'b' and +-- "target coordinate" 'i'. +type ColoredGraph i a b = Map i (a, Map i b) + +type Coordinate = (Int, Int) + +-- The six directions of neighbours on a hexagonal grid. +hexDirections :: [Coordinate] +hexDirections = + [ (1, 0) + , (1, -1) + , (0, -1) + , (-1, 0) + , (-1, 1) + , (0, 1) + ] + +-- Returns the six neighboring coordinates of the given coordinate on a +-- hexagonal grid. +hexNeighbors :: Coordinate -> [Coordinate] +hexNeighbors (i, j) = bimap (+ i) (+ j) <$> hexDirections + +-- The eight directions of neighbours on a square grid. +octoDirections :: [Coordinate] +octoDirections = + [ (1, 0) + , (1, -1) + , (0, -1) + , (-1, -1) + , (-1, 0) + , (-1, 1) + , (0, 1) + , (1, 1) + ] + +-- Returns the eight neighboring coordinates of the given coordinate on a +-- square grid. +octoNeighbors :: Coordinate -> [Coordinate] +octoNeighbors (i, j) = bimap (+ i) (+ j) <$> octoDirections + + + + +-- Maps over the individual values of a tuple. +mapBoth :: (a -> b) -> (a, a) -> (b, b) +mapBoth f (x, y) = (f x, f y) + +-- Combines two tuples using the given function. +binaryOp :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c) +binaryOp op (x, y) (z, w) = (op x z, op y w) + + +hexHexGraphRing :: Int -> [Coordinate] +hexHexGraphRing base = concat [oneSide k | k <- [0..5]] + where + oneSide :: Int -> [Coordinate] + oneSide i = [binaryOp (\z w -> base*z + k*w) (hexDirections !! i) (hexDirections !! ((i+2) `mod` 6)) | k <- [1..base]] + +-- Returns the distance between two hexagonal coordinates. +distance :: Coordinate -> Coordinate -> Int +distance (x, y) (i, j) = (abs(x - i) + abs(x + y - i - j) + abs(y - j)) `div` 2 + +-- | Creates a hexagon shaped graph of hexagon vertices (each vertex has six +-- outgoing edges) with the given radius. +-- +-- The "coordinates" of the graph will be '(Int, Int)' where '(0, 0)' is at +-- the center. The color of edges will also be a '(Int, Int)' tuple that +-- shows the "direction" of the edge. +hexHexGraph :: Int -> ColoredGraph (Int, Int) Position (Int, Int) +hexHexGraph radius = Map.fromList ((\z -> (z , (Empty, Map.fromList $ filter ((< radius) . distance (0, 0) . fst) $ (\i -> (hexNeighbors z !! i, hexDirections !! i)) <$> [0..5]))) <$> nodes) + where + nodes :: [Coordinate] + nodes = (0, 0) : concatMap hexHexGraphRing [1..radius-1] + + + + + +-- | Creates a parallelogram shaped graph of hexagon vertices (each vertex has +-- six outgoing edges) with the given side length. +-- +-- The "coordinates" of the graph will be '(Int, Int)' where '(0, 0)' is at +-- the center. The color of edges will also be a '(Int, Int)' tuple that +-- shows the "direction" of the edge. +paraHexGraph :: Int -> ColoredGraph (Int, Int) Position (Int, Int) +paraHexGraph n = Map.fromList ((\z -> (z , (Empty, Map.fromList $ filter ((\(i, j) -> i < n && i >= 0 && j < n && j >= 0) . fst) $ (\i -> (hexNeighbors z !! i, hexDirections !! i)) <$> [0..5]))) <$> nodes) + where + nodes :: [Coordinate] + nodes = [(i, j) | i <- [0..n-1], j <- [0..n-1]] + +-- | Creates a rectangular shaped graph of octagon vertices (each vertex has +-- eight outgoing edges) with the given width and height. +-- +-- The "coordinates" of the graph will be '(Int, Int)' where '(0, 0)' the top +-- left vertex. The color of edges will also be a '(Int, Int)' tuple that +-- shows the "direction" of the edge. +rectOctGraph :: Int -> Int -> ColoredGraph (Int, Int) Position (Int, Int) +rectOctGraph m n = Map.fromList ((\z -> (z , (Empty, Map.fromList $ filter ((\(i, j) -> i < m && i >= 0 && j < n && j >= 0) . fst) $ (\i -> (octoNeighbors z !! i, octoDirections !! i)) <$> [0..7]))) <$> nodes) + where + nodes :: [Coordinate] + nodes = [(i, j) | i <- [0..m-1], j <- [0..n-1]] + +-- | Creates a triangular shaped graph of hexagon vertices (each vertex has +-- six outgoing edges) with the given side length. +-- +-- The "coordinates" of the graph will be '(Int, Int)' where '(1, n-1)', +-- '(n-1, 1)' and '(n-1, n-1)' are the 3 corners. The color of edges will +-- also be a '(Int, Int)' tuple that shows the "direction" of the edge. +triHexGraph :: Int -> ColoredGraph (Int, Int) Position (Int, Int) +triHexGraph n = Map.fromList ((\z -> (z, (Empty, Map.fromList $ filter ((\(i, j) -> i < n && i >= 0 && j < n && j >= 0 && i + j >= n) . fst) $ (\i -> (hexNeighbors z !! i, hexDirections !! i)) <$> [0 .. 5]))) <$> nodes) + where + nodes :: [Coordinate] + nodes = [(i, j) | i <- [0 .. n -1], j <- [0 .. n -1], i + j >= n] + +-- | Creates a complete graph with n vertices. +completeGraph :: Int -> ColoredGraph Int () () +completeGraph n = Map.fromList [ (i, ((), Map.fromList [(j, ()) | j <- [0..n-1], i /= j])) | i <- [0..n-1]] + + + + + + + +-- Returns the first value that is accepted by the predicate, or 'Nothing'. +firstJust :: (a -> Maybe b) -> [a] -> Maybe b +firstJust f = listToMaybe . mapMaybe f + +-- Maps the vertices, and their outgoing edges with values, and collects the +-- 'Just' results. +mapMaybeG :: Ord i => ((a, Map i b) -> Maybe c) -> ColoredGraph i a b -> ColoredGraph i c b +mapMaybeG f g = fmap (second (Map.filterWithKey (\k _ -> Map.member k g'))) g' + where + g' = Map.mapMaybe (\(a, xs) -> (, xs) <$> f (a, xs)) g + +-- | Filters out any vertices whose value, and their outgoing edges with +-- values, is not accepted by the predicate. +filterG :: Ord i => ((a, Map i b) -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b +filterG pred = mapMaybeG (\(z, w) -> if pred (z, w) then Just z else Nothing) + +-- | Filters out any vertices whose value is not accepted by the predicate. +filterValues :: Ord i => (a -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b +filterValues pred = filterG $ pred . fst + +-- | Maps the values of vertices with the given function. +mapValues :: Ord i => (a -> c) -> ColoredGraph i a b -> ColoredGraph i c b +mapValues = fmap . first + +-- | Maps the values of edges with the given function. +mapEdges :: Ord i => (b -> c) -> ColoredGraph i a b -> ColoredGraph i a c +mapEdges = fmap . second . fmap + +-- Returns a list of "coordinates" for vertices whose value, and their outgoing +-- edges with values, are accepted by the predicate. +nodesPred :: (a -> Map i b -> Bool) -> ColoredGraph i a b -> [i] +nodesPred pred g = fst <$> filter (uncurry pred . snd) (Map.toList g) + +-- | Filters out any edges whose value is not accepted by the predicate. +filterEdges :: (b -> Bool) -> ColoredGraph i a b -> ColoredGraph i a b +filterEdges pred = fmap $ second $ Map.filter pred + +-- Returns a path from i to j, including what edge value to take. +path :: Ord i => ColoredGraph i a b -> i -> i -> Maybe [(b, i)] +path = path' Set.empty + +-- Returns a path from i to j, including what edge value to take. With a set of +-- already visited "coordinates". +path' :: Ord i => Set i -> ColoredGraph i a b -> i -> i -> Maybe [(b, i)] +path' s g i j + | i == j = Just [] + | otherwise = firstJust (\(k, d) -> ((d, k):) <$> path' s' g k j) $ filter (\(k, _) -> not $ k `Set.member` s') neighbours + where + neighbours = Map.assocs $ snd $ g Map.! i + s' = Set.insert i s + + +-- | A list of all vertices grouped by connected components. +components :: (Eq i, Ord i) => ColoredGraph i a b -> [[i]] +components = components' [] + where + components' :: (Eq i, Ord i) => [[i]] -> ColoredGraph i a b -> [[i]] + components' state g = case find (\k -> all (notElem k) state) (Map.keys g) of + Just i -> components' (component g i : state) g + Nothing -> state + + +-- List all the connected nodes starting from one node, also known as a connected component. +component :: Ord i => ColoredGraph i a b -> i -> [i] +component g = fst . component' Set.empty g + where + component' :: Ord i => Set i -> ColoredGraph i a b -> i -> ([i], Set i) + component' inputState g i = (i : xs, newState) + where + neighbours = Map.assocs $ snd $ g Map.! i + (xs, newState) = foldl tmp ([], Set.insert i inputState) (fst <$> neighbours) + + tmp (ks, state) k + | k `Set.member` state = (ks, state) + | otherwise = let (x, y) = component' state g k in (ks ++ x, y) + +-- | Returns a list of vertex values from the given graph. +values :: ColoredGraph i a b -> [a] +values = fmap fst . Map.elems + +-- | Returns a graph formed from a subset of vertices and +-- all edges connecting those vertices in the original graph. +inducedSubgraph :: Eq i => ColoredGraph i a b -> [i] -> ColoredGraph i a b +inducedSubgraph g nodes = mapMaybeWithKey tmp g + where + tmp i (a, xs) = if i `elem` nodes + then Just (a, filterWithKey (const . flip elem nodes) xs) + else Nothing + +-- | For every component of G, count how many groups of nodes they overlap with +-- and check if the predicate holds on the count. If it matches on any +-- component then return that component. We also try to return only the parts +-- of the component that are necessary for our predicate to hold. +anyConnections :: Ord i => (Int -> Bool) -> [[i]] -> ColoredGraph i a b -> Maybe [i] +anyConnections pred groups = findComponent cond + where + cond z = pred $ length $ filter (not . Prelude.null . intersect z) groups + +-- | Is there a component along edges with value `dir` that has a length +-- accepted by `pred`? If there is we return a subset of that component that +-- matches the predicate +inARow :: (Ord i, Eq b) => (Int -> Bool) -> b -> ColoredGraph i a b -> Maybe [i] +inARow pred dir = findComponent (pred . length) . filterEdges (==dir) + +-- | Try to find a component of the graph that matches the predicate. +-- The component that is returned is minimized using a greedy +-- search while still matching our predicate. +findComponent :: Ord i => ([i] -> Bool) -> ColoredGraph i a b -> Maybe [i] +findComponent pred g = minimizeComponent <$> find pred (components g) + where + -- Remove elements from xs while the condition holds. + minimizeComponent xs = maybe xs minimizeComponent $ find cond $ oneRemoved xs + where + -- The condition we want to hold is our + -- predicate and that we only have one component. + cond z = pred z && 1 == length (components $ inducedSubgraph g z) + -- Lists where we have removed one element from the input. + oneRemoved :: [i] -> [[i]] + oneRemoved [] = [] + oneRemoved [x] = [[]] + oneRemoved (x:xs) = xs : ((x:) <$> oneRemoved xs) + +-- | Returns the winning sets representing paths from one set of nodes to +-- another on a graph. +winningSetPaths :: Ord i => ColoredGraph i a b -> [i] -> [i] -> [[i]] +winningSetPaths g is js = concat [foldTree (\(isLeaf, z) xs -> if isLeaf then [[z]] else concatMap (fmap (z:)) xs) $ winningSetPaths' g start i goal | i <- is] + where + allTrue = True <$ g + start = foldr (`Map.insert` False) allTrue is + + allFalse = False <$ g + goal = foldr (`Map.insert` True) allFalse js + +-- | Returns a tree representing all paths from a starting node too any node in +-- the goal. The paths do not "touch" themselves and they only use a set of +-- allowed nodes. That they don't touch means that we generate exactly the +-- minimum set of winning sets that cover reaching from our starting node to +-- the goal. +winningSetPaths' :: Ord i => ColoredGraph i a b -> Map i Bool -> i -> Map i Bool -> Tree (Bool, i) +winningSetPaths' g allowed i goal = Node (False, i) $ (\k -> if fromJust $ Map.lookup k goal then Node (True, k) [] else winningSetPaths' g allowed' k goal) <$> neighbourIndices + where + neighbourIndices = filter (fromJust . flip Map.lookup allowed) $ Map.keys $ snd $ fromJust $ Map.lookup i g + allowed' = foldr (`Map.insert` False) allowed neighbourIndices + +-- | Takes a path of vertices and returns a path of edges. Where the edges are +-- pairs of from and to vertices. +edgePath :: [a] -> [(a, a)] +edgePath a = zip a (tail a) + +-- | A standard implementation of 'MyLib.positions' for games +-- with an underlying 'ColoredGraph' played on the vertices. +-- +-- For 'ColoredGraph's, this is a synonym of 'values'. +coloredGraphVertexPositions :: (ColoredGraphTransformer i a b g, Ord i) => g -> [a] +coloredGraphVertexPositions = values . toColoredGraph + +-- | A standard implementation of 'MyLib.getPosition' for games +-- with an underlying 'ColoredGraph' played on the vertices. +coloredGraphGetVertexPosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> i -> Maybe a +coloredGraphGetVertexPosition g i = fst <$> Map.lookup i (toColoredGraph g) + +-- | A standard implementation of 'MyLib.setPosition' for games +-- with an underlying 'ColoredGraph' played on the vertices. +coloredGraphSetVertexPosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> i -> a -> Maybe g +coloredGraphSetVertexPosition g i p = if Map.member i c + then Just $ fromColoredGraph g $ Map.adjust (\(_, xs) -> (p, xs)) i c + else Nothing + where + c = toColoredGraph g + +-- | A standard implementation of 'MyLib.positions' for games +-- with an underlying 'ColoredGraph' played on the edges. +coloredGraphEdgePositions :: (ColoredGraphTransformer i a b g, Ord i) => g -> [b] +coloredGraphEdgePositions = Map.elems . snd <=< Map.elems . toColoredGraph + +-- | A standard implementation of 'MyLib.getPosition' for games +-- with an underlying 'ColoredGraph' played on the edges. +coloredGraphGetEdgePosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> (i, i) -> Maybe b +coloredGraphGetEdgePosition g (from, to) = Map.lookup from (toColoredGraph g) >>= (Map.lookup to . snd) + +-- | A standard implementation of 'MyLib.setPosition' for games +-- with an underlying 'ColoredGraph' played on the vertices. +coloredGraphSetEdgePosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> (i, i) -> b -> Maybe g +coloredGraphSetEdgePosition g (from, to) p = Map.lookup from c >>= + \(a, edges) -> if Map.member to edges + then Just $ fromColoredGraph g $ Map.insert from (a, Map.insert to p edges) c + else Nothing + where + c = toColoredGraph g + +-- | Like 'coloredGraphSetEdgePosition' but sets the value to the edges in both +-- directions. +coloredGraphSetBidirectedEdgePosition :: (ColoredGraphTransformer i a b g, Ord i) => g -> (i, i) -> b -> Maybe g +coloredGraphSetBidirectedEdgePosition c (from, to) p = coloredGraphSetEdgePosition c (from, to) p >>= + \c' -> coloredGraphSetEdgePosition c' (to, from) p + +-- | A utility class for transforming to and from 'ColoredGraph'. +-- +-- New-types of 'ColoredGraph' can derive this using the +-- 'GeneralizedNewtypeDeriving' language extension. +class ColoredGraphTransformer i a b g | g -> i, g -> a, g -> b where + -- | "Extracts" the 'ColoredGraph' from a container type. + toColoredGraph :: g -> ColoredGraph i a b + -- | "Inserts" the 'ColoredGraph' into an already existing container type. + fromColoredGraph :: g -> ColoredGraph i a b -> g + +instance ColoredGraphTransformer i a b (ColoredGraph i a b) where + toColoredGraph c = c + fromColoredGraph _ = id
+ src/Boardgame/Web.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE LambdaCase #-} + +{-| +Module: Boardgame.Web +Description: Functions that interact with a JavaScript runtime through WASM. + +This module is useful if you wish to create web UI through the use of +<https://webassembly.org/ WebAssembly> and regular web technologies. + +Our complementary <https://github.com/Boardgame-DSL/boardgame.js#boardgamejs boardgame.js> +JavaScript library can be useful as it contains the necessary JavaScript +functions and some extra helper functions. + += Usage example + +== Simple +Imagine a 'Boardgame.PositionalGame' called @TicTacToe@, with a function +@newTicTacToe@ that instantiates it. If you wish to build a web UI for the +game, you can use the default way of exposing the Haskell model to the +JavaScript runtime: + +> main = defaultWebGame newTicTacToe + +After that, the game can be started form the JavaScript runtime with the +function @window.boardgame.games.default()@. + +== Multiple games +If you also have another game, say @Hex@ with a function @newHex@. And you want +to play both from the same UI you can instead use the following method. + +> main = do +> addWebGame "TicTacToe" newTicTacToe +> addWebGame "Hex" newHex +> webReady + +With this, the JavaScript runtime can access both games through the +@window.boardgame.games@ object. @window.boardgame.games.TicTacToe()@ and +@window.boardgame.games.Hex()@ respectively. + +The 'webReady' call is used to invoke the @window.boardgame.initialized@ event. + += Remember +Compile with <https://github.com/tweag/asterius/ Asterius> and the @wasm@ flag +active. + +> ahc-cabal new-build --flags="wasm" +-} +module Boardgame.Web ( + playWeb + , defaultWebGame + , addWebGame + , webReady +) where + +import Asterius.Aeson (jsonFromJSVal, jsonToJSVal) +import Asterius.Types (JSVal) +import Data.Aeson (FromJSON, ToJSON) +import Data.Functor ((<&>)) +import Boardgame ( + Player(..) + , PositionalGame(..) + , playerToInt + , play + ) + +foreign import javascript "wrapper" jsMakeCallback :: IO () -> IO JSVal + +foreign import javascript "boardgame._putState($1)" jsPutState :: JSVal -> IO () +foreign import javascript "boardgame._putTurn($1)" jsPutTurn :: Int -> IO () +foreign import javascript safe "boardgame._getMove()" jsGetMove :: IO JSVal +foreign import javascript "boardgame._putInvalidInput()" jsPutInvalidInput :: IO () +foreign import javascript "boardgame._putInvalidMove()" jsPutInvalidMove :: IO () +foreign import javascript "boardgame._putGameOver($1, $2)" jsPutGameOver :: JSVal -> JSVal -> IO () +foreign import javascript "boardgame.games[$1] = $2" jsSetGame :: JSVal -> JSVal -> IO () +foreign import javascript "boardgame._ready()" jsReady :: IO () + +-- | A main function for running games as a web app. Initializes the provided +-- game as "default" and "tells" JavaScript it's ready. Then JavaScript can +-- start games whenever. +defaultWebGame :: (ToJSON a, ToJSON c, FromJSON c, PositionalGame a c) => a -> IO () +defaultWebGame startState = do + callback <- jsMakeCallback $ playWeb startState + jsSetGame (jsonToJSVal "default") callback + jsReady + +-- | Adds a named game to the list of games accessible from JavaScript. +addWebGame :: (ToJSON a, ToJSON c, FromJSON c, PositionalGame a c) => String -> a -> IO () +addWebGame name startState = do + callback <- jsMakeCallback $ playWeb startState + jsSetGame (jsonToJSVal name) callback + +-- | Lets JavaScript know that the Haskell backend is up and running by firing +-- the ready event. +webReady :: IO () +webReady = jsReady + +-- | Plays a 'PositionalGame' with the help of JavaScript FFI. The state of the +-- game ('a') needs to implement 'Data.Aeson.ToJSON' and the coordinates +-- ('c') needs to implement 'Data.Aeson.FromJSON'. This is because they need +-- to be passed to and from (respectively) the JavaScript runtime. +playWeb :: (ToJSON a, ToJSON c, FromJSON c, PositionalGame a c) => a -> IO () +playWeb = play putState putTurn getMove putInvalidMove putGameOver + where + putState = jsPutState . jsonToJSVal + putTurn = jsPutTurn . playerToInt + getMove = jsGetMove <&> jsonFromJSVal >>= \case + Left _ -> jsPutInvalidInput >> getMove + Right c -> return c + putInvalidMove = jsPutInvalidMove + putGameOver (x, y) = jsPutGameOver (jsonToJSVal x) (jsonToJSVal y)
+ tests/BoardgameTest.hs view
@@ -0,0 +1,4 @@+module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."