- OEIS
- Archive
- Bettering English
- Dominoe Computer
- Faster Than Light
- Invariants
- Invariants
- Penrose Maze
- Rust Quickref
- Syntactic Sugar
- Terminal Colors

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