;;; Pegboard Solver ;;; David Evans ;;; 22 January 2009 ;;; ;;; Described in Chapter 5: Data ;;; (load "list-procedures.ss") (define (make-taggedlist tag p) (cons tag p)) (define (taggedlist-get-tag p) (car p)) (define (taggedlist-get-element tag p n) (if (eq? (taggedlist-get-tag p) tag) (list-get-element (cdr p) n) (error (format "Bad list tag: ~a (expected ~a)" (taggedlist-get-tag p) tag)))) ;;; Position (define (make-position row col) (make-taggedlist 'Position (list row col))) (define (position-get-row posn) (taggedlist-get-element 'Position posn 1)) (define (position-get-column posn) (taggedlist-get-element 'Position posn 2)) (define (make-list-of-constants n val) (if (= n 0) null (cons val (make-list-of-constants (- n 1) val)))) ;;; Board (define (make-board rows) (if (= rows 0) null (list-append (make-board (- rows 1)) (list (make-list-of-constants rows true))))) (define (board-rows board) (length board)) (define (board-contains-peg? board pos) (list-get-element (list-get-element board (position-get-row pos)) (position-get-column pos))) (define (row-replace-peg pegs col val) (if (= col 1) (cons val (cdr pegs)) (cons (car pegs) (row-replace-peg (cdr pegs) (- col 1) val)))) (define (board-replace-peg board row col val) (if (= row 1) (cons (row-replace-peg (car board) col val) (cdr board)) (cons (car board) (board-replace-peg (cdr board) (- row 1) col val)))) (define (board-add-peg board pos) (if (board-contains-peg? board pos) (error (format "Board already contains peg at position: ~a" pos)) (board-replace-peg board (position-get-row pos) (position-get-column pos) true))) (define (board-remove-peg board pos) (if (not (board-contains-peg? board pos)) (error (format "Board does not contain peg at position: ~a" pos)) (board-replace-peg board (position-get-row pos) (position-get-column pos) false))) (define (board-number-of-pegs board) (list-sum (list-map (lambda (peg) (if peg 1 0)) (list-flatten board)))) ;;; Direction (define (make-direction down right) (make-taggedlist 'Direction (list down right))) (define (direction-get-vertical dir) (taggedlist-get-element 'Direction dir 1)) (define (direction-get-horizontal dir) (taggedlist-get-element 'Direction dir 2)) (define (direction-add dir1 dir2) (make-direction (+ (direction-get-vertical dir1) (direction-get-vertical dir2)) (+ (direction-get-horizontal dir1) (direction-get-horizontal dir2)))) (define direction-up (make-direction -1 0)) (define direction-down (make-direction 1 0)) (define direction-left (make-direction 0 -1)) (define direction-right (make-direction 0 1)) (define direction-up-left (direction-add direction-up direction-left)) (define direction-down-right (direction-add direction-down direction-right)) (define all-directions (list direction-up direction-down direction-left direction-right direction-up-left direction-down-right)) (define (direction-step pos dir) (make-position (+ (position-get-row pos) (direction-get-vertical dir)) (+ (position-get-column pos) (direction-get-horizontal dir)))) ;;; Move (define (make-move start direction) (make-taggedlist 'Move (list start direction))) (define (move-get-start move) (taggedlist-get-element 'Move move 1)) (define (move-get-direction move) (taggedlist-get-element 'Move move 2)) (define (move-get-jumpee move) (direction-step (move-get-start move) (move-get-direction move))) (define (move-get-landing move) (direction-step (move-get-jumpee move) (move-get-direction move))) ;;; Solving the Puzzle (define (execute-move board move) (board-add-peg (board-remove-peg (board-remove-peg board (move-get-start move)) (move-get-jumpee move)) (move-get-landing move))) (define (all-positions board) (list-flatten (list-map (lambda (row) (list-map (lambda (col) (make-position row col)) (intsto row))) (intsto (board-rows board))))) (define (all-conceivable-moves board) (list-flatten (list-map (lambda (pos) (list-map (lambda (dir) (make-move pos dir)) all-directions)) (all-positions board)))) (define (valid-position? board pos) ; position is valid if its row <= # of rows in board and col <= row (and (>= (position-get-row pos) 1) (>= (position-get-column pos) 1) (<= (position-get-row pos) (board-rows board)) (<= (position-get-column pos) (position-get-row pos)))) (define (all-possible-moves board) (list-filter (lambda (move) (valid-position? board (move-get-landing move))) (all-conceivable-moves board))) (define (all-legal-moves board) (list-filter (lambda (move) (and (board-contains-peg? board (move-get-start move)) (board-contains-peg? board (move-get-jumpee move)) (not (board-contains-peg? board (move-get-landing move))))) (all-possible-moves board))) (define (is-winning-board? board) (= (board-number-of-pegs board) 1)) (define (solve-pegboard board) ; Board -> List of Moves (if (is-winning-board? board) null ; no Moves needed to reach winning position (try-moves board (all-legal-moves board)))) (define (try-moves board moves) (if (null? moves) false ; didn't find a winner (if (solve-pegboard (execute-move board (car moves))) (cons (car moves) (solve-pegboard (execute-move board (car moves)))) (try-moves board (cdr moves)))))