mvr/gist:8081429

## gistfile1.lhs
A Whirlwind Tour of Combinatorial Games in Haskell
==================================================

Combinatorial games are an interesting class of games where two
players take turns to make a move, changing the game from one position
to another. In these games, both players have perfect information
about the state of the game and there is no element of chance. In
'normal play', the winner is declared when the other player is unable
to move. A lot of famous strategy games can be analysed as
combinatorial games: chess, go, tic-tac-toe.

The simplest way of thinking of these games is as a set of moves for
the player Left, and a set of moves for the player Right. When a
player chooses an option from their set, this new position can be
considered another game. This gives us a tree-like structure:

> import Prelude hiding ((||))
> import qualified Prelude ((||))
> import Control.Monad
> import Data.List
> import Data.Maybe
> import Data.Ratio
> import Data.Bits
> import Data.Function

> data Game = Game { leftMoves :: [Game], rightMoves :: [Game] }

We write { L | R } for the game where Left can choose a move from L,
and Right can choose a move from R. For example, we have the zero
game, where neither player has any moves they can make: zero = { | }

> zero = Game [] []

In this game, if it's Left's turn, he loses. If it's Right's turn, he
loses. So this game encompases the idea of both players having 0 turns
remaining.

Here's the next simplest game, one = { zero | }

> one = Game [zero] []

Now, if it's Left's turn, he can move to the zero game. If it's
Right's turn, he loses straight away. In this game, Left has one
move's advantage on Right. Similarly, we can define two:

> two = Game [one] []

Now Left has a two move advantage on Right. If we want to classify the
different outcomes a game can have, we find there are only four
options:

1. Left can always win, no matter who starts
2. Right can always win, no matter who starts
3. The second player can always win
4. The first player can always win

We will write these four options as G > 0, G < 0, G = 0, G || 0. It's
clear that zero = 0 and one > 0. We can combine these classes as
usual. For example, G >= 0 means Left can always win if he's the
second player, and in G <= 0 Right can always win if he's the second
player.

These two are easy to implement. If G >= 0, Left can always win as
second player and Right has no good opening move. A good opening move
for Right is a position in R that right could win, i.e. a position
R <= 0. The definition is similar for G <= 0, giving mutually recursive
definitions:

> gteqZero :: Game -> Bool
> lteqZero :: Game -> Bool
> gteqZero = not . any lteqZero . rightMoves
> lteqZero = not . any gteqZero . leftMoves

>-- gteqZero zero ==> True
>-- lteqZero zero ==> True
>-- gteqZero one  ==> True
>-- lteqZero one  ==> False

These are guaranteed to terminate, as at every step we are looking at
a smaller game. From these we can easily build the others:

> eqZero g = gteqZero g && lteqZero g
> gtZero g = gteqZero g && not (lteqZero g)
> ltZero g = not (gteqZero g) && lteqZero g

> fuzzyZero g = not (gteqZero g) && not (lteqZero g)

The last case is strange. We have a game G where neither G >= 0 nor
G <= 0! This corresponds to G || 0 from above, and we say G is fuzzy to
0. We can find such a game easily: ∗ = { zero | zero }. This game
clearly does not correspond to a number.

> star = Game [zero] [zero]

>-- fuzzyZero star ==> True

Now we consider the sum of two games. In the game G + H, a player has
the choice of which component they wish to move in. For example, Left
can choose one of the L moves in G, leaving H the same, or one of the
L moves in H, leaving G the same.

> instance Num Game where
>   g + h = Game left right
>     where left  = map (+ h) (leftMoves g)  ++ map (g +) (leftMoves h)
>           right = map (+ h) (rightMoves g) ++ map (g +) (rightMoves h)

We are also ready to negate games. In -G, Right can make all the moves
Left could, and vice versa. This is just like spinning the board in
chess.

>   negate g = Game (map negate $ rightMoves g) (map negate $ leftMoves g)

With these operations, games form an abelian group. Following the
pattern earlier, converting from integers to games is easy. We have
n = { n-1 | }. If we are given a negative number, we can just negate the
positive game.

