;;; 15-Puzzle for 6.034 (by TLP@mit.edu).

;;; BOARD
;;; A board is represented as a list of columns, each of which is a list.
;;; A board is a list of 4 lists of 4 entries
;;; Entries are numbers, except for the empty tile = #f

;;; Here is the goal board we use.
(define *goal-board* '((7 8 1 9) (6 #f 2 10) (5 4 3 11) (12 13 14 15)))

;;; A position is (x y), x picks a column and y picks an entry in a column
;;; All the positions in a board
(define *all-positions* 
  '((0 0) (0 1) (0 2) (0 3) (1 0) (1 1) (1 2) (1 3) 
    (2 0) (2 1) (2 2) (2 3) (3 0) (3 1) (3 2) (3 3)))

;;; Define valid moves from each position 
;;; Each entry is (pos . moves)
(define *valid-moves*
  '( 
    ((0 0) (0 1) (1 0))
    ((0 1) (0 0) (0 2) (1 1))
    ((0 2) (0 1) (0 3) (1 2))
    ((0 3) (0 2) (1 3))

    ((1 0) (1 1) (0 0) (2 0))
    ((1 1) (1 0) (1 2) (0 1) (2 1))
    ((1 2) (1 1) (1 3) (0 2) (2 2))
    ((1 3) (1 2) (0 3) (2 3))

    ((2 0) (2 1) (1 0) (3 0))
    ((2 1) (2 0) (2 2) (1 1) (3 1))
    ((2 2) (2 1) (2 3) (1 2) (3 2))
    ((2 3) (2 2) (1 3) (3 3))

    ((3 0) (3 1) (2 0))
    ((3 1) (3 0) (3 2) (2 1))
    ((3 2) (3 1) (3 3) (2 2))
    ((3 3) (3 2) (2 3))
    ))

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

;;; Returns new board, with x,y entry set to value.
;;; Keeps the unmodified cols from the previous board, so as not to use up too much space.
(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 3)))
    (map (lambda (col i)
	   ;; replace the xth col with modified col
	   ;; keep the unmodified cols
	   (if (= i x)
	       (set-board-y col)
	       col))
	 board
	 '(0 1 2 3))))

;;; Return the tile number (or #f) at the given pos
;;; Does not check that the pos is valid (efficieny, sigh).
(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)))))
    ;; adjacencies dx=0,dy=1 or dx=1,dy=0
    (= 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*))

;;; Uses pre-compiled list of moves
(define (valid-moves board from)
  (cdr (assoc from *valid-moves*)))

;;; Returns boolean (#t if move is legal, i.e. empty tile moving to adjacent position.
(define (valid-move? board from to)
  (and (adjacent? from to)
       (not (board-value board from))	; empty from
       ;; The test below is redundant in a well formed board
       ;; (board-value board to)
       ))

;;; Returns new board after moving empty tile (from->to)
(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)))

;;; STATE
;;; A state (state of the game) is: (board empty-tile-pos)
;;; The empty-tile-pos is there to avoid having to look for it each time

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

;;; For use with Blind and Heuristic searches, returns list of states
(define (get-neighboring-states state)
  (map (lambda (pos)
	 ;; state
	 (make-state (make-move (state-board state) (state-empty-pos state) pos)
		    pos))
       (valid-moves (state-board state) (state-empty-pos state))))

;;; For use with Optimal searches, returns a list of (neighbor-states cost=1)...
(define (get-neighboring-states-and-cost state)
  (map (lambda (pos)
	 ;; (state cost)
	 (list (make-state (make-move (state-board state) (state-empty-pos state) pos)
			  pos)
	       1))
       (valid-moves (state-board state) (state-empty-pos state))))

;;; Interface to the heuristic function, see below
(define (get-heuristic-value state goal)
  (sum-manhattan-distance  (state-board state) (state-board goal)))

;;; Some utilities for heuristics

;;; Returns a pos for the tile with the given value
(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))))

;;; A simple heuristic (underestimate).
(define (count-misplaced-tiles board goal)
  (let ((count 0))
    (for-each
     (lambda (pos)
       (and (board-value board pos)
	    (not (equal? (board-value board pos) (board-value goal pos)))
	    (set! count (+ count 1))
	    ))
     *all-positions*)
    count))

;;; A better heuristic (underestimate).
(define (sum-manhattan-distance board goal)
  (let ((dist 0))
    (for-each
     (lambda (pos)
       (let ((pos-value (board-value board pos)))
	 (and pos-value			; don't count the empty tile
	      (not (equal? pos-value (board-value goal pos)))
	      (set! dist 
		    (+ dist (manhattan-distance pos (find-tile goal pos-value))))
	      )))
     *all-positions*)
    dist))

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

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

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

;;; Some simple hashing for the states, based on the board

(define (state-hash-index state)
  (let ((board (state-board state))
	(index 0))
    (for-each
     (lambda (col coeff)
       (for-each (lambda (x c) 
		   (if x (set! index (+ index (* x c))))) 
		 col coeff))
     board
     '((1 2 4 6) (8 12 16 20) (32 44 65 83))
     )
    ;;(if (> index 3600) (error index))
    index))

;;; Actions for *expanded*

(define (in-state-list? state lst)
  (let ((l (vector-ref lst (state-hash-index state))))
    ;;(if (= 0 (remainder *number-of-search-steps* 100))
    ;; (begin (display "[") (display (length l)) (display "] ")))
    (member state l)))

(define (add-to-state-list state lst)
  (let ((index (state-hash-index state)))
    (set! *number-ruled-out* (+ 1 *number-ruled-out*))
    (vector-set! lst index (cons state (vector-ref lst index)))
    lst))

(define (init-state-list . start)
  (begin
    (set! *number-ruled-out* (length start))
    ;; If the states were evenly distributed, we would not expect to find more 
    ;; than 100 states per entry.  But, they won't be equally distributed...
    (let ((lst (make-vector 3600 '()))
	  (index (if (null? start) #f (state-hash-index (car start)))))
      (if (null? start) #f 
	  (vector-set! lst index (cons (car start) (vector-ref lst index))))
      lst)))

;;; Some test cases

(define (board->state board)
  (make-state board (find-tile board #f)))

;;; Some states for testing, for example (a* *easy-start-state* *goal-state*)
(define *goal-state* (board->state *goal-board*))
(define *easy-start-state* (board->state '((#f 8 1 9) (7 2 3 10) 
					   (6 5 4 11) (12 13 14 15))))
(define *hard-start-state* (board->state '((7 1 8 9) (6 2 #f 10) 
					   (5 4 3 11) (12 13 14 15))))
#|
(define *goal2-state* (board->state '((#f 1 2) (3 4 5) (6 7 8))))
(define *start1-state* (board->state '((#f 4 2) (1 5 8) (3 6 7))))
(define *start2-state* (board->state '((8 7 6) (5 4 3) (2 1 #f))))
(define *start3-state* (board->state '((4 8 1) (3 #f 2) (6 7 5))))
(define *start4-state* (board->state '((1 6 8) (3 4 2) (7 5 #f))))
(define *start5-state* (board->state '((1 2 3) (8 #f 4) (7 6 5))))
|#

;;; (begin (load "search") (load "search-opt") (load "puzzle2"))