;;;; Copyright (c) 2007 Jeremy English <jhe@jeremyenglish.org>
;;;;
;;;; Permission to use, copy, modify, distribute, and sell this software and its
;;;; documentation for any purpose is hereby granted without fee, provided that
;;;; the above copyright notice appear in all copies and that both that
;;;; copyright notice and this permission notice appear in supporting
;;;; documentation.  No representations are made about the suitability of this
;;;; software for any purpose.  It is provided "as is" without express or
;;;; implied warranty.
;;;;
;;;; Created: 25-June-2007

(in-package :chess-trace)

(defclass chess-pieces ()
  ((data-file-name :initarg :data-file-name
              :reader data-file-name)
   (data-file :initarg :data-file
              :accessor data-file)
   (sprite-size :initarg :sprite-size
                :accessor sprite-size)
   (white-background :initarg :white-background
                     :reader white-background)
   (black-background :initarg :black-background
                    :reader black-background)
   (name-map :initarg :name-map
             :reader name-map)
   (fg-bg-map :initarg :fg-bg-map
              :reader fg-bg-map)
   (extra-map :initarg :extra-map
               :reader extra-map)))

(defun make-chess-pieces (&key (data-file-name #p"pieces.xpm") (sprite-size 44)
                          (white-background (rgb-color #xfb #xc9 #x9f))
                          (black-background (rgb-color #xd1 #x8b #x47)))
  (let* ((name-map
          (list :bishop 0
               :king sprite-size
               :knight (* 2 sprite-size)
               :pawn (* 3 sprite-size)
               :queen (* 4 sprite-size)
               :rook (* 5 sprite-size)))
         (fg-bg-map
          (list :white-white 0
                 :white-black sprite-size
                 :black-white (* sprite-size 2)
                 :black-black (* sprite-size 3)))
    (extra-row (* sprite-size 4))
    (extra-map
      (list :black-dot (list :x 0 :y extra-row)
            :white-dot (list :x sprite-size :y extra-row)
            :black-cross (list :x (* sprite-size 2) :y extra-row)
            :white-cross (list :x (* sprite-size 3) :y extra-row))))
    (make-instance 'chess-pieces
                   :data-file-name data-file-name
                   :data-file nil
                   :black-background black-background
                   :white-background white-background
                   :sprite-size sprite-size
                   :name-map name-map :fg-bg-map fg-bg-map :extra-map extra-map)))

(defun load-pieces-data-file (chess-pieces data-stream)
  "Load must be called before using the class. The color map of the passed data-stream gets populated during the load."
  (setf (data-file chess-pieces)
        (xpm-file-to-canvas (data-file-name chess-pieces) (color-table data-stream))))

(defmethod chess-symbolp ((cp chess-pieces) name)
  (getf (name-map cp) name))

(defmethod valid-sprite-name ((cp chess-pieces) name)
  (or (chess-symbolp cp name) (equal name :dot) (equal name :cross)))

(defun valid-fg-bg (fg-bg)
  (or (equal fg-bg :white) (equal fg-bg :black)))

(defun define-extra-key (name background)
  (let ((keys '(:dot (:white :white-dot :black :black-dot)
                :cross (:white :white-cross :black :black-cross))))
    (getf (getf keys name) background)))

(defun fg-bg-key (foreground background)
  (let ((keys '(:black (:white :black-white :black :black-black)
                :white (:white :white-white :black :white-black))))
    (getf (getf keys foreground) background)))

(defmethod get-piece ((cp chess-pieces) &key (name :king) (foreground :white) (background :white))
  "Get a chess piece sprite. Valid names are :king, :queen, :rook, :pawn, :bishop, :knight, :dot, and :cross. Valid foregrounds and backgrounds are :white and :black. The extra symbols :dot and :cross have a solid foreground so that parameter is ignored."
  (when (null (data-file cp))
    (error (format nil "No data file is loaded. Please load it with load-pieces-data-file.")))
  (unless (valid-sprite-name cp name)
    (error (format nil "~a is an invalid sprite name" name)))
  (unless (valid-fg-bg foreground)
    (error (format nil "~a is an invalid foreground color. Should be :white or :black." foreground)))
  (unless (valid-fg-bg background)
    (error (format nil "~a is an invalid background color. Should be :white or :black." background)))
  (if (chess-symbolp cp name)
      (copy-area (data-file cp)
                 :x (getf (name-map cp) name)
                 :y (getf (fg-bg-map cp)(fg-bg-key foreground background))
                 :width (sprite-size cp)
                 :height (sprite-size cp))
      (let* ((extra-key (define-extra-key name background))
             (position (getf (extra-map cp) extra-key)))
        (copy-area (data-file cp)
                   :x (getf position :x)
                   :y (getf position :y)
                   :width (sprite-size cp)
                   :height (sprite-size cp)))))