>   fromInteger i | i == 0 = zero
>                 | i > 0  = Game [fromInteger (i-1)] []
>                 | i < 0  = negate $ fromInteger (-i)

>   g * h = undefined -- This is possible to define for some games
>   abs g = undefined
>   signum g = undefined

This arithmetic now lets us define equality in a natural way. Two
games are equal if their difference is 0.

> instance Eq Game where
>   g == h = eqZero (g - h)

As we would hope, G = G for every game. Let's think about why this
is. G = G is equivalent to G - G = 0 or G + (-G) = 0. If the first
player makes a move in G, the second player can immediately reply with
the same move in -G. No matter what move the first player makes, the
second has a response in the other component. This can continue until
the first player runs out of options and loses, meaning G + (-G) = 0.

We're ready to show 1 + 1 = 2:

>-- one + one == two ==> True
>-- zero + one == one ==> True
>-- two + two == two ==> False

We see arithmetic behaves as you expect. What about ∗ from earlier?

>-- star + star == zero ==> True

This seems strange at first, but makes sense when we think about how
∗ + ∗ would be played. The first player plays in a ∗, moving it to
0. The other player is then free to play in the other ∗, leaving
0 + 0 = 0, so the first player loses. The first player losing is how
we defined G = 0, so indeed we get ∗ + ∗ = 0.

We can also compare games with each other. We have to cheat here
because Ord is intended for total orders, but from ∗ || 0 it is clear
we can't always put an order on two games.

> instance Ord Game where
>   g < h = ltZero (g - h)
>   g > h = gtZero (g - h)
>   g <= h = lteqZero (g - h)
>   g >= h = gteqZero (g - h)

> g || h = fuzzyZero (g - h)

Now let's consider the game G = { 0 | 1 }. What do we know about it?

> half = Game [zero] [one]
>-- half > 0 ==> True
>-- half < 1 ==> True

We might guess that this game is 1/2. We can check:

>-- half + half == 1 ==> True

And so it is. We could also find a game representing 1/4:

> fourth = Game [zero] [half]
>-- fourth + fourth + fourth + fourth == 1 ==> True

Continuing like this we can construct every dyadic rational,
i.e. rationals where the denominator is a power of two. The idea is,
2p+1 / 2^n = { p / 2^(n-1) | (p+1) / 2^(n-1) }, so we're constructing
dyadic rationals out of simpler ones. It turns out that every real
number can be written as a game. To see how this is possible, notice
that the dyadic rationals are dense in the reals. We could then
squeeze every number between two infinite sequences of dyadic
rationals. For example,

2/3 = { 0, 1/2, 5/8, 21/32 ... | ... 43/64, 11/16, 3/4, 1 }

The only reals with finite representations are the dyadic rationals,
so we'll stick with those. Again we're going to cheat and use
Fractional, even though games in general do not have well defined
division.

> powerOf2 :: (Integral a) => a -> Bool
> powerOf2 n | n == 0 = True
>            | n == 1 = True
>            | even n = powerOf2 (n `div` 2)
>            | otherwise = False

> dyadic :: Rational -> Bool
> dyadic = powerOf2 . denominator

> instance Fractional Game where
>   fromRational r | denominator r == 1 = fromInteger (numerator r)
>                  | dyadic r = Game [left] [right]
>                  | otherwise = error "Cannot convert non-dyadic Rational to Game"
>                  where newNumerator = (numerator r - 1) `div` 2
>                        newDenominator = denominator r `div` 2
>                        left  = fromRational (newNumerator % newDenominator)
>                        right = fromRational ((newNumerator + 1) % newDenominator)

Checking that this works:

>-- fromRational (1%4) == fourth ==> True

If you step back, it's incredible that these games, with such a simple
definition, contain all the real numbers and much more besides.

If we're given a game, we might like to know if it represents a
number. The conditions for this are quite easy; a game is a number if
all its Left and Right options are numbers, and also every Left option
is < every Right option.

