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