Cracker Barrel Peg Board Puzzle

[Brian Adkins]

One of the topics of discussion this evening was about seeing
solutions to relatively simple programming problems in a variety of
functional programming languages. This can be a fun way to gain
proficiency in a programming language for the programmer and be
informative for the viewers.

There are number of ways we could go about this, but I thought a
simple way would be for folks to post problems of interest to
themselves, and others could decide whether they wanted to create a
program or not. One person might choose a pet problem, another might
choose a Project Euler problem, or a SICP exercise, etc.

I'll start things off with the Cracker Barrel Peg Board Puzzle. I
first solved this in BASIC as a kid, so I thought I'd give it a shot
in Haskell to stretch my newbie wings a bit. I'd love to see solutions
in other functional languages and other problems. I think we're
probably all limited in our free time, so I expect the problems will
need to be programmed in a relatively short period of time for people
to want to participate, but feel free to post whatever you'd like to.
Even if you're the only person who provides a solution, it will still
be interesting.

I'd suggest posting problems in separate threads with solutions as
replies.

I'll let folks Google the peg board puzzle, but it's basically a set
of 15 holes in a triangular arrangement with 14 golf tees. The object
is to remove golf tees by jumping as in checkers. Leaving one tee is
good, leaving one tee in the original empty hole is better. For our
purposes, one solution is fine ie. no need to produce all possible
solutions. Identify the starting empty hole as a startup config, and
produce the list of moves as the solution.

[Brian Adkins]

This turned out to be a much better learning experience for Haskell than I anticipated. In case Google screws up the formatting, here's a link to hpaste:

http://hpaste.org/44669/cracker_barrel_puzzle

Everything went pretty smoothly until I came to the "play" function which handles all the move making and backtracking. I'm still not pleased with that function; after many years of imperative thinking, it may take a while longer to get into the functional mindset. However, even with my very rough newbie skills, I think Haskell provides a reasonably elegant solution.

Even though I only wanted the first solution, I think it may have been more idiomatic to have a function lazily compute a list of all solutions and just take the head of that list.

Brian

-- 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) <- pairs, 

                      isOccupied b neighbor && 

                      isEmpty b dst ]

  where (r, c) = p

        pairs  = filter (\(p1,p2) -> 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 <- b ]

-- Make a move and return the new board

move b (src,dst) = dst:filter pred b

  where ((sr,sc),(dr,dc)) = (src,dst)

        neighbor = (div (sr+dr) 2, div (sc+dc) 2)

        pred     = \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)

--

Brian Adkins

Lojic Technologies, LLC

http://lojic.com/

[David Cabana]

I accepted the Cracker Barrel puzzle challenge, and posted a Clojure
solution, here:
http://erl.nfshost.com/2011/03/19/cracker-barrel-puzzle/

[Nick]

Not to be redundant, but here is my Clojure solution.
(ns org.nibrown.crackerbarrel.clojure.CrackerBarrel)

(defn is-solved?
"is the game solved or not?"
[{pegs :pegs}]
(= 1 (count pegs)))

(defn move
"returns the board after moving the given peg in the given direction
on the given board
if the move is invalid, returns nil"
[[peg-row peg-col] [row-dir col-dir] {pegs :pegs, size :size :as
game}]
(let [hopped-row (+ peg-row row-dir)
hopped-col (+ peg-col col-dir)
new-row (+ hopped-row row-dir)
new-col (+ hopped-col col-dir)]
(if (and
(< -1 new-row (- size new-col))
(< -1 new-col size)
(get pegs [hopped-row hopped-col])
(not (get pegs [new-row new-col])))
(assoc game :pegs
(conj (disj pegs [hopped-row hopped-col] [peg-row peg-col])
[new-row new-col])))))

(defn hop-legal?
"returns if the given peg moving in the given direction on the given
board is a legal move"
[peg direction game]
(not (nil? (move peg direction game))))

(defn all-dirs
"returns all the legal move directions for the given peg"
[peg game]
(filter #(hop-legal? peg % game) [[1 0] [-1 0] [0 1] [0 -1] [1 -1]
[-1 1]]))