> isNumber :: Game -> Bool
> isNumber (Game left right) =    all isNumber left
>                              && all isNumber right
>                              && all (\l -> all (l<) right ) left
>-- isNumber zero ==> True
>-- isNumber one ==> True
>-- isNumber (fromRational (3%8)) ==> True
>-- isNumber star ==> False

It's time to go back and look at some strange infinitesimal games.

Let's consider G = { 0 | ∗ }, written ↑. ↑ is clearly positive, as
Left always wins. To see this, note that if Left moves first, he moves
to zero and Right loses. If Right moves first, he has to move to star,
where Left can move to zero and make him lose again. There is of
course an equivalent game, ↓ for Right.

> up   = Game [zero] [star]
> down = Game [star] [zero] -- = -up

>-- up > 0 ==> True
>-- down < 0 ==> True
>-- isNumber up ==> False
>-- isNumber down ==> False

Just how positive is ↑?

>-- up < 1 ==> True
>-- up < fromRational (1%2) ==> True
>-- up < fromRational (1%4) ==> True
>-- up < fromRational (1%8) ==> True
>-- up < fromRational (1%16) ==> True

Not very positive. It turns out ↑ is smaller than every positive
number. We can add ↑ to itself as many times as we like and it will
still be infinitesimally small.

↑ > 0, but how does it compare to ∗?

>-- up > star ==> False
>-- up || star ==> True
>-- down || star ==> True

∗'s fuzziness includes both ↑ and ↓. How about two copies of ↑?

>-- (up + up) > star ==> True
>-- (down + down) < star ==> True

So ↑+↑, written ⇑, is no longer confused with ∗.

So far, the games we've been considering are all infinitesimally close
to an actual number, as ∗ and all multiples of ↑ are infinitesimally
close to 0. This need not be the case in general, as can be seen in
the game G = { 1 | -1 }.

> switch = Game [1] [-1]

This game is known as a switch game, and is written ±1. Both players
are desperate to play in this game, as the result for them is much
better than if the other player makes their move first. Compare this
with G = { -1 | 1 } = 0, where both players would rather not move as
it just makes them one move closer to a loss.

±1 turns out to be fuzzy with all games between -1 and 1.

>-- switch < 2 ==> True
>-- switch || 1 ==> True
>-- switch || 0 ==> True
>-- switch || -1 ==> True
>-- switch > -2 ==> True

This makes sense, as if you add ±1 to any game in that range, the
outcome is still determined by whoever gets to play in ±1 first. For
values outside that range, ±1 isn't enough to tip the scales in the
other player's favour. For example, ±1 + 2 is still a win for Left,
even if Right goes first and plays ±1 to -1.

An important class of games is that of all 'impartial' games. These
are games where both players have the same set of moves they can
make. In other words, 'spinning the board' has no effect and the
result is the same position. One nice example of an impartial game is
the game of Nim.

In the game of Nim, the state of the game is represented as a few
piles of chips. A valid move is one that removes some chips from a
single pile. Say we had the piles [2, 4, 5], then a valid move could
be to [2, 4, 2], reducing the pile of 5 to 2. First let's represent a
single Nim pile as a game. From a pile of size n, either player can
move to any pile of size less than n. Of course, if the pile has size
0, neither player can do anything. That suggests the following
definition.

> nim :: Int -> Game
> nim 0 = zero
> nim n = Game options options
>   where options = map nim [0..n-1]

The value corresponding to 'nim n' is denoted ∗n, and is called a
nimber. All nimbers (except 0) are fuzzy, as the first player can take
the whole pile and win. Now to build a full Nim position, we just sum
up the values of the individual piles.

> nimPiles :: [Int] -> Game
> nimPiles = sum . map nim

It's an amazing fact that every impartial game is equivalent to some
nimber. In particular, the sum of two nimbers is another nimber. We
might hope that this addition works like normal addition, but that's
not the case. This is obvious when adding a nimber to itself, as
impartial games are their own inverses meaning two copies of any
nimber sum to zero. We do have that ∗1 + ∗2 = ∗3:

>-- nim 1 + nim 2 == nim 3 ==> True

