Obligatory Cracker Barrel peg board puzzle in OCaml

a_peg_board.ml

(* 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) ]

peg_board.hs

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

peg_board.rb

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],
  ]

peg_board.sml

(* 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