{-# 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 (Int -> Player -> ShowS
[Player] -> ShowS
Player -> String
(Int -> Player -> ShowS)
-> (Player -> String) -> ([Player] -> ShowS) -> Show Player
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Player] -> ShowS
$cshowList :: [Player] -> ShowS
show :: Player -> String
$cshow :: Player -> String
showsPrec :: Int -> Player -> ShowS
$cshowsPrec :: Int -> Player -> ShowS
Show, Player -> Player -> Bool
(Player -> Player -> Bool)
-> (Player -> Player -> Bool) -> Eq Player
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Player -> Player -> Bool
$c/= :: Player -> Player -> Bool
== :: Player -> Player -> Bool
$c== :: Player -> Player -> Bool
Eq)

-- | Returns the "next" player in turn.

nextPlayer :: Player -> Player
nextPlayer :: Player -> Player
nextPlayer Player
Player1 = Player
Player2
nextPlayer Player
Player2 = Player
Player1

-- | Turns a 'Player' into an int. 1 or 2 for the player respectively.

playerToInt :: Player -> Int
playerToInt :: Player -> Int
playerToInt Player
Player1 = Int
1
playerToInt Player
Player2 = Int
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 (Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: Position -> Position -> Bool
Eq, Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
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 :: (Player -> Player) -> Position -> Position
mapPosition Player -> Player
f (Occupied Player
p) = Player -> Position
Occupied (Player -> Position) -> Player -> Position
forall a b. (a -> b) -> a -> b
$ Player -> Player
f Player
p
mapPosition Player -> Player
_ Position
Empty     = Position
Empty

-- | Checks if the position is occupied or not.

isOccupied :: Position -> Bool
isOccupied :: Position -> Bool
isOccupied (Occupied Player
_) = Bool
True
isOccupied Position
Empty     = Bool
False

-- | Checks if the position is empty or not.

isEmpty :: Position -> Bool
isEmpty :: Position -> Bool
isEmpty (Occupied Player
_) = Bool
False
isEmpty Position
Empty        = Bool
True

-- | The 'Outcome' of a game. Either a 'Win' for one of the players, or a

--   'Draw'.

data Outcome = Win Player | Draw
  deriving (Outcome -> Outcome -> Bool
(Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool) -> Eq Outcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Outcome -> Outcome -> Bool
$c/= :: Outcome -> Outcome -> Bool
== :: Outcome -> Outcome -> Bool
$c== :: Outcome -> Outcome -> Bool
Eq, Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
(Int -> Outcome -> ShowS)
-> (Outcome -> String) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Outcome] -> ShowS
$cshowList :: [Outcome] -> ShowS
show :: Outcome -> String
$cshow :: Outcome -> String
showsPrec :: Int -> Outcome -> ShowS
$cshowsPrec :: Int -> Outcome -> ShowS
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 :: (Player -> Player) -> Outcome -> Outcome
mapOutcome Player -> Player
f (Win Player
p) = Player -> Outcome
Win (Player -> Outcome) -> Player -> Outcome
forall a b. (a -> b) -> a -> b
$ Player -> Player
f Player
p
mapOutcome Player -> Player
_ Outcome
Draw    = Outcome
Draw

-- | Checks if the outcome is a victory or not.

isWin :: Outcome -> Bool
isWin :: Outcome -> Bool
isWin (Win Player
_) = Bool
True
isWin Outcome
Draw    = Bool
False

-- | Checks if the outcome is a draw or not.

isDraw :: Outcome -> Bool
isDraw :: Outcome -> Bool
isDraw (Win Player
_) = Bool
False
isDraw Outcome
Draw    = Bool
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 = a -> Player -> c -> Maybe a
forall a c. PositionalGame a c => a -> Player -> c -> Maybe a
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 -> Player -> c -> Maybe a
takeEmptyMakeMove a
a Player
p c
coord = case a -> c -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition a
a c
coord of
  Just Position
Empty -> a -> c -> Position -> Maybe a
forall a c. PositionalGame a c => a -> c -> Position -> Maybe a
setPosition a
a c
coord (Player -> Position
Occupied Player
p)
  Maybe Position
_          -> Maybe a
forall a. Maybe a
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 :: [[c]] -> a -> Maybe (Outcome, [c])
patternMatchingGameOver [[c]]
patterns a
a = case ((Position, [c]) -> Bool)
-> [(Position, [c])] -> Maybe (Position, [c])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Position -> Bool
isOccupied (Position -> Bool)
-> ((Position, [c]) -> Position) -> (Position, [c]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, [c]) -> Position
forall a b. (a, b) -> a
fst) ([(Position, [c])] -> Maybe (Position, [c]))
-> [(Position, [c])] -> Maybe (Position, [c])
forall a b. (a -> b) -> a -> b
$ (\[c]
pat -> (, [c]
pat) (Position -> (Position, [c])) -> Position -> (Position, [c])
forall a b. (a -> b) -> a -> b
$ [Position] -> Position
reduceHomogeneousList (Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Position -> Position)
-> (c -> Maybe Position) -> c -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition a
a (c -> Position) -> [c] -> [Position]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [c]
pat)) ([c] -> (Position, [c])) -> [[c]] -> [(Position, [c])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[c]]
patterns of
    Maybe (Position, [c])