But because ∗n = -∗n we can add ∗1 to both sides and get ∗2 = ∗3 + ∗1.

>-- nim 1 + nim 3 == nim 2 ==> True

Nimber-addition turns out to have a XOR like structure, where powers
of two in each summand cancel out.

> nimPlus :: Int -> Int -> Int
> nimPlus a b = a `xor` b

>-- 1 `nimPlus` 3 ==> 2

Even more impressive is that you can define a product on nimbers,
meaning impartial games form a field.

One issue we've skimmed over is that there are lots of different ways
of representing a single game. For example, { 1 | } = { 0, 1 | } = 2

>-- Game [one] [] == two ==> True
>-- Game [zero, one] [] == two ==> True

We've really been using equivalence classes of games. For example, the
'zero game' in our abelian group is really the equivalence class of
all games equal to zero.

The games we've been dealing with are all 'short' games; there are
only finitely many positions the game can be in. Thankfully, every
short game has a unique normal form, the simplest representation of
the game. To get to this normal form, two simplifications are used:

The first is removing 'dominated' options. Looking back at { 0, 1 | },
Left has no reason to ever move to 0 when the better move 1 is
available. In general, if Left has A and B as options, and A <= B,
then A can be removed without changing the value of the game. We have
to be careful here, it's not a matter of just choosing the 'maximum'
options, because some moves could be fuzzy with others.

> unbeaten :: (a -> a -> Bool) -> [a] -> [a]
> unbeaten p [] = []
> unbeaten p (x:xs) = if any (p x) rest then
>                        rest
>                     else
>                       x : filter (not . flip p x) rest
>   where rest = unbeaten p xs

> removeDominated :: Game -> Game
> removeDominated g = Game left right
>   where left  = unbeaten (<=) (leftMoves g)
>         right = unbeaten (>=) (rightMoves g)

The other way of simplifying games is by removing 'reversible'
moves. If Left has a move where Right's response gives a position
better for Right than the original game, then Left's move is called
reversible. If Left decides to make that move, he must anticipate that
Right will reverse it into something better for him. We can bypass
these and let Left jump straight to what he would do after that.

> lReversible :: Game -> Game -> [Game]
> lReversible g gl = maybe [gl] leftMoves (find (<= g) (rightMoves gl))

> rReversible :: Game -> Game -> [Game]
> rReversible g gr = maybe [gr] rightMoves (find (>= g) (leftMoves gr))

> anyReversible :: Game -> Bool
> anyReversible g = any (<= g) (concatMap rightMoves (leftMoves g)) Prelude.|| any (>= g) (concatMap leftMoves (rightMoves g))

> bypassReversible :: Game -> Game
> bypassReversible g = Game left right
>   where left  = concatMap (lReversible g) (leftMoves g)
>         right = concatMap (rReversible g) (rightMoves g)

Now, to simplify a game, we just combine the two operations, then
apply the simplification to all of the subgames. We need to repeatedly
check for reversible moves, as each round of simplification could
expose new ones.

> simplifyTop :: Game -> Game
> simplifyTop = removeDominated . until (not . anyReversible) (bypassReversible . removeDominated)

> simplify :: Game -> Game
> simplify g = Game (map simplify (leftMoves s)) (map simplify (rightMoves s))
>              where s = simplifyTop g

It can be proven that the game given by the two simplifications always
exists and is unique.

Before we can apply what we've learned to a real game, we'd like some
way to easily read off what the value of a game is, if it happens to
correspond to some simple value that we already understand.

Many of the games we find in real play are just the sum of a number, a
multiple of ↑, and a nimber. Because this is so common, we will create
a new type for it:

> data NumberUpStar = NUS { numberPart :: Rational, upPart :: Int, nimberPart :: Int } deriving (Eq, Ord)

> nusIsNumber nus = upPart nus == 0 && nimberPart nus == 0

We can leverage the simplification of games to make it easier to
convert from an arbitrary game to a NumberUpStar. For example, in a
simplified game, if Left only has one option and Right has none, we
must be dealing with an integer. Many similar rules, when combined,
will give us the function we require.

