Cracker Barrel Pegboard puzzle Haskell -> Racket

pegboard.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 []

-- Has the goal been met?             
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) ]

main = print (solve board)

pegboard.rkt

#lang racket
;; Solve the Cracker Barrel Peg Board Puzzle

(struct pos (r c) #:transparent)
(struct pos2 (p1 p2) #:transparent)
(struct move (src dst) #:transparent)

(define (is-occupied? b p)  (elem? p b))
(define (is-empty? b p)     (not (is-occupied? b p)))
(defpat (is-pos? (pos r c)) (&& (elem? r [.. 0 4]) (elem? c [.. 0 r])))

;; Possible moves for one position
(define (position-moves b p)
  (match-define (pos r c) p)
  ; List of pos2 where p1 is a neighbor to jump, p2 is a destination
  (define pairs (filter (λ (p2) (and (is-pos? (pos2-p1 p2)) 
                                     (is-pos? (pos2-p2 p2))))
                        (lcomp (list or oc)
                               '((-2 0) (0 2) (2 2) (2 0) (0 -2) (-2 -2))
                               (pos2 (pos (+ r (/ or 2)) (+ c (/ oc 2)))
                                     (pos (+ r or) (+ c oc))))))
  (for/list ([pair pairs]
             #:when (and (is-occupied? b (pos2-p1 pair))
                         (is-empty? b (pos2-p2 pair))))
    (move p (pos2-p2 pair))))

;; Possible moves for all positions on the board
(define (possible-moves b) 
  (append-map (λ (p) (position-moves b p)) b))
  
;; Make a move and return the new board
(define (move-peg b m)
  (match-define (move (pos sr sc) (pos dr dc)) m)
  (define neighbor (pos (/ (+ sr dr) 2) (/ (+ sc dc) 2)))
  (define pred (λ (p) (and (not (equal? p (move-src m)))
                           (not (equal? p neighbor)))))
  (cons (move-dst m) (filter pred b)))

;; Has the goal been met?
(define (goal? b p m)
  (and (equal? (length b) 1)
       (equal? (car b) p)))

;; Make moves until the goal position is met
(define (play b p moves)
  (define next-moves (possible-moves b))
  (define (try-moves lst)
    (cond [(null? lst) '()]
          [else (let* ([m (car lst)]
                       [result (play (move-peg b m) p (cons m moves))])
                  (if (null? result)
                      (try-moves (cdr lst))
                      result))]))
  (if (null? next-moves)
      (if (goal? b p moves)
          (reverse moves)
          '())
      (try-moves next-moves)))

;; Compute the initial empty position to know the goal, then solve the puzzle
(define (solve b)
  (let ([empty-pos (car (for*/list ([r [.. 0 4]]
                                    [c [.. 0 r]]
                                    #:when (is-empty? b (pos r c)))
                          (pos r c)))])
    (play b empty-pos '())))

(define board (lcomp (list a b)
                     '((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))
                     (pos a b)))

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

prelude.rkt

;; ---------------------------------------------------------------------------------------------------
;; Support code
;; ---------------------------------------------------------------------------------------------------

(define-syntax defpat
  (syntax-rules ()
    [(_ (fn pat) b1 b2 ...)
     (define fn (match-lambda [pat b1 b2 ...]))]))

(define-syntax lcomp
  (syntax-rules ()
    [(_ pat lst b1 b2 ...)
     (for/list ([elt lst])
       (match elt [pat b1 b2 ...]))]))
      
(define (lgen m n)   (range m (add1 n)))
(define (&& a b)     (and a b))

; Thanks Matthias Felleisen for these:
(define (.. m n)      (lgen m n))
(define (elem? m lst) (cons? (member m lst)))