Nothing -> if (Position -> Bool) -> [Position] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Position -> Bool
isOccupied (a -> [Position]
forall a c. PositionalGame a c => a -> [Position]
positions a
a) then (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Outcome
Draw, []) else Maybe (Outcome, [c])
forall a. Maybe a
Nothing
    Just (Occupied Player
winner, [c]
coords) -> (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Player -> Outcome
Win Player
winner, [c]
coords)
    Just (Position
Empty, [c]
coords)           -> (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Outcome
Draw, [c]
coords)
  where
    -- | Returns an element of the homogeneous list, or 'Empty'.

    reduceHomogeneousList :: [Position] -> Position
    reduceHomogeneousList :: [Position] -> Position
reduceHomogeneousList []     = Position
Empty
    reduceHomogeneousList (Position
x:[Position]
xs) = if (Position -> Bool) -> [Position] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
x) [Position]
xs then Position
x else Position
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 :: [[c]] -> a -> Maybe (Outcome, [c])
makerBreakerGameOver [[c]]
patterns a
a
  | Just [c]
coords <- Maybe [c]
player1won = (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Player -> Outcome
Win Player
Player1, [c]
coords)
  | Bool
player2won = (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Player -> Outcome
Win Player
Player2, [c]
player2Coords)
  | Bool
otherwise = Maybe (Outcome, [c])
forall a. Maybe a
Nothing
  where
    player1won :: Maybe [c]
player1won = ([c] -> Bool) -> [[c]] -> Maybe [c]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((c -> Bool) -> [c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((c -> Bool) -> [c] -> Bool) -> (c -> Bool) -> [c] -> Bool
forall a b. (a -> b) -> a -> b
$ (Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Player -> Position
Occupied Player
Player1) (Position -> Bool) -> (c -> Position) -> c -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Position -> Position)
-> (c -> Maybe Position) -> c -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition a
a) [[c]]
patterns
    player2won :: Bool
player2won = ([c] -> Bool) -> [[c]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((c -> Bool) -> [c] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((c -> Bool) -> [c] -> Bool) -> (c -> Bool) -> [c] -> Bool
forall a b. (a -> b) -> a -> b
$ (Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Player -> Position
Occupied Player
Player2) (Position -> Bool) -> (c -> Position) -> c -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Position -> Position)
-> (c -> Maybe Position) -> c -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition a
a) [[c]]
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 :: [c]
player2Coords = ([c] -> [c] -> Ordering) -> [[c]] -> [c]
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy [c] -> [c] -> Ordering
forall a b. [a] -> [b] -> Ordering
compareLength ([[c]] -> [c]) -> [[c]] -> [c]
forall a b. (a -> b) -> a -> b
$ [[c]] -> [[c]]
forall c. Eq c => [[c]] -> [[c]]
assignments ([[c]] -> [[c]]) -> [[c]] -> [[c]]
forall a b. (a -> b) -> a -> b
$ (c -> Bool) -> [c] -> [c]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Player -> Position
Occupied Player
Player2) (Position -> Bool) -> (c -> Position) -> c -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Position -> Position)
-> (c -> Maybe Position) -> c -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition a
a) ([c] -> [c]) -> [[c]] -> [[c]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[c]]
patterns

    -- A lazy version of `comparing length`.

    compareLength              :: [a] -> [b] -> Ordering
    compareLength :: [a] -> [b] -> Ordering
