;;; -*- 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)))))