Comparison of solution to pegboard puzzle in Racket and Haskell

pegboard.hs

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]

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



possibleMoves b = concat [ positionMoves b pos | pos <- b ]

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)


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

solve b = let emptyPos = head [ (r,c) | r <- [0..4], c <- [0..r], isEmpty b (r,c) ]
          in play b emptyPos []
             

goal b p m = length b == 1 && head b == p

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)

pegboard.jl

isoccupied(b, (r,c)) = b[r,c]
isopen(b, p)         = !isoccupied(b, p)
ispos((r,c))         = 1 <= c <= r <= 5

# Possible moves for one position
function positionmoves(b, p)
  (r,c) = p
  pairs = filter(((p1,p2),) -> ispos(p1) && ispos(p2),
                 [ ((r + or ÷ 2, c + oc ÷ 2),(r + or, c + oc)) for
                   (or, oc) = [ (-2,0), (0,2), (2,2), (2,0), (0,-2), (-2,-2) ] ])
  [ (p, dst) for (neighbor, dst) = pairs if isoccupied(b, neighbor) && isopen(b, dst) ]
end

# Possible moves for all positions on the board
possiblemoves(b) = reduce(vcat, [ positionmoves(b,pos) for pos =
                                  [ (r,c) for r = 1:5 for c = 1:r if b[r,c] ] ])

# Make a move and return the new board
function move(b, (src,dst))
  ((sr,sc),(dr,dc))  = (src,dst)
  neighbor           = ((sr+dr) ÷ 2, (sc + dc) ÷ 2)
  board              = copy(b)
  board[src...]      = 0
  board[neighbor...] = 0
  board[dst...]      = 1
  board
end

# Make moves until the goal position is met
function play(b, moves)
  next_moves = possiblemoves(b)

  function trymoves(lst)
    if isempty(lst)
      []
    else
      result = play(move(b,lst[1]), [lst[1]; moves])
      if isempty(result)
        trymoves(lst[2:end])
      else
        result
      end
    end
  end

  if isempty(next_moves)
    if goal(b)
      reverse(moves)
    else
      []
    end
  else
    trymoves(next_moves)
  end
end

# Indicate whether we've reached the goal state
goal(board) = count(identity, board) == 1 && board[1,1]

board = BitArray([ 0 0 0 0 0
                   1 1 0 0 0
                   1 1 1 0 0
                   1 1 1 1 0
                   1 1 1 1 1 ])

print(play(board, []))

pegboard.rkt

#lang racket

(require defpat/defpat)



(define (is-occupied? b p)   (elem? p b))
(define (is-empty? b p)      (not (is-occupied? b p)))
(defpat (is-pos? (cons r c)) (<= 0 c r 4))

(define (position-moves b p)
  (match-define (cons r c) p)
  (define pairs (filter (λ (move) (and (is-pos? (car move)) (is-pos? (cdr move))))
                        (for/list ([ (or oc) (pair-stream '((-2 . 0) (0 . 2) (2 . 2) (2 . 0) (0 . -2) (-2 . -2))) ])
                          (cons (cons (+ r (/ or 2)) (+ c (/ oc 2))) (cons (+ r or) (+ c oc))))))
  (for/list ([ (neighbor dst) (pair-stream pairs) ]
             #:when (and (is-occupied? b neighbor)
                         (is-empty?    b dst)))
    (cons p dst)))

(define (possible-moves b) (append-map (λ (p) (position-moves b p)) b))
  
(defpat (move b (cons src dst))
  (match-let* ([ (cons (cons sr sc) (cons dr dc))  (cons src dst) ]
               [ neighbor (cons (/ (+ sr dr) 2) (/ (+ sc dc) 2)) ]
               [ pred     (λ (p) (and (not (equal? p src)) (not (equal? p neighbor)))) ])
    (cons dst (filter pred b))))

(define (play b p moves)
  (define next-moves (possible-moves b))
  (define/match (try-moves lst)
    [ ('())         '() ]
    [ ((cons m ms)) (let ([ result (play (move b m) p (cons m moves)) ])
                      (if (null? result)
                          (try-moves (cdr lst))
                          result)) ])
  (if (null? next-moves)
      (if (goal? b p)
          (reverse moves)
          '())
      (try-moves next-moves)))





(define (solve b)
  (let ([empty-pos (car (for*/list ([r [.. 0 4]] [c [.. 0 r]] #:when (is-empty? b (cons r c))) (cons r c)))])
    (play b empty-pos '())))

(define (goal? b p) (and (equal? (length b) 1) (equal? (car b) p)))

(define 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)))

(module* main #f (pretty-print (solve board)))

support.rkt

;; A few supporting macros/functions
(define-struct pair-stream (v)
  #:methods gen:stream
  [(define (stream-empty? stream)
     (empty? (pair-stream-v stream)))
   (define (stream-first stream)
     (let ([ pair (first (pair-stream-v stream)) ])
       (values (car pair) (cdr pair))))
   (define (stream-rest stream)
     (pair-stream (rest (pair-stream-v stream))))])
      
(define (lgen m n)    (range m (add1 n)))
(define (.. m n)      (lgen m n))
(define (elem? m lst) (cons? (member m lst)))