;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.number-toss)

;;;;;;
;;; solution

(def class* solution ()
  ((challenge :type challenge)
   (moves :type move-sequence)
   (board :type board)
   (score :type integer)
   (score-bound :type integer)))

(def function solution/solve (challenge &optional (known-score 0))
  (check-type challenge challenge)
  (bind ((original-board (board/parse (size-of challenge) (board-of challenge)))
         (best-solution (make-instance 'solution
                                       :challenge challenge
                                       :moves nil
                                       :board (board/copy original-board)
                                       :score 0
                                       :score-bound (board/compute-score-bound original-board)))
         (seen-solutions (make-hash-table :test #'equal))
         (solutions (list best-solution)))
    (iter (for solution = (pop solutions))
          (while solution)
          (solution/map-moves solution
                              (lambda (move)
                                (bind ((board (board/copy (board-of solution))))
                                  (board/move board move)
                                  (bind ((score (+ (score-of solution)
                                                   (board/compute-move-score (board-of solution) move)))
                                         (key (cons score board)))
                                    (unless (gethash key seen-solutions)
                                      (bind ((score-bound (+ score (board/compute-score-bound board))))
                                        (when (>= score-bound (max known-score (score-of best-solution)))
                                          (setf (gethash key seen-solutions) #t)
                                          (setf solutions (cons (make-instance 'solution
                                                                               :challenge challenge
                                                                               :moves (append (moves-of solution) (list move))
                                                                               :board board
                                                                               :score score
                                                                               :score-bound score-bound)
                                                                (remove score solutions :test #'> :key #'score-bound-of))))))))))
          (when (> (score-of solution)
                   (score-of best-solution))
            (setf best-solution solution)
            (format t "Solution count: ~A, best solution score: ~A~%" (length solutions) (score-of best-solution)))
          (setf solutions (sort solutions #'> :key #'score-of)))
    best-solution))

(def function solution/map-moves (solution function)
  (check-type solution solution)
  (iter (with board = (board-of solution))
        (with size = (length board))
        (for x1 :from 0 :below size)
        (iter (for y1 :from 0 :below size)
              (for position1 = (position/make x1 y1))
              (when (board/at board position1)
                (iter (for (dx dy) :in '((-2 -2) (-2 0) (-2 2) (0 -2) (0 2) (2 -2) (2 0) (2 2)))
                      (for x2 = (+ x1 dx))
                      (for y2 = (+ y1 dy))
                      (when (and (<= 0 x2 (1- size))
                                 (<= 0 y2 (1- size)))
                        (bind ((position2 (position/make x2 y2)))
                          (unless (board/at board position2)
                            (bind ((move (move/make position1 position2)))
                              (when (board/at board (move/middle move))
                                (funcall function move)))))))))))

(def function solution/print (solution)
  (bind ((challenge (revive-instance (challenge-of solution)))
         (board (board/parse (size-of challenge) (board-of challenge))))
    (iter (with score = 0)
          (for move :in-sequence (append (moves-of solution) (list nil)))
          (format t "~%Score: ~A~%" score)
          (iter (for y :from 0 :below (length board))
                (iter (for x :from 0 :below (length board))
                      (for element = (board/at board (position/make x y)))
                      (if element
                          (format t "~A" element)
                          (format t " ")))
                (terpri t))
          (when move
            (incf score (board/compute-move-score board move))
            (board/move board move)))))