Skip to content

Instantly share code, notes, and snippets.

@lojic
Last active August 29, 2015 14:06
Show Gist options
  • Save lojic/33a72dded4d4f9ec43e1 to your computer and use it in GitHub Desktop.
Save lojic/33a72dded4d4f9ec43e1 to your computer and use it in GitHub Desktop.
Obligatory Cracker Barrel peg board puzzle in OCaml
(* 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) ]
-- 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 goal b p moves 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 []
goal :: Board -> Pos -> [ Move ] -> Bool
goal b p m = length b == 1 && head b == p
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) ]
def is_occupied b, p
b.include?(p)
end
def is_empty b, p
!is_occupied(b, p)
end
def is_pos p
r, c = p
(0..4).include?(r) && (0..r).include?(c)
end
def position_moves b, p
result = []
r, c = p
[ [-2,0], [0,2], [2,2], [2,0], [0,-2], [-2,-2] ].map {|pair|
r0, c0 = pair
[ [(r + r0) / 2, (c + c0) / 2], [r + r0, c + c0] ]
}.select {|pair|
p1, p2 = pair
is_pos(p1) && is_pos(p2) && is_occupied(b, p1) && is_empty(b, p2)
}
end
def possible_moves b
b.map {|pos| position_moves(b,pos) }.flatten
end
def move b, m
src, dst = m
[ dst ] + b.select {|p|
sr, sc = m[0]
dr, dc = m[1]
neighbor = [ (sr+dr) / 2, (sc+dc) / 2]
p != neighbor && p != [sr, sc]
}
end
def play b, p, moves
next_moves = possible_moves(b)
try_moves = lambda {|ms|
return [] if ms.empty?
m = ms[0]
result = play(move(b,m), p, [m] + ms)
if result.empty?
try_moves.call(ms[1..-1])
else
result
end
}
if next_moves.empty?
if b.length == 1 && b[0] == p
reverse moves
else
[]
end
else
try_moves.call(next_moves)
end
end
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],
]
(* Solve the Cracker Barrel Peg Board Puzzle *)
open List
(* Provide extra functionality *)
fun elem x xs = exists (fn e => e = x) xs
fun upto (m,n) = if m>n then [] else m :: upto(m+1,n)
val filter = filter
type Pos = int * int
type Move = int * int
type Board = Pos list
fun isOccupied b p = elem p b
fun isEmpty b p = not (isOccupied b p)
fun isPos (r,c) = r >= 0 andalso r < 5 andalso c >= 0 andalso c <= r
(* Possible moves for one position *)
fun positionMoves b p =
let val (r, c) = p
val pairs = filter
(fn (neighbor,dst) => isPos neighbor andalso
isPos dst andalso
isOccupied b neighbor andalso
isEmpty b dst)
(map (fn (or,oc) => ((r + or div 2, c + oc div 2),(r + or, c + oc)))
[ (~2,0), (0,2), (2,2), (2,0), (0,~2), (~2,~2) ])
in map (fn (neighbor, dst) => (p, dst)) pairs end
(* Possible moves for all positions on the board *)
fun possibleMoves b = concat (map (fn pos => positionMoves b pos) b)
(* Make a move and return the new board *)
fun move b (src,dst) =
let val ((sr,sc),(dr,dc)) = (src,dst)
val neighbor = ((sr+dr) div 2, (sc+dc) div 2)
in dst :: filter (fn pos => (pos <> src) andalso (pos <> neighbor) ) b
end
(* Make moves until the goal position is met *)
fun play b p moves =
let val nextMoves = possibleMoves b
fun tryMoves [] = []
| tryMoves (m::ms) =
let val result = play (move b m) p (m::moves)
in if null result then tryMoves ms
else result
end
in if null nextMoves then
if length b = 1 andalso hd b = p then rev moves else []
else tryMoves nextMoves
end
(* Compute the initial empty position to know the goal, then solve the puzzle *)
fun solve b =
let fun 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)) [] end
val 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) ] : Board
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment