;;; Pegboard Solver ;;; ;;; From the University of Virginia's CS 200, Spring 2004, Notes #11 ;;; http://www.cs.virginia.edu/cs200/lectures/notes11.html ;;; ;;; To solve the board: ;;; [1,1] ;;; [2,1] 2,2 ;;; 3,1 3,2 3,3 ;;; where [x,y] means there is a peg in that hole, otherwise the hole is empty: ;;; (define my-board (make-board 3 (list (make-position 2 2) ;;; (make-position 3 1) ;;; (make-position 3 2) ;;; (make-position 3 3)))) ;;; (solve-pegboard my-board) ;;; Which will evaluate to (((1 . 1) (2 . 1) (3 . 1))), the move ;;; which jumps peg at position 1,1 over peg 2,1 to position 3,1. ;;; A board is a pair of the number of rows and the empty squares (define (make-board rows holes) (cons rows holes)) (define (board-holes board) (cdr board)) (define (board-rows board) (car board)) ;;; make-position creates an row col coordinate that represents a position on the board (define (make-position row col) (cons row col)) (define (get-row posn) (car posn)) (define (get-col posn) (cdr posn)) (define (same-position pos1 pos2) (and (= (get-row pos1) (get-row pos2)) (= (get-col pos1) (get-col pos2)))) ;;; on-board? takes a board and a position and returns true iff the position is on the board. (define (on-board? board posn) (and (>= (get-row posn) 1) (>= (get-col posn) 1) (<= (get-row posn) (board-rows board)) (<= (get-col posn) (get-row posn)))) ;;; There are rows + (rows - 1) + ... + 1 squares (holes or pegs) (define (board-squares board) (count-squares (board-rows board))) (define (count-squares nrows) (if (= nrows 1) 1 (+ nrows (count-squares (- nrows 1))))) ;;; peg? returns true if the position on board has a peg in it, and false if it doesn't (define (peg? board posn) (define (peg-holes? holes posn) (if (null? holes) #t (if (same-position (car holes) posn) #f (peg-holes? (cdr holes) posn)))) (peg-holes? (board-holes board) posn)) (define (intsfrom n) (if (= n 0) null (cons n (intsfrom (- n 1))))) (define (intsto n) (reverse (intsfrom n))) (define (show-board board) (apply string-append (map (lambda (r) (string-append (apply string-append (map (lambda (c) (if (peg? board (make-position r c)) "1" "0")) (intsto r))) " ")) (intsto (board-rows board))))) ;;; remove-peg evaluates to the board you get by removing the peg at posn from board. (define (remove-peg board posn) (make-board (board-rows board) (cons posn (board-holes board)))) ;;; add-peg evaluates to the board you get by adding a peg at posn to board. (define (add-peg board posn) (make-board (board-rows board) (filter (lambda (pos) (not (same-position pos posn))) (board-holes board)))) ;;; move creates a list of three posn, a start (the posn that the jumping ;;; peg starts from), a jump (the posn that is being jumped over), and end ;;; (the posn that the peg will end up in) (define (make-move start jump end) (list start jump end)) (define (get-start move) (car move)) (define (get-jump move) (cadr move)) (define (get-end move) (caddr move)) ;;; execute-move evaluates to the board after making move move on board. (define (execute-move board move) (add-peg (remove-peg (remove-peg board (get-start move)) (get-jump move)) (get-end move))) ;;; generate-moves evaluates to all possible moves that move a peg into ;;; the position empty, even if they are not contained on the board. (define (generate-moves empty) (map (lambda (hops) (let ((hop1 (car hops)) (hop2 (cdr hops))) (make-move (make-position (+ (get-row empty) (car hop1)) (+ (get-col empty) (cdr hop1))) (make-position (+ (get-row empty) (car hop2)) (+ (get-col empty) (cdr hop2))) empty))) (list (cons (cons 2 0) (cons 1 0)) ;; right of empty, hopping left (cons (cons -2 0) (cons -1 0)) ;; left of empty, hopping right (cons (cons 0 2) (cons 0 1)) ;; below, hopping up (cons (cons 0 -2) (cons 0 -1)) ;; above, hopping down (cons (cons 2 2) (cons 1 1)) ;; above right, hopping down-left (cons (cons -2 2) (cons -1 1)) ;; above left, hopping down-right (cons (cons 2 -2) (cons 1 -1)) ;; below right, hopping up-left (cons (cons -2 -2) (cons -1 -1))))) ;; below left, hopping up-right (define (all-possible-moves board) (apply append (map generate-moves (board-holes board)))) (define (legal-moves board) (filter (lambda (move) (legal-move? move board)) (all-possible-moves board))) (define (legal-move? move board) ;; A move is valid if: ;; o the start and end positions are on the board ;; o there is a peg at the start position ;; o there is a peg at the jump position ;; o there is not a peg at the end position (and (on-board? board (get-start move)) (on-board? board (get-end move)) (peg? board (get-start move)) (peg? board (get-jump move)) (not (peg? board (get-end move))))) (define (is-winning-position? board) ;; A board is a winning position if only one hole contains a peg (= (length (board-holes board)) (- (board-squares board) 1))) (define (find-first-winner board moves) (printf "Board: ~a~n" (show-board board)) (if (null? moves) (if (is-winning-position? board) '() ;; Found a winning game, no moves needed to win (eval to null) #f) ;; A losing position, no more moves, but too many pegs. ;;; See if the first move is a winner (let ((result (solve-pegboard (execute-move board (car moves))))) (if result ;; anything other than #f is a winner (null is not #f) (cons (car moves) result) ;; found a winner, this is the first move (begin (printf "Bad move: ~a on ~a~n" (car moves) (show-board board)) (find-first-winner board (cdr moves))))))) ;;; solve-pegboard evaluates to: ;;; #f if the board is a losing position (there is no sequence of moves to win from here) ;;; or a list of moves to win from this position ;;; ;;; NOTE: null is a winning result! It means the board has one peg in it right now and ;;; no moves are required to win. (define (solve-pegboard board) (find-first-winner board (legal-moves board)))