(defn all-moves
"returns all the legal moves for the given peg"
[peg game]
(map #(hash-map :peg peg :dir %) (all-dirs peg game)))

(defn all-moves-on-board
"returns all the legal moves on the given board in the form of a map
of pegs to move directions"
[{pegs :pegs, :as game}]
(reduce into (map #(all-moves % game) pegs)))

(defn try-sequence
"tries to find a winning sequence beginning with the starting
position"
[game moves-so-far]
(let [moves-to-try (all-moves-on-board game)]
(if (is-solved? game) moves-so-far ; yippee, we're done!
(if (empty? moves-to-try) nil ; no more moves
(first (filter #(not (nil? %))
(map #(try-sequence (move (:peg %) (:dir %) game)
(conj moves-so-far %))
moves-to-try)))))))

(defn solve
"returns the sequence of moves that will result in a win, or null if
a win is not possible"
[starting-game]
(try-sequence starting-game []))

And the solution for a standard 5 sized board with the top peg
missing:
[{:peg [2 0], :dir [1 0]} {:peg [0 2], :dir [1 -1]} {:peg [3 1], :dir
[-1 0]} {:peg [0 4], :dir [0 -1]} {:peg [1 3], :dir [1 -1]} {:peg [4
0], :dir [-1 1]} {:peg [0 1], :dir [0 1]} {:peg [0 3], :dir [1 -1]}
{:peg [1 0], :dir [1 0]} {:peg [2 2], :dir [0 -1]} {:peg [3 0], :dir
[-1 0]} {:peg [0 0], :dir [1 0]} {:peg [2 0], :dir [-1 1]}]

For each move, the value for :peg is the peg to move, and the value
for direction is the direction in which to move it.

[jvt]

I used the cracker barrel puzzle as an example in my latest blog
post.

http://dorophone.blogspot.com/2011/04/deep-emacs-lisp-part-2.html

My solution is in emacs and uses a lazy list monad to produce a lazy
list of all possible solutions and the instructions to generate each
solution.

[Brian Adkins]

OCaml has recently pushed Haskell out of the top spot for a statically typed FPL for me, so I thought I'd code up the Cracker Barrel puzzle solution in it to see how it faired. I think Haskell still has an edge in a number of areas (including syntax beauty - I do miss list comprehensions & extra concision), but I think in total, for my needs, OCaml comes out ahead (the multi-million LOC, ~ decade, Jane Street case study is an impressive data point). 

I'll give it a shot in Racket next for a comparison.

Brian

(* Solve the Cracker Barrel Peg Board Puzzle in OCaml *)

open Core.Std

open Core.Core_list

let isOccupied b p = mem b p

let isEmpty b p    = not (isOccupied b p)

let isPos (r,c)    = r >= 0 && r < 5 && c >= 0 && c <= r

(* Possible moves for one position *)

let positionMoves b p = let (r,c) = p in

let pairs = filter (map [ ((-2),0); (0,2); (2,2); (2,0); (0,(-2)); ((-2),(-2)) ]

                        (fun (r1,c1) -> ((r + r1 / 2, c + c1 / 2),(r + r1, c + c1))))

                   (fun (neighbor,dst) -> isPos neighbor && isPos dst &&

                                          isOccupied b neighbor && isEmpty b dst) in

  map pairs (fun (_, dst) -> (p, dst))

(* Possible moves for all positions on the board *)

let possibleMoves b = concat (map b (fun pos -> positionMoves b pos))

(* Make a move and return the new board *)

let move b (src,dst) = let ((sr,sc),(dr,dc)) = (src,dst) in

  let neighbor = ((sr+dr) / 2, (sc+dc) / 2) in

  dst :: filter b (fun pos -> (pos <> src) && (pos <> neighbor))

(* Make moves until the goal position is met *)

let rec play b p moves = let nextMoves = possibleMoves b in

  let rec tryMoves = function

    | []      -> []

    | (m::ms) -> let result = play (move b m) p (m::moves) in

                 if is_empty result then tryMoves ms else result in

  if is_empty nextMoves then 

    if length b = 1 && hd_exn b = p then rev moves else []

  else

    tryMoves nextMoves

(* Compute the initial empty position to know the goal, then solve the puzzle *)

let solve b = let rec emptyPos (r,c) = if isEmpty b (r,c) then

                                         (r,c)

                                       else

                                         if c<r then emptyPos (r,c+1) else emptyPos (r+1,0) in

  play b (emptyPos(0,0)) []

    

let 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) ]