Chopsticks
Chopsticks
is a silly game you play with your fingers and someone else’s
fingers. The number of possible hand positions (5 * 5 * 5 * 5) is
small enough that it can easily be brute-force solved with a few
tricks. First, we will need memoization. This memoization module
handles only unary functions, but at least it hides it’s
implementation :-). (That is to say it’s impossible to obtain the
memoization table from a memoized function.)

module Memoize ( Memoized , recall , forget ) where
import Prelude hiding ( lookup )
import Data.Map
import Control.Monad.State
newtype Memoize a b c = Memoize {
memoize :: Map a b -> ( c , Map a b )
}
type Memoized a b = a -> Memoize a b b
forget :: ( Memoized a b ) -> a -> b
forget func arg = fst ( memoize ( func arg ) empty )
recall :: Ord a => ( a -> Memoize a b b ) -> a -> Memoize a b b
recall func arg = Memoize recall' where
recall' memory = case lookup arg memory of
Just val -> ( val , memory )
Nothing -> remember memory
remember memory =
let ( val , memory' ) = memoize ( func arg ) memory in
( val , insert arg val memory' )
instance Monad ( Memoize a b ) where
return val = Memoize ( \ memory -> ( val , memory ))
m >>= func = Memoize ( \ memory ->
let ( val , memory' ) = memoize m memory in
memoize ( func val ) memory' )

And it’s use, for our old friend the Fibonacci sequence,

import Memoize
fib :: Int -> Integer
fib = forget memFib
memFib :: Memoized Int Integer
memFib 0 = return 1
memFib 1 = return 1
memFib n = do
x <- recall memFib ( n - 1 )
y <- recall memFib ( n - 2 )
return ( x + y )

Now we can write an algorithm to solve games. The following module
implementats the Minimax algorithm, except that

It deals only with winning/losing, not with scores.
It can handle cycles; it detects if a player cannot win but can
postpone the game indefinately.
module Minimax ( Color , Game , solve ) where
import Memoize
data Color = Red -- Loss
| Green -- Win
| Yellow -- Draw
deriving ( Eq , Ord , Show )
class Ord board => Game board where
moves :: board -> Either Color [ board ]
solve :: Game board => board -> Color
solve board = forget ( explore [] ) board
explore :: Game board => [ board ] -> Memoized board Color
explore path board =
if elem board path then return Yellow -- Cycles are draws
else case moves board of
Left color -> return color -- End of the game
Right nextBoards -> do
colors <- mapM ( recall ( explore ( board : path ))) nextBoards
-- If you can move such that your opponent loses, then you can win
if any ( == Red ) colors then return Green
-- If you can move such that your opponent draws, then you can draw
else if any ( == Yellow ) colors then return Yellow
-- If your opponent can win regardless of your move, then you lose
else return Red

And finally the definition of the ChopSticks game. I tried to follow
the rules on Wikipedia, but it’s kind of messy. There’s probably a
mistake. Anyhow, running `solve`

on `Board 1 1 1 1`

yields `Yellow`

(a
draw).

module ChopSticks where
import Data.List
import Debug.Trace
import qualified Data.Map as Map
type Fingers = Int
fingersOnHand = 5
fingerPlus :: Fingers -> Fingers -> Fingers
fingerPlus x y = if x + y >= fingersOnHand then 0 else x + y
fingerTransfer :: Fingers -> Fingers -> [ Fingers ]
fingerTransfer x y =
let cap = min ( x - 1 ) ( fingersOnHand - y - 1 ) in
if x > y then delete ( x - y ) [ 1 .. cap ]
else [ 1 .. cap ]
data Board = Board Fingers Fingers Fingers Fingers
deriving ( Eq , Ord , Show )
instance Game Board where
moves ( Board 0 0 _ _ ) = Left Red
moves ( Board _ _ 0 0 ) = Left Green
moves ( Board 0 a c d ) = Right $ nub $ [
Board ( c ` fingerPlus ` a ) d 0 a ,
Board c ( d ` fingerPlus ` a ) 0 a ]
++ [ Board c d x ( a - x ) | x <- fingerTransfer a 0 ]
moves ( Board a 0 c d ) = Right $ nub $ [
Board ( c ` fingerPlus ` a ) d a 0 ,
Board c ( d ` fingerPlus ` a ) a 0 ]
++ [ Board c d ( a - x ) x | x <- fingerTransfer a 0 ]
moves ( Board a b c d ) = Right $ nub $ [
Board ( c ` fingerPlus ` a ) d a b ,
Board ( c ` fingerPlus ` b ) d a b ,
Board c ( d ` fingerPlus ` a ) a b ,
Board c ( d ` fingerPlus ` b ) a b ]
++ [ Board c d ( a + x ) ( b - x )
| x <- fingerTransfer b a ]
++ [ Board c d ( a - x ) ( b + x )
| x <- fingerTransfer a b ]
instance Game Int where
moves 0 = Left Yellow
moves 1 = Left Red
moves 2 = Right [ 0 , 1 ]
moves 3 = Right [ 2 , 3 ]
test board = putStrLn $ show $ solve ( board :: Board )