> optionsToNUS :: ([NumberUpStar], [NumberUpStar]) -> Maybe NumberUpStar
> -- Zero game
> optionsToNUS ([], []) = Just $ NUS 0 0 0

> -- If G = { L | } then L is an integer and G = L + 1
> optionsToNUS ([l], []) = Just $ NUS (lValue + 1) 0 0
>                                 where lValue = numberPart l

> -- If G = { | R } then R is an integer and G = R - 1
> optionsToNUS ([], [r]) = Just $ NUS (rValue - 1) 0 0
>                                 where rValue = numberPart r

> -- If G = { L | R } and L and R are both numbers, G = average of L and R
> optionsToNUS ([l], [r]) | nusIsNumber l && nusIsNumber r
>                           && numberPart l < numberPart r = Just $ NUS value 0 0
>                                 where value = (numberPart l + numberPart r) / 2

> -- Here we are of the form n + { 0 | G }, where G has non-negative ups
> optionsToNUS ([l], [r]) | nusIsNumber l && not (nusIsNumber r)
>                           && numberPart l == numberPart r
>                           && upPart r >= 0
>                             = Just $ NUS (numberPart l) (upPart r + 1) (nimberPart r `nimPlus` 1)

> -- Now n + { G | 0 }, where G has non-positive ups
> optionsToNUS ([l], [r]) | not (nusIsNumber l) && nusIsNumber r
>                           && numberPart l == numberPart r
>                           && upPart l <= 0
>                             = Just $ NUS (numberPart r) (upPart l - 1) (nimberPart l `nimPlus` 1)

> -- If G = { n, n∗ | n }, G = n↑∗
> optionsToNUS ([l1, l2], [r]) | nusIsNumber l1 && nusIsNumber r
>                                && l1 == r && l2 == NUS (numberPart l1) 0 1
>                                  = Just $ NUS (numberPart l1) 1 1

> -- If G = { n | n, n∗ }, G = n↓∗
> optionsToNUS ([l], [r1, r2]) | nusIsNumber l && nusIsNumber r1
>                                && l == r1 && r2 == NUS (numberPart r1) 0 1
>                                  = Just $ NUS (numberPart r1) (-1) 1

> -- Last possibility to check, we are looking at G = n + ∗k
> optionsToNUS (l1:ls, r1:rs) | length ls == length rs && nusIsNumber l1
>                               && l1 == r1 && nimberOptions = Just $ NUS (numberPart l1) 0 (length ls + 1)
>   where nimberOptions = all valid (zip3 ls rs [1..])
>         valid (l, r, i) = l == r && numberPart l == numberPart l1
>                           && upPart l == 0 && nimberPart l == i

> optionsToNUS _ = Nothing

> nusOptionsFrom :: Game -> Maybe ([NumberUpStar], [NumberUpStar])
> nusOptionsFrom g = do
>   left <- mapM simplifiedToNUS (leftMoves g)
>   right <- mapM simplifiedToNUS (rightMoves g)
>   return (sort left, sort right)

> -- Assumes the game given to it is simplified
> simplifiedToNUS :: Game -> Maybe NumberUpStar
> simplifiedToNUS = nusOptionsFrom >=> optionsToNUS

If we have one of these NumberUpStars, it's easy to print out a simple
representation of it. It's standard when dealing with games to write
3↑∗ for 3 + ↑ + ∗. We just need to be careful not to confuse this for
multiplication.

> instance Show NumberUpStar where
>   show (NUS 0 0 0) = "0"
>   show (NUS number up star) = numberShow number ++ upShow up ++ starShow star
>     where numberShow n | n == 0 = ""
>                        | denominator n == 1 = show $ numerator n
>                        | otherwise = "(" ++ show (numerator n) ++ "/" ++ show (denominator n) ++ ")"

>           upShow n | n == 0 = ""
>                    | n > 0 = replicate n '↑'
>                    | n < 0 = replicate (-n) '↓'

>           starShow n | n == 0 = ""
>                      | n == 1 = "∗"
>                      | otherwise = "∗" ++ show n

