root/trunk/thirdparty/cl-gd-0.5.6/colors-aux.lisp

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $

;;; Copyright (c) 2003-2007, Dr. Edmund Weitz.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :cl-gd)

(defun current-brush (&optional (image *default-image*))
  "Returns the GD image which is the current brush of IMAGE \(or NIL
if there is no current brush)."
  (check-type image image)
  (let ((brush (get-slot-value (img image) 'gd-image 'brush)))
    (if (null-pointer-p brush)
      nil
      brush)))

(defun (setf current-brush) (brush &optional (image *default-image*))
  "Sets BRUSH \(which must be a GD image) to be the current brush
for IMAGE."
  (check-type brush image)
  (check-type image image)
  (gd-image-set-brush (img image) (img brush))
  brush)

(defun current-tile (&optional (image *default-image*))
  "Returns the GD image which is the current tile of IMAGE \(or NIL
if there is no current tile)."
  (check-type image image)
  (let ((tile (get-slot-value (img image) 'gd-image 'tile)))
    (if (null-pointer-p tile)
      nil
      tile)))

(defun (setf current-tile) (tile &optional (image *default-image*))
  "Sets TILE \(which must be a GD image) to be the current tile
for IMAGE."
  (check-type tile (or image null))
  (check-type image image)
  (gd-image-set-tile (img image) (img tile))
  tile)

(defun current-style (&optional (image *default-image*))
  "Returns the current style of IMAGE as a list."
  (check-type image image)
  (let ((style-length (get-slot-value (img image) 'gd-image 'style-length))
        (style (get-slot-value (img image) 'gd-image 'style)))
    (loop for i below style-length
          collect (let ((color (deref-array style '(:array :int) i)))
                    (if (= color +transparent+)
                      nil
                      color)))))

(defun current-style* (&key (image *default-image*))
  "Returns the current style of IMAGE as an array."
  (check-type image image)
  (let ((style-length (get-slot-value (img image) 'gd-image 'style-length))
        (style (get-slot-value (img image) 'gd-image 'style)))
    (loop with result = (make-array style-length)
          for i below style-length
          do (setf (aref result i)
                     (let ((color (deref-array style '(:array :int) i)))
                       (if (= color +transparent+)
                         nil
                         color)))
          finally (return result))))

(defgeneric (setf current-style) (style &optional image)
  (:documentation "Sets STYLE to be the current drawing style for
IMAGE. STYLE can be a LIST or a VECTOR. Each element of STYLE is
either a color or NIL \(for transparent pixels)."))

(defmethod (setf current-style) ((style list) &optional (image *default-image*))
  (check-type image image)
  (let ((length (length style)))
    (with-safe-alloc (c-style (allocate-foreign-object :int length)
                              (free-foreign-object c-style))
      (loop for color in style
            for i from 0
            do (setf (deref-array c-style '(:array :int) i)
                       (typecase color
                         (null +transparent+)
                         (integer color)
                         (t 1))))
      (gd-image-set-style (img image) c-style length)
      style)))

(defmethod (setf current-style) ((style vector) &optional (image *default-image*))
  (check-type image image)
  (let ((length (length style)))
    (with-safe-alloc (c-style (allocate-foreign-object :int length)
                              (free-foreign-object c-style))
      (loop for color across style
            for i from 0
            do (setf (deref-array c-style '(:array :int) i)
                       (typecase color
                         (null +transparent+)
                         (integer color)
                         (t 1))))
      (gd-image-set-style (img image) c-style length)
      style)))

(defun set-anti-aliased (color do-not-blend &optional (image *default-image*))
  "Set COLOR to be the current anti-aliased color of
IMAGE. DO-NOT-BLEND \(if provided) is the background color
anti-aliased lines stand out against clearly."
  (check-type color integer)
  (check-type do-not-blend (or integer null))
  (check-type image image)
  (gd-image-set-anti-aliased-do-not-blend (img image)
                                          color
                                          (or do-not-blend -1)))

(defun resolve-c-color (color image)
  "Accepts a CL-GD 'color' COLOR and returns the corresponding
argument for GD, modifying internal slots of IMAGE if needed."
  (etypecase color
    (brush
      (setf (current-brush image) color)
      +brushed+)
    (tile
      (setf (current-tile image) color)
      +tiled+)
    ((cons brush (or vector list))
      (setf (current-brush image) (car color)
            (current-style image) (cdr color))
      +styled-brushed+)
    (anti-aliased-color
      (set-anti-aliased (color color)
                        (do-not-blend color)
                        image)
      +anti-aliased+)
    ((or vector list)
      (setf (current-style image) color)
      +styled+)
    (integer
      color)))

(defmacro with-color-argument (&body body)
  "Internal macro used to give correct color arguments to enclosed
foreign functions. Assumes fixed names COLOR and IMAGE."
  (with-unique-names (c-color-arg)
    `(let ((,c-color-arg (resolve-c-color color image)))
      ,@(sublis (list (cons 'color c-color-arg))
                body :test #'eq))))