Cracker Barrel Peg Board Puzzle in Haskell

:: haskell, programming

I first wrote a program to solve the Cracker Barrel peg board puzzle (15 holes arranged in a triangle with 14 golf tees) many years ago as youth using the BASIC language. I wish I still had the source to that, because I’m pretty sure this Haskell version would kick its butt :)

I’m still trying to get my head around Haskell, so I expect there are many possible improvements to this program, but even so, I’m pleased with how Haskell allows me to express logic.

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
 
-- Solve the Cracker Barrel Peg Board Puzzle

module Main where

type Pos = (Int, Int)
type Move = (Pos, Pos)
type Board = [ Pos ]

isOccupied b p = elem p b
isEmpty b p    = not (isOccupied b p)
isPos (r,c)    = elem r [0..4] && elem c [0..r]

-- Possible moves for one position
positionMoves b p = [ (p, dst) | (neighbor, dst)  isPos p1 && isPos p2)
                   [ ((r + or `div` 2, c + oc `div` 2),(r + or, c + oc)) |
                     (or, oc) <- [ (-2,0), (0,2), (2,2), (2,0), (0,-2), (-2,-2) ] ]

-- Possible moves for all positions on the board
possibleMoves b = concat [ positionMoves b pos | pos  (pos /= src) && (pos /= neighbor)

-- Make moves until the goal position is met
play b p moves =
  if null nextMoves then
    if length b == 1 && head b == p then reverse moves else []
  else
    tryMoves nextMoves
  where
    nextMoves       = possibleMoves b
    tryMoves []     = []
    tryMoves (m:ms) =
      let result = play (move b m) p (m:moves)
      in if null result then tryMoves ms else result

-- Compute the initial empty position to know the goal, then solve the puzzle
solve b = let emptyPos = head [ (r,c) | r <- [0..4], c <- [0..r], isEmpty b (r,c) ]
          in play b emptyPos []

-- A sample board with the topmost hole empty
board :: Board
board = [ (1,0), (1,1),
          (2,0), (2,1), (2,2),
          (3,0), (3,1), (3,2), (3,3),
          (4,0), (4,1), (4,2), (4,3), (4,4) ]

main = print (solve board)