Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
169 lines (150 sloc) 6.67 KB
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.13 2009/11/23 17:05:38 edi Exp $
;;; Copyright (c) 2003-2009, 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))))