>-- show (NUS 0 0 0) ==> "0"
>-- show (NUS 3 2 1) ==> "3↑↑∗"

Now, to show a game, we first try to convert it to a NumberUpStar. If
this fails, we just print its left and right options.

> instance Show Game where
>   show g = string (simplifiedToNUS s)
>     where s = simplify g
>           string (Just nus) = show nus
>           string Nothing = "{ " ++ leftString ++ " | " ++ rightString ++ " }"
>           leftString = intercalate ", " (map show (leftMoves s))
>           rightString = intercalate ", " (map show (rightMoves s))

Finally we have a easy way to identify the games we create. You could
try yourself to combine the games we already have.  Some of the
identities are very surprising!

>-- Game [0] [up] ==> ↑↑∗

Now let's work on analysing a real game. The game of Toads and Frogs
is played on a strip of squares. Each square is either empty, or has a
Toad or a Frog in it. Whenever it's lefT's turn, he can either move a
Toad rightwards into an empty space, or hop over a Frog to the right
of him to land in an empty space. Right's move are identical, but
moving the fRogs in the other direction.

For example, if our board is in the state [ T _ T F _ ], Left could
either move the first Toad like this: [ _  T T F _ ] or hop the second
Toad like this: [ T _ _ F T ].

A standard starting board might look like this [ T T _ _ F F ]. Let's
use what we've developed above to tell us how to play this.

First we will need a type to represent the state of a square and the
board.

> data Square = T | F | E deriving (Eq, Show)

> type Board = [Square]

Now, given a board, we want to know what moves are possible for each
player.

> leftTFMoves :: Board -> [Board]
> leftTFMoves (T:E:rest) = ([E,T] ++ rest) : map ([T,E] ++) (leftTFMoves rest)
> leftTFMoves (T:F:E:rest) = ([E,F,T] ++ rest) : map ([T,F,E] ++) (leftTFMoves rest)
> leftTFMoves (x:rest) = map ([x] ++) (leftTFMoves rest)
> leftTFMoves [] = []

To find right's possible moves, we switch the players on the board,
find Left's moves, then switch back.

> switchPlayers :: Board -> Board
> switchPlayers = reverse . map switch
>   where switch T = F
>         switch F = T
>         switch E = E

> rightTFMoves :: Board -> [Board]
> rightTFMoves = map switchPlayers . leftTFMoves . switchPlayers

Now it's a simple matter to convert a board to a game.

> boardToGame :: Board -> Game
> boardToGame b = Game (map boardToGame (leftTFMoves b)) (map boardToGame (rightTFMoves b))

We can use this immediately to find the value of our board:

>-- boardToGame [T,T,E,E,F,F] ==> ∗

So if you and a friend are playing on this board, you had better ask
to play first!

Some very strange values can appear as positions in Toads and Frogs:

>-- boardToGame [T,T,T,F,E,F] ==> { { (1/4) | 0 } | 0 }
>-- boardToGame [E,T,T,T,E,F] ==> { 1∗ | 0 }
>-- boardToGame [E,T,T,E,F,F,E] ==> { (1/4) | (-1/4) }

You might recognise the last one as ±(1/4). The next obvious question
is, what's the best move from a given position?

> bestLeftMove :: Board -> (Board, Game)
> bestLeftMove b = maximumBy (compare `on` snd) movesValues
>   where allMoves = leftTFMoves b
>         movesValues = zip allMoves (map boardToGame allMoves)

>-- bestLeftMove [E,T,T,E,F,F,E] ==> ([E,T,E,T,F,F,E], (1/4))

With this up your sleeve, you should be able to beat pretty much
anyone.

===

For a much better written, much more rigorous and much more
entertaining introduction to combinatorial games, see:

Winning Ways for your Mathematical Plays (Academic Press, 1982)
by Berlekamp, Conway and Guy

For an almost unbelievably fast implementation of operations on
combinatorial games, see:

Combinatorial Game Suite: http://cgsuite.sourceforge.net/
by Aaron Siegel