;;;
;;; CS200 Spring 2003
;;;
;;; Cracker Barrel Peg Board Solver (for Mini-Scheme)
;;;
;;; To use our code in Mini-Scheme, we quote each definition and use
;;; meval-sequence to evaluate all our definitions in the-global-environment.
;;;

(require (lib "list.ss"))

(load "listprocs.ss")

(meval-sequence
 (list

  ;;; We want the definitions of map and filter from listprocs.ss
  ;;; Note that we can't just make them Mini-Scheme primitives, since
  ;;; the procedure application must be evaluated using Mini-Scheme.
  
  '(define insertl 
     (lambda (f lst start)
       (if (null? lst) 
	   start
	   (f (car lst) (insertl f (cdr lst) start)))))

  '(define filter 
     (lambda (f lst)
       (insertl
	(lambda (el rest) (if (f el) (cons el rest) rest))
	lst
	null)))

  '(define map 
     (lambda (f lst)
       (insertl
	(lambda (el rest) (cons (f el) rest))
	lst
	null)))

  '(define delete 
     (lambda (lst el)
       (if (null? lst) 
	   null ;; okay to not find it now: (error "Element not found!")
	   (if (eqv? (car lst) el)
	       (cdr lst)
	       (cons (car lst) (delete (cdr lst) el))))))

  ;;; and is not the Scheme and (which is a special form)
  '(define and 
     (lambda (p1 p2)
       (if p1 p2 false)))

  ;;; A board is a pair of the number of rows and the empty squares
  '(define make-board (lambda (rows holes) (cons rows holes)))
  '(define board-holes (lambda (board) (cdr board)))
  '(define board-rows (lambda (board) (car board)))

  ;;; There are rows + (rows - 1) + ... + 1 squares (holes or pegs)
  '(define board-squares (lambda (board) 
			   (count-squares (board-rows board))))

  '(define count-squares 
     (lambda (nrows)
       (if (= nrows 1) 1 (+ nrows (count-squares (- nrows 1))))))

  ;;; make-position creates an x,y coordinate that represents a position on the board
  ;;; e.g.             1,1
  ;;;               2,1   2,2
  ;;;            3,1   3,2   3,3
  ;;;         4,1   4,2   4,3   4,4
  ;;;      5,1   5,2   5,3   5,4   5,5

  '(define make-position (lambda (x y) (list x y)))

  ;;; get-x and get-y get the x or y value from a posn
  ;;; e.g.   > (get-x (make-position 2 3))
  ;;;        2
  ;;;        > (get-y (make-position 2 3))
  ;;;        3

  '(define get-x (lambda (posn) (car posn)))
  '(define get-y (lambda (posn) (cadr posn)))

  ;;; make-starting-board creates a peg board with the requested number
  ;;; of rows and one peg missing (that is, one hole at startpos).
  ;;;
  ;;; e.g.   > (make-starting-board 5 (make-position 3 2))
  ;;;        (5 . (3 2))
  ;;;
  ;;;    creates this board (if X's stand for pegs, and O's are empty:
  ;;;
  ;;;                     X
  ;;;                    X X
  ;;;                   X O X
  ;;;                  X X X X
  ;;;                 X X X X X
  ;;;

  '(define make-starting-board 
     (lambda (rows startpos)
       ((lambda (board) ;;; Note we desugared the let since Mini-Scheme doesn't have it
	  (assert (on-board? board startpos) "Starting hole must be on the board")
	  board)
	(make-board rows (list startpos)))))

  ;;; on-board? takes a board and a position and returns true if it is 
  ;;; contained in the board.

  '(define on-board? 
     (lambda (board posn)
       (and (>= (get-x posn) 1) 
	    (and (>= (get-y posn) 1)
		 (and (<= (get-x posn) (board-rows board))
		      (<= (get-y posn) (get-x posn)))))))
  
  ;;; peg? returns true if the position on board has a peg in it, and false if it doesn't
  
  '(define peg? 
     (lambda (board posn)
       ((lambda (holes)
	  (if (not (empty? holes))
	      (if (and (= (get-x posn) (get-x (car holes))) 
		       (= (get-y posn) (get-y (car holes))))
		  false 
		  (peg? (cdr board) posn))
	      true))
	(board-holes board))))
  
  ;;; remove-peg evaluates to the board you get by removing a peg at posn from
  ;;; the passed board

  '(define remove-peg 
     (lambda (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 
     (lambda (board posn)
       (make-board (board-rows board) (delete (board-holes board) posn))))
  
  ;;; 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 (lambda (start jump end) (list start jump end)))
  '(define get-start (lambda (move) (car move)))
  '(define get-jump (lambda (move) (cadr move)))
  '(define get-end (lambda (move) (cadr (cdr 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.
  ;;;
  ;;; We can hop the peg in each of eight possible directions.

  '(define generate-moves 
     (lambda (empty)
       ;; (printf "generate-moves: ~a~n" empty)
       (map (lambda (hops)
	      (make-move (make-position (+ (get-x empty) (car (car hops))) (+ (get-y empty) (cdr (car hops))))
			 (make-position (+ (get-x empty) (car (cdr hops))) (+ (get-y empty) (cdr (cdr hops))))
			 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
  
  ;;; all-moves cycles through the board and generates all possible moves for the board,
  ;;; even if they are not valid

  '(define all-possible-moves 
     (lambda (holes)
       (if (empty? holes) 
	   null
	   ((lambda (result)
	      ;; (printf "All possible moves: ~a ==> ~a~n" holes result)
	      result)
	    (append (generate-moves (car holes))
		    (all-possible-moves (cdr holes)))))))
  
  ;;; valid-moves filters the moves on a board to produce only those that are valid.
  '(define valid-moves 
     (lambda (board)
       ((lambda (result)
	  ;; (printf "Valid moves: ~a~n" result)
	  result)
	(filter 
	 (lambda (move)
	   ;; 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))
		(and (on-board? board (get-end move))
		     (and (peg? board (get-start move))
			  (and (peg? board (get-jump move))
			       (not (peg? board (get-end move))))))))
	 (all-possible-moves (board-holes board))))))
  
  ;;; execute-move evaluates to the board after making move move on board.
  '(define execute-move 
     (lambda (board move)
       (add-peg (remove-peg (remove-peg board (get-start move)) 
			    (get-jump move))
		(get-end move))))
  
  '(define is-winning-position? 
     (lambda (board)
       ;; A board is a winning position if only one hole contains a peg
       (= (length (board-holes board))
	  (- (board-squares board) 1))))
  
  ;;; find-first evaluates to the first element of lst that is not #f.
  '(define find-first-winner 
     (lambda (board moves)
       (if (null? moves)
	   (if (is-winning-position? board)
	       null ;; Found a winning game, no moves needed to win (eval to null)
	       false)  ;; A losing position, no more moves, but too many pegs.
           ;;; See if the first move is a winner
	   ((lambda (result)
	      (if result ;; anything other than #f is a winner
		  (cons (car moves) result)
		  (find-first-winner board (cdr moves))))
	    (solve-pegboard (execute-move board (car 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 
     (lambda (board)
       (find-first-winner board (valid-moves board))))

  ) ;;; end of list of definitions
 ;;; Evaluate all the definitions in the-global-environment
 the-global-environment)