;;; 8-Puzzle for 6.034 (by TLP).

;;; All the positions in a board
(define *all-positions* 
  '((0 0) (0 1) (0 2) (1 0) (1 1) (1 2) (2 0) (2 1) (2 2)))

;;; Accessors and contructor for POS
(define pos-x car)
(define pos-y cadr)
(define make-pos list)

;;; BOARD
;;; A board is a list of 3 lists of 3 entries ((b00 b01 b02) (b10 b11 b12) (b20 b21 b22))
;;; Entries are numbers, except for the empty tile = #f
(define *goal-board* '((7 8 1) (6 #f 2) (5 4 3)))

;;; Returns new board, with x,y entry set to value.
(define (set-board-value board pos value)
  (let ((x (pos-x pos))
	(y (pos-y pos)))
    (define (set-board-y col)
      (map (lambda (entry j)
	     ;; replace the yth entry with value, 
	     ;; otherwise return entry
	     (if (= y j) value entry))
	   col
	   '(0 1 2)))
    (map (lambda (col i)
	   ;; replace the xth col with modified col
	   (if (= i x)
	       (set-board-y col)
	       col))
	 board
	 '(0 1 2))))

(define (board-value board pos)
  (let ((x (pos-x pos))
	(y (pos-y pos)))
    (list-ref (list-ref board x) y)))

;;; Are two positions adjacent (horizontal or vertical)
(define (adjacent? pos1 pos2)
  (let ((dx (abs (- (pos-x pos1) (pos-x pos2))))
	(dy (abs (- (pos-y pos1) (pos-y pos2)))))
    (= 1 (+ dx dy))))

;;; MOVES

;;; A list of pos (where the empty tile can move)
(define (valid-moves board from)
  (filter (lambda (to) (valid-move? board from to))
	  *all-positions*))

;;; Returns boolean
(define (valid-move? board from to)
  (and (adjacent? from to)
       (let ((content-to (board-value board to))
	     (content-from (board-value board from)))
	 (and content-to (not content-from))
	 )))

;;; Returns new board
(define (make-move board from to)
  (if (valid-move? board from to)
      (let ((content-to (board-value board to)))
	(set-board-value (set-board-value board to #f)
			 from content-to))
      (error "Invalid move" move board)))

;;; NODE
;;; A node (state of the game) is: (board empty-tile-pos)

(define node-board car)
(define node-empty-pos cadr)
(define make-node list)

(define *goal-node* (make-node *goal-board* '(1 1)))

;;; For use with Blind and Heuristic searches
(define (get-neighboring-nodes node)
  (map (lambda (pos)
	 ;; (node cost)
	 (make-node (make-move (node-board node) (node-empty-pos node) pos)
			  pos))
       (valid-moves (node-board node) (node-empty-pos node))))

;;; Returns a list of (neighbor cost=1)...
;;; For use with UC and A*
(define (get-neighboring-nodes-and-cost node)
  (map (lambda (pos)
	 ;; (node cost)
	 (list (make-node (make-move (node-board node) (node-empty-pos node) pos)
			  pos)
	       1))
       (valid-moves (node-board node) (node-empty-pos node))))

;;; Use the heuristic
(define (get-heuristic-value node goal)
  (sum-manhattan-distance  (node-board node) (node-board goal)))

;;; Some utilities for heuristics

;;; Returns a pos
(define (find-tile board value)
  (let ((list-with-pos
	 (filter (lambda (pos) (equal? value (board-value board pos)))
	       *all-positions*)))
  (if (pair? list-with-pos)
      ;; found it
      (car list-with-pos)
      (error "Could not find the tile" board value))))

(define (count-misplaced-tiles board goal)
  (length 
   (remove-falses 
    (map (lambda (pos)
	   (not (equal? (board-value board pos) (board-value goal pos))))
	 *all-positions*))))

(define (manhattan-distance pos1 pos2)
  (+ (abs (- (pos-x pos1) (pos-x pos2)))
     (abs (- (pos-y pos1) (pos-y pos2)))))

(define (sum-manhattan-distance board goal)
  (apply 
   +
   (remove-falses
    (map (lambda (pos)
	   (and (board-value board pos)
		(not (equal? (board-value board pos) (board-value goal pos)))
		(manhattan-distance pos (find-tile goal (board-value board pos)))))
	 *all-positions*))))

;;; Generally useful, in case it is not around...

(define filter 
  (lambda (pred sequence)
    (cond ((null? sequence) '())
	  ((pred (car sequence))
	   (cons (car sequence)
		 (filter pred (cdr sequence))))
	  (else (filter pred (cdr sequence))))))

;;; Some testing values

(define *hard-start* (make-node '((7 1 8) (6 2 #f) (5 4 3)) '(1 2)))
(define *easy-start* (make-node '((#f 8 1) (7 2 3) (6 5 4)) '(0 0)))