# 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

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