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)

Justin Pombrio

About Me

Puzzles

Show

Tell

Tree Editors

Chopsticks