(proclaim '(optimize (speed 0) (safety 3) (debug 3)))

#|
x-x-x
|\ /|
x x x
|/ \|
x-x-x
|#

(defconstant +empty+ 0)
(defconstant +white+ 1)
(defconstant +blue+ 2)
(defconstant +red+ 3)
(defconstant +possible-directions+ 
  #2A(( ((1 0) (0 1) (1 1)) ((-1 0) (1 0)) ((-1 0) (-1 1) (0 1)) )
      ( ((0 -1) (0 1)) ((-1 -1) (1 -1) (-1 1) (1 1)) ((0 -1) (0 1)) )
      ( ((0 -1) (1 -1) (1 0)) ((-1 0) (1 0)) ((-1 0) (-1 -1) (0 -1)) )))

(defun make-start-board ()
  (make-array '(3 3) :element-type '(unsigned-byte 8) :initial-contents
              `((,+white+ ,+empty+ ,+blue+)
                (,+white+ ,+red+ ,+blue+)
                (,+white+ ,+empty+ ,+blue+))))

(defconstant +end-board+
  #.(make-array '(3 3) :element-type '(unsigned-byte 8) :initial-contents  
                `((,+empty+ ,+blue+ ,+white+)
                  (,+blue+ ,+red+ ,+white+)
                  (,+blue+ ,+empty+ ,+white+))))

(defun get-possible-targets (board x y)
  (unless (= +empty+ (aref board y x))
    (loop for (xd yd) in (aref +possible-directions+ y x)
          when (= +empty+ (aref board (+ y yd) (+ x xd)))
          collect (cons (+ x xd) (+ y yd)))))

(defun board-value (board)
  (loop for x from 0 below 3 
        with result = 0 and mult = 1 
        finally (return result) do
        (loop for y from 0 below 3 do
              (incf result (* mult (aref board y x)))
              (setf mult (* 4 mult)))))

(defconstant +end-board-value+ (board-value +end-board+))

(defun move (board x-from y-from x-to y-to)
  (setf (aref board y-to x-to) (aref board y-from x-from)
        (aref board y-from x-from) +empty+))

(defun print-solution (path)
  (format t "path length: ~a, path: " (length path))
  (loop for ((x0 . y0) (x1 . y1)) in path do
        (format t "~a~a-~a~a " x0 y0 x1 y1))
  (terpri))

(defun copy-board (board)
  (adjust-array
   (make-array '(3 3) :element-type '(unsigned-byte 8) :displaced-to board)
   '(3 3)))

(defun print-board (board)
  (loop for y from 0 below 3 do
        (loop for x from 0 below 3 do
              (format t "~a" (aref board y x)))
        (terpri))
  (terpri))

(defun find-path-impl (visited move-big level paths)
  (when (> (length level) 0)
    (let (new-level new-paths)
      (loop for board in level
            for path in paths do
            (loop for x from 0 below 3 do
                  (loop for y from 0 below 3 do
                        (when (eql move-big (= +red+ (aref board y x)))
                          (loop for (xt . yt) in (get-possible-targets board x y) do
                                (let ((new-board (copy-board board))
                                      (new-path (copy-seq path)))
                                  (move new-board x y xt yt)
                                  (push (list (cons x y) (cons xt yt)) new-path)
                                  (let ((value (board-value new-board)))
                                    (when (= value +end-board-value+)
                                      (return-from find-path-impl (nreverse new-path)))
                                    (when move-big (incf value 262144))
                                    (when (or nil (= 0 (bit visited value)))
                                      (setf (bit visited value) 1)
                                      (push new-path new-paths)
                                      (push new-board new-level)))))))))
      (find-path-impl visited (not move-big) new-level new-paths))))

(defun find-path ()
  (let ((visited (make-sequence 'bit-vector (* 2 262144) :initial-element 0))
        (board (make-start-board))
        (level '()))
    (push board level)
    (let ((result (find-path-impl visited nil level '(()))))
      (if result
          (print-solution result)
        (format t "no solution found")))))