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

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

;;;;;;
;;; Position

(def type coordinate ()
  '(integer 0 8))

(def type position ()
  'cons)

(def function position/make (x y)
  (check-type x coordinate)
  (check-type y coordinate)
  (cons x y))

(def function position/x (position)
  (check-type position cons)
  (car position))

(def function position/y (position)
  (check-type position cons)
  (cdr position))

(def function position/parse (position index)
  (check-type position string)
  (check-type index non-negative-integer)
  (position/make (- (char-code (elt position index)) 48)
                 (- (char-code (elt position (1+ index))) 48)))

(def function position/print (position stream)
  (check-type position cons)
  (princ (code-char (+ 48 (position/x position))) stream)
  (princ (code-char (+ 48 (position/y position))) stream))

;;;;;;
;;; Move

(def type move ()
  'cons)

(def function move/make (source target)
  (check-type source position)
  (check-type target position)
  (bind ((move (cons source target)))
    (assert (move/valid? move))
    move))

(def function move/source (move)
  (check-type move move)
  (car move))

(def function move/target (move)
  (check-type move move)
  (cdr move))

(def function move/middle (move)
  (check-type move move)
  (bind ((source (move/source move))
         (target (move/target move)))
    (position/make (/ (+ (position/x source) (position/x target)) 2)
                   (/ (+ (position/y source) (position/y target)) 2))))

(def function move/valid? (move)
  (bind ((source (move/source move))
         (target (move/target move))
         (dx (abs (- (position/x source) (position/x target))))
         (dy (abs (- (position/y source) (position/y target)))))
    (or (and (= dx 2) (= dy 0))
        (and (= dx 0) (= dy 2))
        (and (= dx 2) (= dy 2)))))

(def function move/parse (move index)
  (check-type move string)
  (check-type index non-negative-integer)
  (move/make (position/parse move index)
             (position/parse move (+ 2 index))))

(def function move/print (move stream)
  (check-type move move)
  (position/print (move/source move) stream)
  (position/print (move/target move) stream))

;;;;;;
;;; Move sequence

(def type move-sequence ()
  'sequence)

(def function move-sequence/make (moves)
  (check-type moves move-sequence)
  moves)

(def function move-sequence/parse (moves)
  (check-type moves string)
  (iter (for index :from 0 :below (length moves) :by 4)
        (collect (move/parse moves index))))

(def function move-sequence/print (moves stream)
  (check-type moves move-sequence)
  (iter (for move :in-sequence moves)
        (move/print move stream)))

;;;;;;
;;; Challenge id

(def type challenge-id ()
  'non-negative-integer)

(def function challenge-id/size (challenge-id)
  (check-type challenge-id challenge-id)
  (the board-size (+ 5 (mod challenge-id 5))))

(def function challenge-id/ordinal (challenge-id)
  (check-type challenge-id challenge-id)
  (floor (/ challenge-id 5)))

;;;;;;
;;; Board

(def type score ()
  '(integer 1 18))

(def type board ()
  'sequence)

(def type board-size ()
  '(integer 5 9))

(def type board-element ()
  '(or null (integer 1 9)))

(def function board/make (size)
  (check-type size board-size)
  (iter (for y :from 0 :below size)
        (collect (iter (for x :from 0 :below size)
                       (collect nil)))))

(def function board/copy (board)
  (check-type board board)
  (iter (for y :from 0 :below (length board))
        (collect (iter (for x :from 0 :below (length board))
                       (collect (board/at board (position/make x y)))))))

(def function board/parse (size numbers)
  (check-type size board-size)
  (check-type numbers sequence)
  (assert (= (* size size) (length numbers)))
  (iter (for y :from 0 :below size)
        (collect (iter (for x :from 0 :below size)
                       (for char = (elt numbers (+ (* y size) x)))
                       (for element = (unless (char= char #\Space)
                                        (- (char-code char) 48)))
                       (check-type element board-element)
                       (collect element)))))

(def function board/print (board stream)
  (check-type board board)
  (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 stream "~A" element)
                  (format stream " ")))))

(def function board/size (board)
  (check-type board board)
  (the board-size (length board)))

(def function board/at (board position)
  (check-type board board)
  (check-type position position)
  (the board-element
    (nth (position/x position)
         (nth (position/y position) board))))

(def function (setf board/at) (new-value board position)
  (check-type new-value board-element)
  (check-type board board)
  (check-type position position)
  (the board-element
    (setf (nth (position/x position)
               (nth (position/y position) board))
          new-value)))

(def function board/compute-move-score (board move)
  (check-type board board)
  (check-type move move)
  (the score
    (bind ((source (board/at board (move/source move)))
           (middle (board/at board (move/middle move))))
      (if (= source middle)
          (* 2 middle)
          middle))))

(def function board/move (board move)
  (check-type board board)
  (check-type move move)
  (bind ((source (move/source move)))
    (setf (board/at board (move/target move)) (board/at board source))
    (setf (board/at board (move/middle move)) nil)
    (setf (board/at board source) nil)
    (values)))

(def function board/compute-score (board moves)
  (check-type board board)
  (check-type moves sequence)
  (iter (with score = 0)
        (for move :in-sequence moves)
        (incf score (board/compute-move-score board move))
        (board/move board move)
        (finally (return score))))

(def function board/compute-score-bound (board)
  (bind ((smallest 0)
         (bound 0)
         (size (length board))
         (counts (make-array 10))
         (parities (make-array 10)))
    (iter (for x :from 0 :below size)
          (iter (for y :from 0 :below size)
                (for number = (board/at board (position/make x y)))
                (when number
                  (setf (aref parities number) (logior (aref parities number)
                                                       (ash 1 (+ (* 2 (mod x 2))
                                                                 (mod y 2)))))
                  (incf (aref counts number))
                  (when (or (zerop smallest)
                            (< number smallest))
                    (setf smallest number)))))
    (setf bound (- smallest))
    (iter (for i :from 0 :below (length counts))
          (for count = (aref counts i))
          (for parity = (aref parities i))
          (incf bound
                (cond ((or (= count 1)
                           (member parity '(1 2 4 8)))
                       (* count i))
                      ((> count 1)
                       (+ i (* 2 i (1- count))))
                      (t 0))))
    bound))