compareLength []     []     = Ordering
EQ
    compareLength (a
_:[a]
_)  []     = Ordering
GT
    compareLength []     (b
_:[b]
_)  = Ordering
LT
    compareLength (a
_:[a]
xs) (b
_:[b]
ys) = [a] -> [b] -> Ordering
forall a b. [a] -> [b] -> Ordering
compareLength [a]
xs [b]
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 :: [[c]] -> [[c]]
assignments = [c] -> [[c]] -> [[c]]
forall a. Eq a => [a] -> [[a]] -> [[a]]
assignments' []
      where
        assignments' :: [a] -> [[a]] -> [[a]]
assignments' [a]
set [] = [[a]
set]
        assignments' [a]
set ([a]
claus:[[a]]
clauses) = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
intersect [a]
set [a]
claus
          then [a] -> [[a]] -> [[a]]
assignments' [a]
set [[a]]
clauses
          else [[[a]]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[a]]] -> [[a]]) -> [[[a]]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (\a
c -> [a] -> [[a]] -> [[a]]
assignments' (a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
set) [[a]]
clauses) (a -> [[a]]) -> [a] -> [[[a]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
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 :: [[c]] -> a -> Maybe (Outcome, [c])
avoiderEnforcerGameOver [[c]]
patterns a
a = (Outcome -> Outcome) -> (Outcome, [c]) -> (Outcome, [c])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Player -> Player) -> Outcome -> Outcome
mapOutcome Player -> Player
nextPlayer) ((Outcome, [c]) -> (Outcome, [c]))
-> Maybe (Outcome, [c]) -> Maybe (Outcome, [c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[c]] -> a -> Maybe (Outcome, [c])
forall c a.
(Eq c, PositionalGame a c) =>
[[c]] -> a -> Maybe (Outcome, [c])
makerBreakerGameOver [[c]]
patterns a
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 :: (a -> m ())
-> (Player -> m ())
-> m c
-> m ()
-> ((Outcome, [c]) -> m ())
-> a
-> m ()
play a -> m ()
putState Player -> m ()
putTurn m c
getMove m ()
putInvalidMove (Outcome, [c]) -> m ()
putGameOver a
startingState = a -> m ()
putState a
startingState m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Player -> m ()
putTurn Player
Player1 m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Player -> m ()
play' a
startingState Player
Player1
  where
    play' :: a -> Player -> m ()
play' a
s Player
p = m c
getMove m c -> (c -> Maybe a) -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> a -> Player -> c -> Maybe a
forall a c. PositionalGame a c => a -> Player -> c -> Maybe a
makeMove a
s Player
p m (Maybe a) -> (Maybe a -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just a
s' -> a -> m ()
putState a
s' m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> case a -> Maybe (Outcome, [c])
forall a c. PositionalGame a c => a -> Maybe (Outcome, [c])
gameOver a
s' of
        Just (Outcome, [c])
v  -> (Outcome, [c]) -> m ()
putGameOver (Outcome, [c])
v
        Maybe (Outcome, [c])
Nothing -> (\Player
p' -> Player -> m ()
putTurn Player
p' m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Player -> m ()
play' a
s' Player
p') (Player -> m ()) -> Player -> m ()
forall a b. (a -> b) -> a -> b
$ Player -> Player
nextPlayer Player
p
      Maybe a
Nothing -> m ()
putInvalidMove m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Player -> m ()
play' a
s Player
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 :: a -> IO ()
playIO = (a -> IO ())
-> (Player -> IO ())
-> IO c
-> IO ()
-> ((Outcome, [c]) -> IO ())
-> a
-> IO ()
forall (m :: * -> *) a c.
(Monad m, PositionalGame a c) =>
(a -> m ())
-> (Player -> m ())
-> m c
-> m ()
-> ((Outcome, [c]) -> m ())
-> a
-> m ()
play a -> IO ()
forall a. Show a => a -> IO ()
putState Player -> IO ()
putTurn IO c
getMove IO ()
putInvalidMove (Outcome, [c]) -> IO ()
putGameOver
  where
    putState :: a -> IO ()
putState a
s = String -> IO ()
putStr String
"\ESC[s\ESC[0;0H" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO ()
forall a. Show a => a -> IO ()
print a
s IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStr String
"\ESC[u" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    putTurn :: Player -> IO ()
putTurn Player
p = String -> IO ()
putStr (String
"Move for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (case Player
p of
      Player
Player1 -> String
"player 1"
      Player
Player2 -> String
"player 2") String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": ") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    getMove :: IO c
getMove = IO String
getLine IO String -> (String -> Maybe c) -> IO (Maybe c)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> String -> Maybe c
forall a. Read a => String -> Maybe a
readMaybe IO (Maybe c) -> (Maybe c -> IO c) -> IO c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just c
c  -> c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return c
c
      Maybe c
Nothing -> String -> IO ()
putStr String
"Invalid input, try again: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout IO () -> IO c -> IO c
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO c
getMove
    putInvalidMove :: IO ()
putInvalidMove = String -> IO ()
putStr String
"Invalid move, try again: " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    putGameOver :: (Outcome, [c]) -> IO ()
putGameOver = \case
      (Win Player
Player1, [c]
p) -> String -> IO ()
putStrLn String
"Player 1 won!" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [c] -> IO ()
forall a. Show a => a -> IO ()
print [c]
p IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      (Win Player
Player2, [c]
p) -> String -> IO ()
putStrLn String
"Player 2 won!" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [c] -> IO ()
forall a. Show a => a -> IO ()
print [c]
p IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
      (Outcome
Draw, [c]
_)      -> String -> IO ()
putStrLn String
"It's a draw!" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
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 a b i j
-> Player -> Either i j -> Maybe (CombinedPositionalGames a b i j)
makeMove (CombinedPositionalGames a
x b
y) Player
player Either i j
index = case Either i j
index of
    Left i
i -> (a -> b -> CombinedPositionalGames a b i j)
-> b -> a -> CombinedPositionalGames a b i j
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> CombinedPositionalGames a b i j
forall a b i j. a -> b -> CombinedPositionalGames a b i j
CombinedPositionalGames b
y (a -> CombinedPositionalGames a b i j)
-> Maybe a -> Maybe (CombinedPositionalGames a b i j)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Player -> i -> Maybe a
forall a c. PositionalGame a c => a -> Player -> c -> Maybe a
makeMove a
x Player
player i
i
    Right j
i -> a -> b -> CombinedPositionalGames a b i j
forall a b i j. a -> b -> CombinedPositionalGames a b i j
CombinedPositionalGames a
x (b -> CombinedPositionalGames a b i j)
-> Maybe b -> Maybe (CombinedPositionalGames a b i j)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Player -> j -> Maybe b
forall a c. PositionalGame a c => a -> Player -> c -> Maybe a
makeMove b
y Player
player j
i
  gameOver :: CombinedPositionalGames a b i j -> Maybe (Outcome, [Either i j])
gameOver (CombinedPositionalGames a
x b
y) = (([i] -> [Either i j]) -> (Outcome, [i]) -> (Outcome, [Either i j])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((i -> Either i j) -> [i] -> [Either i j]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i -> Either i j
forall a b. a -> Either a b
Left)  ((Outcome, [i]) -> (Outcome, [Either i j]))
-> Maybe (Outcome, [i]) -> Maybe (Outcome, [Either i j])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe (Outcome, [i])
forall a c. PositionalGame a c => a -> Maybe (Outcome, [c])
gameOver a
x)
                                       Maybe (Outcome, [Either i j])
-> Maybe (Outcome, [Either i j]) -> Maybe (Outcome, [Either i j])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (([j] -> [Either i j]) -> (Outcome, [j]) -> (Outcome, [Either i j])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((j -> Either i j) -> [j] -> [Either i j]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap j -> Either i j
forall a b. b -> Either a b
Right) ((Outcome, [j]) -> (Outcome, [Either i j]))
-> Maybe (Outcome, [j]) -> Maybe (Outcome, [Either i j])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Maybe (Outcome, [j])
forall a c. PositionalGame a c => a -> Maybe (Outcome, [c])
gameOver b
y)
  positions :: CombinedPositionalGames a b i j -> [Position]
positions (CombinedPositionalGames a
x b
y) = a -> [Position]
forall a c. PositionalGame a c => a -> [Position]
positions a
x [Position] -> [Position] -> [Position]
forall a. [a] -> [a] -> [a]
++ b -> [Position]
forall a c. PositionalGame a c => a -> [Position]
positions b
y
  getPosition :: CombinedPositionalGames a b i j -> Either i j -> Maybe Position
getPosition (CombinedPositionalGames a
x b
y) = (i -> Maybe Position)
-> (j -> Maybe Position) -> Either i j -> Maybe Position
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (a -> i -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition a
x) (b -> j -> Maybe Position
forall a c. PositionalGame a c => a -> c -> Maybe Position
getPosition b
y)
  setPosition :: CombinedPositionalGames a b i j
-> Either i j
-> Position
-> Maybe (CombinedPositionalGames a b i j)
setPosition (CombinedPositionalGames a
x b
y) Either i j
ij Position
p = case Either i j
ij of
    Left i
i -> (a -> b -> CombinedPositionalGames a b i j)
-> b -> a -> CombinedPositionalGames a b i j
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> CombinedPositionalGames a b i j
forall a b i j. a -> b -> CombinedPositionalGames a b i j
CombinedPositionalGames b
y (a -> CombinedPositionalGames a b i j)
-> Maybe a -> Maybe (CombinedPositionalGames a b i j)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> i -> Position -> Maybe a
forall a c. PositionalGame a c => a -> c -> Position -> Maybe a
setPosition a
x i
i Position
p
    Right j
j -> a -> b -> CombinedPositionalGames a b i j
forall a b i j. a -> b -> CombinedPositionalGames a b i j
CombinedPositionalGames a
x (b -> CombinedPositionalGames a b i j)
-> Maybe b -> Maybe (CombinedPositionalGames a b i j)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> j -> Position -> Maybe b
forall a c. PositionalGame a c => a -> c -> Position -> Maybe a
setPosition b
y j
j Position
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 :: (a -> Bool) -> a -> Maybe (Outcome, [c])
player1WinsIf a -> Bool
pred a
x = if a -> Bool
pred a
x
  then (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Player -> Outcome
Win Player
Player1, [])
  else Maybe (Outcome, [c])
forall a. Maybe a
Nothing

-- | A synonym for 'player1WinsIf'. When player 2 loses, player 1 wins.

player2LosesIf :: (a -> Bool) -> a -> Maybe (Outcome, [c])
player2LosesIf :: (a -> Bool) -> a -> Maybe (Outcome, [c])
player2LosesIf = (a -> Bool) -> a -> Maybe (Outcome, [c])
forall a c. (a -> Bool) -> a -> Maybe (Outcome, [c])
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 :: (a -> Bool) -> a -> Maybe (Outcome, [c])
player2WinsIf a -> Bool
pred a
x = if a -> Bool
pred a
x
  then (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Player -> Outcome
Win Player
Player2, [])
  else Maybe (Outcome, [c])
forall a. Maybe a
Nothing

-- | A synonym for 'player2WinsIf'. When player 1 loses, player 2 wins.

player1LosesIf :: (a -> Bool) -> a -> Maybe (Outcome, [c])
player1LosesIf :: (a -> Bool) -> a -> Maybe (Outcome, [c])
player1LosesIf = (a -> Bool) -> a -> Maybe (Outcome, [c])
forall a c. (a -> Bool) -> a -> Maybe (Outcome, [c])
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 :: (a -> Bool) -> a -> Maybe (Outcome, [c])
drawIf a -> Bool
pred a
x = if a -> Bool
pred a
x
  then (Outcome, [c]) -> Maybe (Outcome, [c])
forall a. a -> Maybe a
Just (Outcome
Draw, [])
  else Maybe (Outcome, [c])
forall a. Maybe a
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 :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
player1WinsWhen a -> Maybe [c]
pred a
x = (Player -> Outcome
Win Player
Player1, ) ([c] -> (Outcome, [c])) -> Maybe [c] -> Maybe (Outcome, [c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe [c]
pred a
x

-- | A synonym for 'player1WinsIf'. When player 2 loses, player 1 wins.

player2LosesWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
player2LosesWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
player2LosesWhen = (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
forall a c. (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
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 :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
player2WinsWhen a -> Maybe [c]
pred a
x = (Player -> Outcome
Win Player
Player2, ) ([c] -> (Outcome, [c])) -> Maybe [c] -> Maybe (Outcome, [c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  a -> Maybe [c]
pred a
x

-- | A synonym for 'player2WinsIf'. When player 1 loses, player 2 wins.

player1LosesWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
player1LosesWhen :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
player1LosesWhen = (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
forall a c. (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
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 :: (a -> Maybe [c]) -> a -> Maybe (Outcome, [c])
drawWhen a -> Maybe [c]
pred a
x = (Outcome
Draw, ) ([c] -> (Outcome, [c])) -> Maybe [c] -> Maybe (Outcome, [c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe [c]
pred a
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 :: (a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
ifNotThen a -> Maybe (Outcome, [c])
crit1 a -> Maybe (Outcome, [c])
crit2 a
x = a -> Maybe (Outcome, [c])
crit1 a
x Maybe (Outcome, [c])
-> Maybe (Outcome, [c]) -> Maybe (Outcome, [c])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Maybe (Outcome, [c])
crit2 a
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 :: (a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
unless = ((a -> Maybe (Outcome, [c]))
 -> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c]))
-> a
-> Maybe (Outcome, [c])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
forall a c.
(a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
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 :: [a -> Maybe (Outcome, [c])] -> a -> Maybe (Outcome, [c])
criteria = ((a -> Maybe (Outcome, [c]))
 -> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c]))
-> [a -> Maybe (Outcome, [c])] -> a -> Maybe (Outcome, [c])
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
forall a c.
(a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
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 :: (a -> a)
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
symmetric a -> a
flipState a -> Maybe (Outcome, [c])
criterion = a -> Maybe (Outcome, [c])
criterion (a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
forall a c.
(a -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
`ifNotThen` (((Outcome, [c]) -> (Outcome, [c]))
-> Maybe (Outcome, [c]) -> Maybe (Outcome, [c])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Outcome -> Outcome) -> (Outcome, [c]) -> (Outcome, [c])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Outcome -> Outcome) -> (Outcome, [c]) -> (Outcome, [c]))
-> (Outcome -> Outcome) -> (Outcome, [c]) -> (Outcome, [c])
forall a b. (a -> b) -> a -> b
$ (Player -> Player) -> Outcome -> Outcome
mapOutcome Player -> Player
nextPlayer) (Maybe (Outcome, [c]) -> Maybe (Outcome, [c]))
-> (a -> Maybe (Outcome, [c])) -> a -> Maybe (Outcome, [c])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe (Outcome, [c])
criterion (a -> Maybe (Outcome, [c]))
-> (a -> a) -> a -> Maybe (Outcome, [c])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
flipState)