[bknr-cvs] r2219 - in branches/trunk-reorg/thirdparty: . vecto-1.0.2 vecto-1.0.2/doc
bknr at bknr.net
bknr at bknr.net
Fri Oct 5 06:02:37 UTC 2007
Author: hhubner
Date: 2007-10-05 02:02:33 -0400 (Fri, 05 Oct 2007)
New Revision: 2219
Added:
branches/trunk-reorg/thirdparty/vecto-1.0.2/
branches/trunk-reorg/thirdparty/vecto-1.0.2/LICENSE
branches/trunk-reorg/thirdparty/vecto-1.0.2/clipping-paths.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/color.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/copy.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/background.gif
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-butt.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-round.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-square.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-both.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-circle.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-rectangle.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-unclipped.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/closed-subpath.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-a.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-b.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-c.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-d.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-e.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-none.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/examples.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/feedlike-icon.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/illustrations.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/index.html
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-bevel.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-miter.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-round.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/lambda-example.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/open-subpath.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/star-clipping.png
branches/trunk-reorg/thirdparty/vecto-1.0.2/drawing.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/graphics-state.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/package.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/paths.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/test.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/text.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/transform-matrix.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/user-drawing.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/user-shortcuts.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/utils.lisp
branches/trunk-reorg/thirdparty/vecto-1.0.2/vecto.asd
Log:
update vecto (now really)
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/LICENSE
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/LICENSE 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/LICENSE 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,25 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/clipping-paths.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/clipping-paths.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/clipping-paths.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,120 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: clipping-paths.lisp,v 1.2 2007/10/01 16:25:48 xach Exp $
+
+(in-package #:vecto)
+
+;;; Clipping paths are represented as a grayscale channel against
+;;; which drawing operations are masked; it's intersected with the
+;;; alpha channel. They are part of the graphics state that are saved
+;;; and restored by WITH-GRAPHICS-STATE. However, there's no reason to
+;;; pay a channel copying penalty if the clipping path is not
+;;; modified, or pay a data creation/drawing penalty if the clipping
+;;; path is empty.
+;;;
+;;; This is implemented by making WRITABLE-CLIPPING-DATA the method to
+;;; obtain the data of a clipping path; it will create data for an
+;;; empty clipping path, and copy data for a clipping path in a
+;;; temporary graphics state. If WRITABLE-CLIPPING-DATA is never
+;;; called, no mask will be created, and drawing operations won't
+;;; bother consulting the clipping path.
+;;;
+;;; TODO: Store a bounding box with a clipping path, so drawing can be
+;;; limited to the clipping path area when possible.
+
+(defclass clipping-path ()
+ ((height
+ :initarg :height
+ :accessor height)
+ (width
+ :initarg :width
+ :accessor width)
+ (data
+ :initarg :data
+ :accessor data)
+ (scratch
+ :initarg :scratch
+ :accessor scratch
+ :documentation "A temporary channel used to store the new clipping
+ path to intersect with the old one.")))
+
+(defclass empty-clipping-path (clipping-path) ())
+
+(defclass proxy-clipping-path (clipping-path) ())
+
+(defmethod print-object ((clipping-path clipping-path) stream)
+ (print-unreadable-object (clipping-path stream :type t :identity t)
+ (format stream "~Dx~D" (width clipping-path) (height clipping-path))))
+
+(defmethod copy ((clipping-path clipping-path))
+ (make-instance 'proxy-clipping-path
+ :data (data clipping-path)
+ :scratch (scratch clipping-path)
+ :height (height clipping-path)
+ :width (width clipping-path)))
+
+(defmethod copy ((clipping-path empty-clipping-path))
+ (make-instance 'empty-clipping-path
+ :height (height clipping-path)
+ :width (width clipping-path)))
+
+(defgeneric emptyp (object)
+ (:method (object)
+ nil)
+ (:method ((object empty-clipping-path))
+ t))
+
+(defun make-clipping-channel (width height initial-element)
+ (make-array (* width height)
+ :element-type '(unsigned-byte 8)
+ :initial-element initial-element))
+
+(defgeneric clipping-data (object)
+ (:method ((clipping-path clipping-path))
+ (data clipping-path))
+ (:method ((clipping-path empty-clipping-path))
+ nil))
+
+(defgeneric writable-clipping-data (object)
+ (:method ((clipping-path clipping-path))
+ (data clipping-path))
+ (:method ((clipping-path empty-clipping-path))
+ (let* ((width (width clipping-path))
+ (height (height clipping-path))
+ (data (make-clipping-channel width height #xFF))
+ (scratch (make-clipping-channel width height #x00)))
+ (change-class clipping-path 'clipping-path
+ :data data
+ :scratch scratch)
+ data))
+ (:method ((clipping-path proxy-clipping-path))
+ (let ((data (copy-seq (data clipping-path))))
+ (change-class clipping-path 'clipping-path :data data)
+ data)))
+
+(defun make-clipping-path (width height)
+ (make-instance 'empty-clipping-path :width width :height height))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/color.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/color.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/color.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,54 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: color.lisp,v 1.3 2007/09/20 17:42:03 xach Exp $
+
+(in-package #:vecto)
+
+(defclass color () ())
+
+(defclass rgba-color (color)
+ ((red
+ :initarg :red
+ :accessor red)
+ (green
+ :initarg :green
+ :accessor green)
+ (blue
+ :initarg :blue
+ :accessor blue)
+ (alpha
+ :initarg :alpha
+ :accessor alpha))
+ (:default-initargs
+ :red 0.0 :green 0.0 :blue 0.0 :alpha 1.0))
+
+(defmethod copy ((color rgba-color))
+ (make-instance 'rgba-color
+ :red (red color)
+ :green (green color)
+ :blue (blue color)
+ :alpha (alpha color)))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/copy.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/copy.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/copy.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,36 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: copy.lisp,v 1.2 2007/09/20 18:00:37 xach Exp $
+
+(in-package #:vecto)
+
+(defgeneric copy (object)
+ (:documentation
+ "Copy an object in a way suitable for pushing to the graphics state
+ stack. That is, if it's an immutable object, simply return the
+ object; otherwise, create a new object with the immutable state
+ copied."))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/background.gif
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/background.gif
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-butt.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-butt.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-round.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-round.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-square.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/cap-style-square.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-both.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-both.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-circle.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-circle.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-rectangle.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-to-rectangle.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-unclipped.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/clip-unclipped.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/closed-subpath.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/closed-subpath.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-a.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-a.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-b.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-b.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-c.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-c.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-d.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-d.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-e.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-e.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-none.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/dash-pattern-none.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/examples.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/examples.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/examples.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,97 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: examples.lisp,v 1.4 2007/10/01 19:57:15 xach Exp $
+
+(defpackage #:vecto-examples
+ (:use #:cl #:vecto))
+
+(in-package #:vecto-examples)
+
+(defun radiant-lambda (file)
+ (with-canvas (:width 90 :height 90)
+ (let ((font (get-font "times.ttf"))
+ (step (/ pi 7)))
+ (set-font font 40)
+ (translate 45 45)
+ (draw-centered-string 0 -10 #(#x3BB))
+ (set-rgb-stroke 1 0 0)
+ (centered-circle-path 0 0 35)
+ (stroke)
+ (set-rgba-stroke 0 0 1.0 0.5)
+ (set-line-width 4)
+ (dotimes (i 14)
+ (with-graphics-state
+ (rotate (* i step))
+ (move-to 30 0)
+ (line-to 40 0)
+ (stroke)))
+ (save-png file))))
+
+(defun feedlike-icon (file)
+ (with-canvas (:width 100 :height 100)
+ (set-rgb-fill 1.0 0.65 0.3)
+ (rounded-rectangle 0 0 100 100 10 10)
+ (fill-path)
+ (set-rgb-fill 1.0 1.0 1.0)
+ (centered-circle-path 20 20 10)
+ (fill-path)
+ (flet ((quarter-circle (x y radius)
+ (let ((kappa (* +kappa+ radius)))
+ (move-to (+ x radius) y)
+ (curve-to (+ x radius) (+ y kappa)
+ (+ x kappa) (+ y radius)
+ x (+ y radius)))))
+ (set-rgb-stroke 1.0 1.0 1.0)
+ (set-line-width 15)
+ (quarter-circle 20 20 30)
+ (stroke)
+ (quarter-circle 20 20 60)
+ (stroke))
+ (save-png file)))
+
+(defun star-clipping (file)
+ (with-canvas (:width 200 :height 200)
+ (let ((size 100)
+ (angle 0)
+ (step (* 2 (/ (* pi 2) 5))))
+ (translate size size)
+ (move-to 0 size)
+ (dotimes (i 5)
+ (setf angle (+ angle step))
+ (line-to (* (sin angle) size)
+ (* (cos angle) size)))
+ (even-odd-clip-path)
+ (end-path-no-op)
+ (flet ((circle (distance)
+ (set-rgba-fill distance 0 0
+ (- 1.0 distance))
+ (centered-circle-path 0 0 (* size distance))
+ (fill-path)))
+ (loop for i downfrom 1.0 by 0.05
+ repeat 20 do
+ (circle i)))
+ (save-png file))))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/feedlike-icon.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/feedlike-icon.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/illustrations.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/illustrations.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/illustrations.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,158 @@
+;;;; $Id: illustrations.lisp,v 1.6 2007/10/01 16:24:10 xach Exp $
+
+(defpackage #:vecto-illustrations
+ (:use #:cl #:vecto))
+
+(in-package #:vecto-illustrations)
+
+(defun x (point)
+ (car point))
+
+(defun y (point)
+ (cdr point))
+
+(defun annotated-path (&rest points)
+ (with-graphics-state
+ (set-rgb-stroke 0.5 0.5 0.5)
+ (set-rgb-fill 0.5 0.5 0.5)
+ (set-line-width 2)
+ (dolist (point (remove-duplicates points :test 'equal))
+ (centered-circle-path (x point) (y point) 3))
+ (fill-path)
+ (move-to (x (first points)) (y (first points)))
+ (dolist (point (rest points))
+ (line-to (x point) (y point)))
+ (stroke)))
+
+
+(defun join-style (style file)
+ (with-canvas (:width 160 :height 165)
+ (set-rgb-fill 1 1 1)
+ (clear-canvas)
+ (set-rgb-stroke 0 0 0)
+ (set-line-width 20)
+ (move-to 20 20)
+ (line-to 80 140)
+ (line-to 140 20)
+ (set-line-join style)
+ (stroke)
+ (annotated-path '(20 . 20)
+ '(80 . 140)
+ '(140 . 20))
+ (save-png file)))
+
+
+(defun cap-style (style file)
+ (with-canvas (:width 40 :height 100)
+ (set-rgb-fill 1 1 1)
+ (clear-canvas)
+ (set-rgb-stroke 0 0 0)
+ (set-line-width 20)
+ (move-to 20 20)
+ (line-to 20 80)
+ (set-line-cap style)
+ (stroke)
+ (annotated-path '(20 . 20) '(20 . 80))
+ (save-png file)))
+
+
+
+(defun closed-subpaths (closep file)
+ (with-canvas (:width 160 :height 160)
+ (set-rgb-fill 1 1 1)
+ (clear-canvas)
+ (set-rgb-stroke 0 0 0)
+ (set-line-width 20)
+ (move-to 20 20)
+ (line-to 20 140)
+ (line-to 140 140)
+ (line-to 140 20)
+ (line-to 20 20)
+ (when closep
+ (close-subpath))
+ (stroke)
+ (annotated-path '(20 . 20)
+ '(20 . 140)
+ '(140 . 140)
+ '(140 . 20)
+ '(20 . 20))
+ (save-png file)))
+
+(defun dash-paths (array phase cap-style file)
+ (with-canvas (:width 160 :height 40)
+ (set-rgb-fill 1 1 1)
+ (clear-canvas)
+ (set-rgb-stroke 0 0 0)
+ (set-line-width 20)
+ (with-graphics-state
+ (set-dash-pattern array phase)
+ (set-line-cap cap-style)
+ (move-to 20 20)
+ (line-to 140 20)
+ (stroke))
+ (annotated-path '(20 . 20) '(140 . 20))
+ (save-png file)))
+
+
+(defun simple-clipping-path (file &key clip-circle clip-rounded-rectangle)
+ (with-canvas (:width 100 :height 100)
+ (let ((x0 45)
+ (y 45)
+ (r 40))
+ (set-rgb-fill 1 1 1)
+ (clear-canvas)
+ (with-graphics-state
+ (set-rgb-fill 0.9 0.9 0.9)
+ (rectangle 10 10 80 80)
+ (fill-path))
+ (with-graphics-state
+ (when clip-circle
+ (centered-circle-path x0 y r)
+ (clip-path)
+ (end-path-no-op))
+ (when clip-rounded-rectangle
+ (rounded-rectangle 45 25 50 50 10 10)
+ (clip-path)
+ (end-path-no-op))
+ (set-rgb-fill 1 0 0)
+ (set-rgb-stroke 1 1 0)
+ (rectangle 10 10 80 80)
+ (fill-path))
+ (when clip-circle
+ (with-graphics-state
+ (set-rgb-stroke 0.5 0.5 0.5)
+ (set-dash-pattern #(5) 0)
+ (set-line-width 1)
+ (centered-circle-path x0 y r)
+ (stroke)))
+ (when clip-rounded-rectangle
+ (with-graphics-state
+ (set-rgb-stroke 0.5 0.5 0.5)
+ (set-dash-pattern #(5) 0)
+ (set-line-width 1)
+ (rounded-rectangle 45 25 50 50 10 10)
+ (stroke)))
+ (save-png file))))
+
+
+(defun make-illustrations ()
+ (cap-style :butt "cap-style-butt.png")
+ (cap-style :square "cap-style-square.png")
+ (cap-style :round "cap-style-round.png")
+ (join-style :miter "join-style-miter.png")
+ (join-style :bevel "join-style-bevel.png")
+ (join-style :round "join-style-round.png")
+ (closed-subpaths nil "open-subpath.png")
+ (closed-subpaths t "closed-subpath.png")
+ (dash-paths #() 0 :butt "dash-pattern-none.png")
+ (dash-paths #(30 30) 0 :butt "dash-pattern-a.png")
+ (dash-paths #(30 30) 15 :butt "dash-pattern-b.png")
+ (dash-paths #(10 20 10 40) 0 :butt "dash-pattern-c.png")
+ (dash-paths #(10 20 10 40) 13 :butt "dash-pattern-d.png")
+ (dash-paths #(30 30) 0 :round "dash-pattern-e.png")
+ (simple-clipping-path "clip-unclipped.png")
+ (simple-clipping-path "clip-to-circle.png" :clip-circle t)
+ (simple-clipping-path "clip-to-rectangle.png" :clip-rounded-rectangle t)
+ (simple-clipping-path "clip-to-both.png"
+ :clip-circle t
+ :clip-rounded-rectangle t))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/index.html
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/index.html 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/index.html 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,855 @@
+<html>
+<head>
+<title>Vecto - Simple Vector Drawing with Common Lisp</title>
+<style type="text/css">
+ a, a:visited { text-decoration: none }
+ a[href]:hover { text-decoration: underline }
+ pre { background: #DDD; padding: 0.25em }
+ p.download { color: red }
+ .transparent { background-image: url(background.gif) }
+</style>
+</head>
+
+<body>
+
+<h2>Vecto - Simple Vector Drawing with Common Lisp</h2>
+
+<blockquote class='abstract'>
+<h3>Abstract</h3>
+
+<p>Vecto is a simplified interface to the
+powerful <a href="http://projects.tuxee.net/cl-vectors/">CL-VECTORS</a>
+vector rasterization library. It presents a function-oriented
+interface similar to <a href="http://www.cliki.net/CL-PDF">CL-PDF</a>,
+but the results can be saved to a PNG instead of a PDF file. Since
+Vecto and all supporting libraries are written completely in Common
+Lisp, without depending on external non-Lisp libraries, it should work
+in any Common Lisp environment. Vecto is available under a BSD-like
+license. The current version is 1.0.2, released on October 1st,
+2007.
+
+<p>Vecto is used by <a href="http://wigflip.com/easystreet/">Easystreet</a>.
+
+<p>The canonical location for Vecto
+is <a href="http://www.xach.com/lisp/vecto/">http://www.xach.com/lisp/vecto/</a>.
+
+<p class='download'>Download shortcut:</p>
+
+<p><a href="http://www.xach.com/lisp/vecto.tgz">http://www.xach.com/lisp/vecto.tgz</a>
+
+</blockquote>
+
+<h3>Contents</h3>
+
+<ol>
+<li> <a href='#sect-overview-and-limitations'>Overview and Limitations</a>
+<li> <a href='#sect-examples'>Examples</a>
+<li> <a href='#sect-dictionary'>Dictionary</a>
+
+<ul>
+ <li> <a href='#sect-canvases'>Canvases</a>
+ <ul>
+ <li> <a href='#with-canvas'><tt>with-canvas</tt></a>
+ <li> <a href='#clear-canvas'><tt>clear-canvas</tt></a>
+ <li> <a href='#save-png'><tt>save-png</tt></a>
+ <li> <a href='#save-png-stream'><tt>save-png-stream</tt></a>
+ </ul>
+
+ <li> <a href='#sect-graphics-state'>Graphics State</a>
+ <ul>
+ <li> <a href='#with-graphics-state'><tt>with-graphics-state</tt></a>
+ <li> <a href='#set-rgba-fill'><tt>set-rgba-fill</tt></a>
+ <li> <a href='#set-rgba-fill'><tt>set-rgb-fill</tt></a>
+ <li> <a href='#set-rgba-stroke'><tt>set-rgba-stroke</tt></a>
+ <li> <a href='#set-rgba-stroke'><tt>set-rgb-stroke</tt></a>
+ <li> <a href='#set-line-cap'><tt>set-line-cap</tt></a>
+ <li> <a href='#set-line-join'><tt>set-line-join</tt></a>
+ <li> <a href='#set-line-width'><tt>set-line-width</tt></a>
+ <li> <a href='#set-dash-pattern'><tt>set-dash-pattern</tt></a>
+ <li> <a href='#translate'><tt>translate</tt></a>
+ <li> <a href='#rotate'><tt>rotate</tt></a>
+ <li> <a href='#scale'><tt>scale</tt></a>
+ <li> <a href='#skew'><tt>skew</tt></a>
+ <li> <a href='#clip-path'><tt>clip-path</tt></a>
+ <li> <a href='#even-odd-clip-path'><tt>even-odd-clip-path</tt></a>
+ </ul>
+
+ <li> <a href='#sect-paths'>Paths</a>
+ <ul>
+ <li> <a href='#move-to'><tt>move-to</tt></a>
+ <li> <a href='#line-to'><tt>line-to</tt></a>
+ <li> <a href='#curve-to'><tt>curve-to</tt></a>
+ <li> <a href='#quadratic-to'><tt>quadratic-to</tt></a>
+ <li> <a href='#close-subpath'><tt>close-subpath</tt></a>
+ <li> <a href='#rectangle'><tt>rectangle</tt></a>
+ <li> <a href='#centered-ellipse-path'><tt>centered-ellipse-path</tt></a>
+ <li> <a href='#centered-circle-path'><tt>centered-circle-path</tt></a>
+ </ul>
+
+ <li> <a href='#sect-painting'>Painting</a>
+ <ul>
+ <li> <a href='#fill-path'><tt>fill-path</tt></a>
+ <li> <a href='#even-odd-fill'><tt>even-odd-fill</tt></a>
+ <li> <a href='#stroke'><tt>stroke</tt></a>
+ <li> <a href='#fill-and-stroke'><tt>fill-and-stroke</tt></a>
+ <li> <a href='#even-odd-fill-and-stroke'><tt>even-odd-fill-and-stroke</tt></a>
+ <li> <a href='#end-path-no-op'><tt>end-path-no-op</tt></a>
+ </ul>
+
+ <li> <a href='#sect-text'>Text</a>
+ <ul>
+ <li> <a href='#get-font'><tt>get-font</tt></a>
+ <li> <a href='#set-font'><tt>set-font</tt></a>
+ <li> <a href='#draw-string'><tt>draw-string</tt></a>
+ <li> <a href='#draw-centered-string'><tt>draw-centered-string</tt></a>
+ <li> <a href='#string-bounding-box'><tt>string-bounding-box</tt></a>
+ </ul>
+
+ <li> <a href='#sect-miscellaneous'>Miscellaneous</a>
+ <ul>
+ <li> <a href='#const-kappa'><tt>+kappa+</tt></a>
+ </ul>
+
+</ul>
+
+<li> <a href='#sect-references'>References</a>
+<li> <a href='#sect-feedback'>Feedback</a>
+
+</ol>
+
+<a name='sect-overview-and-limitations'><h3>Overview and Limitations</h3></a>
+
+<p>Vecto is a library that provides a simple interface to the
+the <a href="http://projects.tuxee.net/cl-vectors/">CL-VECTORS</a>
+vector drawing library. It supports drawing on a canvas and saving the
+results to a PNG file.
+
+<p>Vecto depends on the following libraries:
+
+<ul>
+<li> <a href="http://projects.tuxee.net/cl-vectors/">CL-VECTORS</a>
+<li> <a href="http://www.xach.com/lisp/zpb-ttf/">ZPB-TTF</a>
+<li> <a href="http://www.cliki.net/salza">Salza</a>
+<li> <a href="http://www.cliki.net/salza-png">Salza-PNG</a>
+</ul>
+
+<p>The easiest way to install Vecto and all its dependencies is
+with <a href="http://www.cliki.net/asdf-install">ASDF-Install</a>.
+
+<p>Vecto's function interface is similar to the
+PDF vector description and painting interface: you create images by
+describing vector paths, then using stroke or fill operations to paint
+to the canvas.
+
+<p>Vecto's color system uses red, green, blue, and alpha color
+components for drawing. The results can be be saved to a PNG with an
+alpha channel.
+
+<p>Vecto's coordinate system starts at the lower-left corner of the
+image, and increases rightwards along the X axis and upwards along the
+Y axis.
+
+<p>All measurements are in pixels.
+
+<p>PDF is a feature-rich system. Vecto supports a small subset of
+PDF-style operations. In particular, it does not support:
+
+<ul>
+<li> sampled images
+<li> pattern, gradient, or functional fill
+<li> complex layout of text
+<li> PostScript fonts
+<li> non-RGB color spaces
+</ul>
+
+<p>Other limitations:
+
+<ul>
+<li> No output formats other than 8-bit, truecolor-alpha PNGs
+<li> No access to underlying pixel data
+</ul>
+
+<p>Related libraries:
+
+<ul>
+ <li> <a href="http://common-lisp.net/project/imago/">Imago</a>
+
+ <li> <a href="http://cyrusharmon.org/projects?project=ch-image">ch-image</a>
+
+ <li> <a href="http://ygingras.net/poly-pen">Poly-pen</a>
+</ul>
+
+
+<a name='sect-examples'><h3>Examples</h3></a>
+
+<p>All examples are available in <tt>doc/examples.lisp</tt> in the Vecto
+distribution. That file starts with:
+
+<pre>
+(defpackage #:vecto-examples
+ (:use #:cl #:vecto))
+
+(in-package #:vecto-examples)
+</pre>
+
+
+<pre>
+<img border=0 align=right src='lambda-example.png'
+>(defun radiant-lambda (file)
+ (<a href='#with-canvas'>with-canvas</a> (:width 90 :height 90)
+ (let ((font (<a href='#get-font'>get-font</a> "times.ttf"))
+ (step (/ pi 7)))
+ (<a href='#set-font'>set-font</a> font 40)
+ (<a href='#translate'>translate</a> 45 45)
+ (<a href='#draw-centered-string'>draw-centered-string</a> 0 -10 #(#x3BB))
+ (<a href='#set-rgb-stroke'>set-rgb-stroke</a> 1 0 0)
+ (<a href='#centered-circle-path'>centered-circle-path</a> 0 0 35)
+ (<a href='#stroke'>stroke</a>)
+ (<a href='#set-rgba-stroke'>set-rgba-stroke</a> 0 0 1.0 0.5)
+ (<a href='#set-line-width'>set-line-width</a> 4)
+ (dotimes (i 14)
+ (<a href='#with-graphics-state'>with-graphics-state</a>
+ (<a href='#rotate'>rotate</a> (* i step))
+ (<a href='#move-to'>move-to</a> 30 0)
+ (<a href='#line-to'>line-to</a> 40 0)
+ (stroke)))
+ (<a href='#save-png'>save-png</a> file))))
+</pre>
+
+<pre>
+<img align=right src='feedlike-icon.png'
+>(defun feedlike-icon (file)
+ (with-canvas (:width 100 :height 100)
+ (set-rgb-fill 1.0 0.65 0.3)
+ (<a href='#rounded-rectangle'>rounded-rectangle</a> 0 0 100 100 10 10)
+ (<a href='#fill-path'>fill-path</a>)
+ (set-rgb-fill 1.0 1.0 1.0)
+ (centered-circle-path 20 20 10)
+ (fill-path)
+ (flet ((quarter-circle (x y radius)
+ (let ((kappa (* <a href='#const-kappa'>+kappa+</a> radius)))
+ (move-to (+ x radius) y)
+ (curve-to (+ x radius) (+ y kappa)
+ (+ x kappa) (+ y radius)
+ x (+ y radius)))))
+ (set-rgb-stroke 1.0 1.0 1.0)
+ (set-line-width 15)
+ (quarter-circle 20 20 30)
+ (stroke)
+ (quarter-circle 20 20 60)
+ (stroke))
+ (save-png file)))
+</pre>
+
+<pre><div style='float: right' class='transparent'><img src='star-clipping.png'
+></div>(defun star-clipping (file)
+ (with-canvas (:width 200 :height 200)
+ (let ((size 100)
+ (angle 0)
+ (step (* 2 (/ (* pi 2) 5))))
+ (translate size size)
+ (move-to 0 size)
+ (dotimes (i 5)
+ (setf angle (+ angle step))
+ (line-to (* (sin angle) size)
+ (* (cos angle) size)))
+ (<a href='#even-odd-clip-path'><tt>even-odd-clip-path</tt></a>)
+ (<a href='#end-path-no-op'><tt>end-path-no-op</tt></a>)
+ (flet ((circle (distance)
+ (<a href='#set-rgba-fill'><tt>set-rgba-fill</tt></a> distance 0 0
+ (- 1.0 distance))
+ (centered-circle-path 0 0 (* size distance))
+ (fill-path)))
+ (loop for i downfrom 1.0 by 0.05
+ repeat 20 do
+ (circle i)))
+ (save-png file))))
+</pre>
+
+<a name='sect-dictionary'><h3>Dictionary</h3></a>
+
+<p>The following symbols are exported from the <tt>VECTO</tt> package.
+
+<a name='sect-canvases'><h4>Canvases</h4></a>
+
+<p><a name='with-canvas'>[Macro]</a><br>
+<b>with-canvas</b> (<tt>&key</tt> <i>width</i> <i>height</i>)
+<tt>&body</tt> <i>body</i>
+
+<blockquote>
+Evaluates <i>body</i> with a canvas established with the specified
+dimensions as the target for drawing commands. The canvas is initially
+completely clear (all pixels have 0 alpha).
+</blockquote>
+
+
+<p><a name='clear-canvas'>[Function]</a><br>
+<b>clear-canvas</b> => |
+
+<blockquote>
+Completely fills the canvas with the current fill color. Any marks on
+the canvas are cleared.
+</blockquote>
+
+
+<p><a name='save-png'>[Function]</a><br>
+<b>save-png</b> <i>file</i> => <i>truename</i>
+
+<blockquote>
+Writes the contents of the canvas as the PNG <i>file</i>, and returns
+the truename of <i>file</i>.
+</blockquote>
+
+
+<p><a name='save-png-stream'>[Function]</a><br>
+<b>save-png-stream</b> <i>stream</i> => |
+
+<blockquote>
+Writes the contents of the canvas as a PNG to <i>stream</i>, which
+must accept <tt>(unsigned-byte 8)</tt> data.
+</blockquote>
+
+
+<a name='sect-graphics-state'><h4>Graphics State</h4></a>
+
+<p>The graphics state stores several parameters used for graphic
+operations.
+
+<p><a name='with-graphics-state'>[Macro]</a><br>
+<b>with-graphics-state</b> <tt>&body</tt> <i>body</i>
+
+<blockquote>
+Evaluates the forms of <i>body</i> with a copy of the current graphics
+state. Any modifications to the state are undone at the end of the
+form.
+</blockquote>
+
+
+<p><a name='set-rgba-fill'>[Functions]</a><br>
+<b>set-rgba-fill</b> <i>r</i> <i>g</i> <i>b</i> <i>alpha</i> => |<br>
+<b>set-rgb-fill</b> <i>r</i> <i>g</i> <i>b</i> => |
+
+<blockquote>
+Sets the fill color. <i>r</i>, <i>g</i>, <i>b</i>, and <i>alpha</i>
+should be in the range of 0.0 to 1.0.
+
+<p><tt>set-rgb-fill</tt> is the same as <tt>set-rgba-fill</tt> with an
+implicit alpha value of 1.0.
+
+<p>The fill color is used
+for <a
+href='#clear-canvas'><tt>CLEAR-CANVAS</tt></a>, <a
+href='#fill-path'><tt>FILL-PATH</tt></a>, <a
+href='#even-odd-fill'><tt>EVEN-ODD-FILL</tt></a>, <a
+href='#fill-and-stroke'><tt>FILL-AND-STROKE</tt></a>, <a
+href='#even-odd-fill-and-stroke'><tt>EVEN-ODD-FILL-AND-STROKE</tt></a>,
+and <a href='#draw-string'><tt>DRAW-STRING</tt></a>.
+
+</blockquote>
+
+<p><a name='set-rgba-stroke'>[Functions]</a><br>
+<b>set-rgba-stroke</b> <i>r</i> <i>g</i> <i>b</i> <i>alpha</i> => |<br>
+<b>set-rgb-stroke</b> <i>r</i> <i>g</i> <i>b</i> => |
+
+<blockquote>
+Sets the stroke color. <i>r</i>, <i>g</i>, <i>b</i>, and <i>alpha</i>
+should be in the range of 0.0 to 1.0.
+
+<p><tt>set-rgb-stroke</tt> is the same as <tt>set-rgba-stroke</tt>
+with an implicit alpha value of 1.0.
+
+<p>The stroke color is used for <a href='#stroke'><tt>STROKE</tt></a>,
+<a href='#fill-and-stroke'><tt>FILL-AND-STROKE</tt></a>,
+and <a href='#even-odd-fill-and-stroke'><tt>EVEN-ODD-FILL-AND-STROKE</tt></a>.
+</blockquote>
+
+
+<p><a name='set-line-cap'>[Function]</a><br>
+<b>set-line-cap</b> <i>style</i> => |
+
+<blockquote>
+Sets the line cap style to <i>style</i>, which must be one
+of <tt>:BUTT</tt>, <tt>:SQUARE</tt>, or <tt>:ROUND</tt>. The initial
+value is <tt>:BUTT</tt>.
+
+<p><table cellspacing=5 id="line-cap">
+<tr>
+ <td align=center><img src="cap-style-butt.png"></td>
+ <td align=center><img src="cap-style-square.png"></td>
+ <td align=center><img src="cap-style-round.png"></td>
+</tr>
+<tr>
+ <td align=center><tt>:BUTT</tt></td>
+ <td align=center><tt>:SQUARE</tt></td>
+ <td align=center><tt>:ROUND</tt></td>
+</tr>
+</table>
+
+</blockquote>
+
+
+<p><a name='set-line-join'>[Function]</a><br>
+<b>set-line-join</b> <i>style</i> => |
+
+<blockquote>
+Sets the line join style to <i>style</i>, which must be one
+of <tt>:MITER</tt>, <tt>:BEVEL</tt>, or <tt>:ROUND</tt>. The initial
+value is <tt>:MITER</tt>.
+
+<p><table cellspacing=5 id="line-join">
+<tr>
+ <td align=center><img src="join-style-miter.png"></td>
+ <td align=center><img src="join-style-bevel.png"></td>
+ <td align=center><img src="join-style-round.png"></td>
+</tr>
+<tr>
+ <td align=center><tt>:MITER</tt></td>
+ <td align=center><tt>:BEVEL</tt></td>
+ <td align=center><tt>:ROUND</tt></td>
+</tr>
+</table>
+
+</blockquote>
+
+
+<p><a name='set-line-width'>[Function]</a><br>
+<b>set-line-width</b> <i>width</i> => |
+
+<blockquote>
+Sets the line width for strokes to <i>width</i>.
+</blockquote>
+
+
+
+<p><a name='set-dash-pattern'>[Function]</a><br>
+<b>set-dash-pattern</b> <i>dash-vector</i> <i>phase</i> => |
+
+<blockquote>
+Sets the dash pattern according to <i>dash-vector</i> and <i>phase</i>.
+
+<p><i>dash-vector</i> should be a vector of numbers denoting on and
+off patterns for a stroke. An empty <i>dash-vector</i> is the same as
+having no dash pattern at all.
+
+<p><i>phase</i> is how far along the dash pattern to proceed before
+applying the pattern to the current stroke.
+
+<p>
+<table>
+ <tr>
+ <th>Appearance</th>
+ <th>Dash Vector and Phase</th>
+ </tr>
+ <tr>
+ <td align=center><img src="dash-pattern-none.png"></td>
+ <td align=left><tt>#() 0</tt></td>
+ </tr>
+ <tr>
+ <td align=center><img src="dash-pattern-a.png"></td>
+ <td align=left><tt>#(30 30) 0</tt></td>
+ </tr>
+ <tr>
+ <td align=center><img src="dash-pattern-b.png"></td>
+ <td align=left><tt>#(30 30) 15</tt></td>
+ </tr>
+ <tr>
+ <td align=center><img src="dash-pattern-c.png"></td>
+ <td align=left><tt>#(10 20 10 40) 0</tt></td>
+ </tr>
+ <tr>
+ <td align=center><img src="dash-pattern-d.png"></td>
+ <td align=left><tt>#(10 20 10 40) 13</tt></td>
+ </tr>
+ <tr>
+ <td align=center><img src="dash-pattern-e.png"></td>
+ <td align=left><tt>#(30 30) 0</tt>, <tt>:ROUND</tt> line caps</td>
+ </tr>
+</table>
+</blockquote>
+
+
+<p><a name='translate'>[Function]</a><br>
+<b>translate</b> <i>x</i> <i>y</i> => |
+
+<blockquote>
+Offsets the coordinate system by <i>x</i> units horizontally
+and <i>y</i> units vertically.
+</blockquote>
+
+
+<p><a name='rotate'>[Function]</a><br>
+<b>rotate</b> <i>radians</i> => |
+
+<blockquote>
+Rotates the coordinate system by <i>radians</i>.
+</blockquote>
+
+
+<p><a name='scale'>[Function]</a><br>
+<b>scale</b> <i>sx</i> <i>sy</i> => |
+
+<blockquote>
+Scales the coordinate system by <i>sx</i> horizontally
+and <i>sy</i> vertically.
+</blockquote>
+
+
+<p><a name='skew'>[Function]</a><br>
+<b>skew</b> <i>ax</i> <i>ay</i> => |
+
+<blockquote>
+Skews the X axis of the coordinate system by <i>ax</i> radians and the
+Y axis by <i>ay</i> radians.
+</blockquote>
+
+
+<p><a name='clip-path'>[Function]</a><br>
+<b>clip-path</b> => |
+
+<blockquote>
+Defines a clipping path based on the current path. It is not applied
+immediately, but is created after after the painting is done in the
+next call to one
+of <a
+href='#fill-path'><tt>FILL-PATH</tt></a>, <a
+href='#even-odd-fill'><tt>EVEN-ODD-FILL</tt></a>, <a
+href='#fill-and-stroke'><tt>FILL-AND-STROKE</tt></a>, <a
+href='#even-odd-fill-and-stroke'><tt>EVEN-ODD-FILL-AND-STROKE</tt></a>,
+or <a href='#end-path-no-op'><tt>END-PATH-NO-OP</tt></a>.
+
+<p>The clipping path initially covers the entire canvas; no clipping
+is done. Subsequent calls to <tt>CLIP-PATH</tt> set the clipping path
+to the intersection of the established clipping path and the new
+clipping path, and all drawing will be done within the outline of the
+clipping path.
+
+<p>The outline of the clipping path is defined with the nonzero
+winding rule, as with <a href='#fill-path'><tt>FILL-PATH</tt></a>.
+
+<p>There is no way to enlarge the clipping path. However, the clipping
+path is part of the graphics state, so changes may be localized by
+using <a href='#with-graphics-state'><tt>WITH-GRAPHICS-STATE</tt></a>.
+
+
+<p><table>
+<tr>
+ <td><img src="clip-unclipped.png"></td>
+ <td>A filled red rectangle, not clipped</td>
+</tr>
+<tr>
+ <td><img src="clip-to-circle.png"></td>
+ <td>The same rectangle drawn with a circle clipping path in effect</td>
+</tr>
+<tr>
+ <td><img src="clip-to-rectangle.png"></td>
+ <td>Clipped to a rounded rectangle clipping path</td>
+</tr>
+<tr>
+ <td><img src="clip-to-both.png"></td>
+ <td>Clipped to the intersection of the circle and rounded rectangle clipping paths</td>
+</tr>
+</table>
+
+
+
+</blockquote>
+
+
+<p><a name='even-odd-clip-path'>[Function]</a><br>
+<b>even-odd-clip-path</b> => |
+
+<blockquote>
+Like <a href='#clip-path'><tt>CLIP-PATH</tt></a>, but uses the
+even/odd fill rule to determine the outline of the clipping path.
+</blockquote>
+
+
+<a name='sect-paths'><h4>Paths</h4></a>
+
+<p>Paths are used to create lines for stroking or outlines for
+filling. Paths consist of straight lines and curves. Paths consist of
+one or more subpaths.
+
+<p><a name='move-to'>[Function]</a><br>
+<b>move-to</b> <i>x</i> <i>y</i> => |
+
+<blockquote>
+Starts a new subpath at (<i>x</i>,<i>y</i>). <tt>move-to</tt> must be the
+first step of constructing a subpath.
+</blockquote>
+
+
+<p><a name='line-to'>[Function]</a><br>
+<b>line-to</b> <i>x</i> <i>y</i> => |
+
+<blockquote>
+Appends a straight line ending at (<i>x</i>,<i>y</i>) to the
+current subpath.
+</blockquote>
+
+
+<p><a name='curve-to'>[Function]</a><br>
+<b>curve-to</b>
+<i>cx1</i> <i>cy1</i>
+<i>cx2</i> <i>cy2</i>
+<i>x</i> <i>y</i> => |
+
+<blockquote>
+Appends a
+cubic <a href="http://en.wikipedia.org/wiki/B%C3%A9zier_curve">Bézier
+curve</a> ending at (<i>x</i>,<i>y</i>) and with control
+points (<i>cx1</i>,<i>cy1</i>) and (<i>cx2</i>,<i>cy2</i>) to the current
+subpath.
+</blockquote>
+
+
+<p><a name='quadratic-to'>[Function]</a><br>
+<b>quadratic-to</b>
+<i>cx</i> <i>cy</i>
+<i>x</i> <i>y</i> => |
+
+<blockquote>
+Appends a quadratic Bézier curve ending at (<i>x</i>,<i>y</i>)
+and with the control point (<i>cx</i>,<i>cy</i>) to the current
+subpath.
+</blockquote>
+
+
+<p><a name='close-subpath'>[Function]</a><br>
+<b>close-subpath</b> => |
+
+<blockquote>
+Closes the current subpath. If the current point is not the same as the
+starting point for the subpath, appends a straight line from the
+current point to the starting point of the current subpath.
+
+<p>Subpaths with start and end points that coincidentally overlap are
+not the same as closed subpaths. The distinction is important when
+stroking:
+
+<p><table cellpadding=5>
+ <tr>
+ <td align=center><img src="open-subpath.png"></td>
+ <td align=center><img src="closed-subpath.png"></td>
+ </tr>
+ <tr>
+ <td align=center>Open subpath</td>
+ <td align=center>Closed subpath</td>
+ </tr>
+</table>
+
+<p>If the subpath is not closed, the start and points of the subpath
+ will be drawn with the current line cap style. If the path is
+ closed, the start and endpoints will be treated as joined and drawn
+ with the line join style.
+</blockquote>
+
+
+<p><a name='rectangle'>[Function]</a><br>
+<b>rectangle</b> <i>x</i> <i>y</i> <i>width</i> <i>height</i>
+
+<blockquote>
+Creates a rectangular subpath with the given <i>width</i>
+and <i>height</i> that has its lower-left corner at
+(<i>x</i>,<i>y</i>). It is effectively the same as:
+
+<pre>
+(move-to x y)
+(line-to (+ x width) y)
+(line-to (+ x width) (+ y height))
+(line-to x (+ y height))
+(close-subpath)
+</pre>
+</blockquote>
+
+<p><a name='centered-ellipse-path'>[Function]</a><br>
+<b>centered-ellipse-path</b>
+<i>x</i> <i>y</i>
+<i>rx</i> <i>ry</i>
+
+<blockquote>
+Adds a closed subpath that outlines an ellipse centered at
+(<i>x</i>,<i>y</i>) with an X radius of <i>rx</i> and a Y radius
+of <i>ry</i>.
+</blockquote>
+
+<p><a name='centered-circle-path'>[Function]</a><br>
+<b>centered-circle-path</b> <i>x</i> <i>y</i> <i>radius</i> => |
+
+<blockquote>
+Adds a closed subpath that outlines a circle centered at
+(<i>x</i>,<i>y</i>) with a radius of <i>radius</i>. It is effectively
+the same as:
+
+<pre>
+(centered-ellipse-path x y radius radius)
+</pre>
+</blockquote>
+
+
+
+<a name='sect-painting'><h4>Painting</h4></a>
+
+<p>After a path is defined, filling, stroking, or both will use the
+path to apply color to the canvas. After a path has been filled or
+stroked, it is no longer active; it effectively disappears.
+
+
+<p><a name='fill-path'>[Function]</a><br>
+<b>fill-path</b> => |
+
+<blockquote>
+Fills the current path with the fill color. If the path has not been
+explicitly closed
+with <a href='#close-subpath'><tt>CLOSE-SUBPATH</tt></a>, it is
+implicitly closed before filling. The non-zero winding rule is used
+to determine what areas are considered inside the path.
+</blockquote>
+
+
+<p><a name='even-odd-fill'>[Function]</a><br>
+<b>even-odd-fill</b> => |
+
+<blockquote>
+The same as <a href='#fill-path'><tt>FILL-PATH</tt></a>, but uses the
+even/odd rule to determine what areas are considered inside the path.
+</blockquote>
+
+
+<p><a name='stroke'>[Function]</a><br>
+<b>stroke</b> => |
+
+<blockquote>
+Strokes the current path. The line width, stroke color, line join
+style, line cap style, and dash pattern and phase determine how the
+stroked path will appear on the canvas.
+</blockquote>
+
+
+<p><a name='fill-and-stroke'>[Function]</a><br>
+<b>fill-and-stroke</b> => |
+
+<blockquote>
+Fills the current path, then strokes it.
+</blockquote>
+
+
+<p><a name='even-odd-fill-and-stroke'>[Function]</a><br>
+<b>even-odd-fill-and-stroke</b> => |
+
+<blockquote>
+Fills the current path using the even/odd rule, then strokes it.
+</blockquote>
+
+
+<p><a name='end-path-no-op'>[Function]</a><br>
+<b>end-path-no-op</b> => |
+
+<blockquote>
+Ends the current path without painting anything. If a clipping path
+has been specified with <a href='#clip-path'><tt>CLIP-PATH</tt></a>
+or <a href='#even-odd-clip-path'><tt>EVEN-ODD-CLIP-PATH</tt></a>, it
+will be created by <tt>end-path-no-op</tt>.
+</blockquote>
+
+
+
+<a name='sect-text'><h4>Text</h4></a>
+
+<p>Vecto can draw text to a canvas. It loads glyph shapes from
+ TrueType font files
+ with <a href="http://www.xach.com/lisp/zpb-ttf/">ZPB-TTF</a>.
+
+<p><a name='get-font'>[Function]</a><br>
+<b>get-font</b> <i>font-file</i> => <i>font-loader</i>
+
+<blockquote>
+Creates and returns a ZPB-TTF font loader object
+from <i>font-file</i>. Any font loader created this way will
+automatically be closed at the end of its
+enclosing <a href='#with-canvas'><tt>WITH-CANVAS</tt></a> form.
+</blockquote>
+
+
+<p><a name='set-font'>[Function]</a><br>
+<b>set-font</b> <i>font-loader</i> <i>size</i> => |
+
+<blockquote>
+Sets the active font to the font associated
+with <i>font-loader</i>, scaled to <i>size</i> units per line.
+
+<p>The first argument can be any ZPB-TTF font loader; it need not be
+created via <a href='#get-font'><tt>GET-FONT</tt></a>. However, only
+font loaders created via <tt>GET-FONT</tt> will be automatically
+closed at the end of <a href='#with-canvas'><tt>WITH-CANVAS</tt></a>.
+</blockquote>
+
+
+<p><a name='draw-string'>[Function]</a><br>
+<b>draw-string</b> <i>x</i> <i>y</i> <i>string</i> => |
+
+<blockquote>
+Draws <i>string</i> on the canvas with the active font. The glyph
+origin of the first character in the string is positioned at <i>x</i>
+and the baseline of the string is positioned at <i>y</i>. The text is
+filled with the current <a href='#set-rgba-fill'>fill color</a>.
+
+<p>The string may be a specialized vector of characters (a true CL
+string) or a vector containing characters, Unicode code-points, or both. For
+example, <tt>#(#\L #\a #\m #\b #\d #\a #\= #x3BB)</tt> is a valid
+argument for <tt>DRAW-STRING</tt>.
+</blockquote>
+
+
+<p><a name='draw-centered-string'>[Function]</a><br>
+<b>draw-centered-string</b> <i>x</i> <i>y</i> <i>string</i> => |
+
+<blockquote>
+Draws <i>string</i> on the canvas with the active font. The horizontal
+center of the string is positioned at <i>x</i> and the baseline of the
+string is positioned at <i>y</i>.
+</blockquote>
+
+
+<p><a name='string-bounding-box'>[Function]</a><br>
+<b>string-bounding-box</b> <i>string</i> <i>size</i> <i>loader</i>
+=> <i>#(xmin ymin xmax ymax)</i>
+
+<blockquote>
+Calculates the bounding box of <i>string</i> for <i>font-loader</i>
+at <i>size</i>.
+</blockquote>
+
+
+<a name='sect-miscellaneous'><h3>Miscellaneous</h3></a>
+
+<p><a name='const-kappa'>[Constant]</a><br>
+<b>+kappa+</b> => 0.5522847498307936d0.
+
+<blockquote>
+This constant is useful to draw portions of a circle.
+</blockquote>
+
+
+<a name='sect-references'><h2>References</h2></a>
+
+<ul>
+ <li> Adobe Systems Inc., <a href="http://www.adobe.com/devnet/pdf/pdf_reference.html">PDF Reference, Sixth Edition, Version 1.7</a>
+ <li> Lawrence Kesteloot, <a href="http://www.teamten.com/lawrence/graphics/premultiplication/">Alpha Premultiplication</a>
+ <li> Dr. Thomas Sederberg, <a href="http://www.tsplines.com/resources/class_notes/Bezier_curves.pdf">Bézier curves</a>
+ <li> Alvy Ray Smith, <a href="http://alvyray.com/Memos/MemosMicrosoft.htm#ImageCompositing">Image Compositing Fundamentals</a>
+ <li> G. Adam Stanislav, <a href="http://www.whizkidtech.redprince.net/bezier/circle/">Drawing a circle with Bézier curves</a>
+ <li> Wikipedia, <a href="http://en.wikipedia.org/wiki/B%C3%A9zier_curve">Bézier curve</a>
+
+</ul>
+
+
+<a name='sect-feedback'><h2>Feedback</h2></a>
+
+<p>If you have any questions, comments, bug reports, or other feedback
+regarding Vecto, please email <a href="mailto:xach at xach.com">Zach
+Beane</a>.
+
+<p><hr>
+<tt>$Id: index.html,v 1.27 2007/10/01 20:03:18 xach Exp $</tt>
+
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-bevel.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-bevel.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-miter.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-miter.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-round.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/join-style-round.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/lambda-example.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/lambda-example.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/open-subpath.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/open-subpath.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/star-clipping.png
===================================================================
(Binary files differ)
Property changes on: branches/trunk-reorg/thirdparty/vecto-1.0.2/doc/star-clipping.png
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/drawing.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/drawing.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/drawing.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,279 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: drawing.lisp,v 1.17 2007/10/01 19:05:13 xach Exp $
+
+(in-package #:vecto)
+
+(deftype octet ()
+ '(unsigned-byte 8))
+
+(deftype vector-index ()
+ `(mod ,array-dimension-limit))
+
+(deftype octet-vector ()
+ '(simple-array (unsigned-byte 8) (*)))
+
+(defun nonzero-winding-alpha (alpha)
+ (min 255 (abs alpha)))
+
+(defun even-odd-alpha (alpha)
+ (let ((value (mod alpha 512)))
+ (min 255 (if (< value 256) value (- 512 value)))))
+
+;; ( (t) = (a) * (b) + 0x80, ( ( ( (t)>>8 ) + (t) )>>8 ) )
+
+(defun imult (a b)
+ (let ((temp (+ (* a b) #x80)))
+ (logand #xFF (ash (+ (ash temp -8) temp) -8))))
+
+(defun lerp (p q a)
+ (logand #xFF (+ p (imult a (- q p)))))
+
+(defun prelerp (p q a)
+ (logand #xFF (- (+ p q) (imult a p))))
+
+(defun draw-function (data width height r.fg g.fg b.fg a.fg alpha-fun)
+ "From http://www.teamten.com/lawrence/graphics/premultiplication/"
+ (declare (ignore height))
+ (let ((r.fg (float-octet r.fg))
+ (g.fg (float-octet g.fg))
+ (b.fg (float-octet b.fg))
+ (a.fg (float-octet a.fg)))
+ (lambda (x y alpha)
+ (setf alpha (funcall alpha-fun alpha))
+ (when (plusp alpha)
+ (let* ((i (* +png-channels+ (+ x (* y width))))
+ (r.bg (aref data (+ i 0)))
+ (g.bg (aref data (+ i 1)))
+ (b.bg (aref data (+ i 2)))
+ (a.bg (aref data (+ i 3)))
+ (a.fg (imult alpha a.fg))
+ (gamma (prelerp a.fg a.bg a.bg)))
+ (flet ((blend (fg bg)
+ (let ((value (lerp (imult bg a.bg) fg a.fg)))
+ (float-octet (/ value gamma)))))
+ (unless (zerop gamma)
+ (setf (aref data (+ i 0)) (blend r.fg r.bg)
+ (aref data (+ i 1)) (blend g.fg g.bg)
+ (aref data (+ i 2)) (blend b.fg b.bg)))
+ (setf (aref data (+ i 3)) gamma)))))))
+
+(defun draw-function/clipped (data clip-data
+ width height
+ r.fg g.fg b.fg a.fg
+ alpha-fun)
+ "Like DRAW-FUNCTION, but uses uses the clipping channel."
+ (declare (ignore height))
+ (let ((r.fg (float-octet r.fg))
+ (g.fg (float-octet g.fg))
+ (b.fg (float-octet b.fg))
+ (a.fg (float-octet a.fg)))
+ (lambda (x y alpha)
+ (let* ((clip-index (+ x (* y width)))
+ (clip (aref clip-data clip-index)))
+ (setf alpha (imult clip (funcall alpha-fun alpha)))
+ (when (plusp alpha)
+ (let* ((i (* clip-index +png-channels+))
+ (r.bg (aref data (+ i 0)))
+ (g.bg (aref data (+ i 1)))
+ (b.bg (aref data (+ i 2)))
+ (a.bg (aref data (+ i 3)))
+ (a.fg (imult alpha a.fg))
+ (gamma (prelerp a.fg a.bg a.bg)))
+ (flet ((blend (fg bg)
+ (let ((value (lerp (imult bg a.bg) fg a.fg)))
+ (float-octet (/ value gamma)))))
+ (unless (zerop gamma)
+ (setf (aref data (+ i 0)) (blend r.fg r.bg)
+ (aref data (+ i 1)) (blend g.fg g.bg)
+ (aref data (+ i 2)) (blend b.fg b.bg)))
+ (setf (aref data (+ i 3)) gamma))))))))
+
+(defun make-draw-function (data clipping-path
+ width height
+ r g b a
+ alpha-fun)
+ (if (emptyp clipping-path)
+ (draw-function data width height r g b a alpha-fun)
+ (draw-function/clipped data (clipping-data clipping-path)
+ width height
+ r g b a
+ alpha-fun)))
+
+(defun intersect-clipping-paths (data temp)
+ (declare (type (simple-array (unsigned-byte 8) (*)) data temp))
+ (map-into data #'imult temp data))
+
+(defun draw-clipping-path-function (data width height alpha-fun)
+ (declare (ignore height)
+ (type (simple-array (unsigned-byte 8) (*)) data))
+ (lambda (x y alpha)
+ (let ((i (+ x (* width y))))
+ (let ((alpha (funcall alpha-fun alpha)))
+ (setf (aref data i) alpha)))))
+
+(defun draw-paths (&key width height paths
+ transform-function
+ draw-function)
+ "Use DRAW-FUNCTION as a callback for the cells sweep function
+for the set of paths PATHS."
+ (let ((state (aa:make-state))
+ (paths (mapcar (lambda (path)
+ ;; FIXME: previous versions lacked
+ ;; paths:path-clone, and this broke fill &
+ ;; stroke because transform-path damages the
+ ;; paths. It would be nicer if transform-path
+ ;; wasn't destructive, since I didn't expect
+ ;; it to be.
+ (transform-path (paths:path-clone path)
+ transform-function))
+ paths)))
+ (vectors:update-state state paths)
+ (aa:cells-sweep/rectangle state 0 0 width height draw-function)))
+
+;;; FIXME: this was added for drawing text paths, but the text
+;;; rendering mode could be changed in the future, making it a little
+;;; silly to have a fixed draw-function.
+
+(defun draw-paths/state (paths state)
+ (draw-paths :paths paths
+ :width (width state)
+ :height (height state)
+ :transform-function (transform-function state)
+ :draw-function (fill-draw-function state)))
+
+(defun fill-image (image-data red green blue alpha)
+ "Completely fill IMAGE with the given colors."
+ (let ((r (float-octet red))
+ (g (float-octet green))
+ (b (float-octet blue))
+ (a (float-octet alpha)))
+ (do ((h 0 (+ h 4))
+ (i 1 (+ i 4))
+ (j 2 (+ j 4))
+ (k 3 (+ k 4)))
+ ((<= (length image-data) k))
+ (setf (aref image-data h) r
+ (aref image-data i) g
+ (aref image-data j) b
+ (aref image-data k) a))))
+
+(defun state-draw-function (state color fill-style)
+ "Create a draw function for the graphics state STATE."
+ (make-draw-function (image-data state)
+ (clipping-path state)
+ (width state)
+ (height state)
+ (red color)
+ (green color)
+ (blue color)
+ (alpha color)
+ (ecase fill-style
+ (:even-odd #'even-odd-alpha)
+ (:nonzero-winding #'nonzero-winding-alpha))))
+
+(defun stroke-draw-function (state)
+ (state-draw-function state (stroke-color state) :nonzero-winding))
+
+(defun fill-draw-function (state)
+ (state-draw-function state (fill-color state) :nonzero-winding))
+
+(defun even-odd-fill-draw-function (state)
+ (state-draw-function state (fill-color state) :even-odd))
+
+(defun tolerance-scale (state)
+ (let ((matrix (transform-matrix state)))
+ (abs (/ 1.0 (min (transform-matrix-x-scale matrix)
+ (transform-matrix-y-scale matrix))))))
+
+
+(defun draw-stroked-paths (state)
+ "Create a set of paths representing a stroking of the current
+paths of STATE, and draw them to the image."
+ (let ((paths (dash-paths (paths state)
+ (dash-vector state)
+ (dash-phase state)))
+ (paths:*bezier-distance-tolerance*
+ (* paths:*bezier-distance-tolerance* (tolerance-scale state))))
+ (setf paths (stroke-paths paths
+ :line-width (line-width state)
+ :join-style (join-style state)
+ :cap-style (cap-style state)))
+ (draw-paths :paths paths
+ :width (width state)
+ :height (height state)
+ :transform-function (transform-function state)
+ :draw-function (stroke-draw-function state))))
+
+(defun close-paths (paths)
+ (dolist (path paths)
+ (setf (paths::path-type path) :closed-polyline)))
+
+(defun draw-filled-paths (state)
+ "Fill the paths of STATE into the image."
+ (close-paths (paths state))
+ (draw-paths :paths (paths state)
+ :width (width state)
+ :height (height state)
+ :transform-function (transform-function state)
+ :draw-function (fill-draw-function state)))
+
+(defun draw-even-odd-filled-paths (state)
+ "Fill the paths of STATE into the image."
+ (close-paths (paths state))
+ (draw-paths :paths (paths state)
+ :width (width state)
+ :height (height state)
+ :transform-function (transform-function state)
+ :draw-function (even-odd-fill-draw-function state)))
+
+(defun draw-clipping-path (state alpha-fun)
+ (let ((data (writable-clipping-data (clipping-path state)))
+ (scratch (scratch (clipping-path state)))
+ (width (width state))
+ (height (height state)))
+ (declare (type octet-vector data scratch))
+ (fill scratch 0)
+ (draw-paths :paths (paths state)
+ :width (width state)
+ :height (height state)
+ :transform-function (transform-function state)
+ :draw-function (draw-clipping-path-function scratch
+ width
+ height
+ alpha-fun))
+ (intersect-clipping-paths data scratch)))
+
+(defun make-clipping-path-function (state type)
+ (ecase type
+ (:nonzero-winding
+ (lambda ()
+ (draw-clipping-path state #'nonzero-winding-alpha)))
+ (:even-odd
+ (lambda ()
+ (draw-clipping-path state #'even-odd-alpha)))))
+
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/graphics-state.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/graphics-state.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/graphics-state.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,204 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: graphics-state.lisp,v 1.15 2007/10/01 02:24:44 xach Exp $
+
+(in-package #:vecto)
+
+(defconstant +png-channels+ 4)
+(defconstant +png-color-type+ :truecolor-alpha)
+
+(defclass graphics-state ()
+ ((paths
+ :initarg :paths
+ :accessor paths)
+ (path
+ :initarg :path
+ :accessor path)
+ (height
+ :initarg :height
+ :accessor height)
+ (width
+ :initarg :width
+ :accessor width)
+ (image
+ :initarg :image
+ :accessor image)
+ (stroke-color
+ :initarg :stroke-color
+ :accessor stroke-color)
+ (line-width
+ :initarg :line-width
+ :accessor line-width)
+ (dash-vector
+ :initarg :dash-vector
+ :accessor dash-vector)
+ (dash-phase
+ :initarg :dash-phase
+ :accessor dash-phase)
+ (fill-color
+ :initarg :fill-color
+ :accessor fill-color)
+ (join-style
+ :initarg :join-style
+ :accessor join-style)
+ (cap-style
+ :initarg :cap-style
+ :accessor cap-style)
+ (transform-matrix
+ :initarg :transform-matrix
+ :accessor transform-matrix)
+ (clipping-path
+ :initarg :clipping-path
+ :accessor clipping-path)
+ (after-paint-fun
+ :initarg :after-paint-fun
+ :accessor after-paint-fun)
+ (font-loaders
+ :initarg :font-loaders
+ :accessor font-loaders)
+ (font
+ :initarg :font
+ :accessor font))
+ (:default-initargs
+ :paths nil
+ :path nil
+ :stroke-color (make-instance 'rgba-color)
+ :line-width 1.0
+ :dash-vector nil
+ :dash-phase 0
+ :fill-color (make-instance 'rgba-color)
+ :join-style :miter
+ :cap-style :butt
+ :transform-matrix (scaling-matrix 1.0 -1.0)
+ :after-paint-fun (constantly nil)
+ :font-loaders (make-hash-table :test 'equal)
+ :font nil))
+
+(defgeneric image-data (state)
+ (:method (state)
+ (png::image-data (image state))))
+
+(defgeneric transform-function (state)
+ (:documentation "Return a function that takes x, y coordinates
+and returns them transformed by STATE's current transformation
+matrix as multiple values.")
+ (:method (state)
+ (make-transform-function (transform-matrix state))))
+
+
+(defgeneric call-after-painting (state fun)
+ (:documentation
+ "Call FUN after painting, and reset the post-painting fun to a no-op.")
+ (:method (state fun)
+ (setf (after-paint-fun state)
+ (lambda ()
+ (funcall fun)
+ (setf (after-paint-fun state) (constantly nil))))))
+
+(defgeneric after-painting (state)
+ (:documentation "Invoke the post-painting function.")
+ (:method (state)
+ (funcall (after-paint-fun state))))
+
+
+(defgeneric apply-matrix (state matrix)
+ (:documentation "Replace the current transform matrix of STATE
+with the result of premultiplying it with MATRIX.")
+ (:method (state matrix)
+ (let ((old (transform-matrix state)))
+ (setf (transform-matrix state) (mult matrix old)))))
+
+(defgeneric clear-paths (state)
+ (:documentation "Clear out any paths in STATE.")
+ (:method (state)
+ (setf (paths state) nil
+ (path state) nil
+ (after-paint-fun state) (constantly nil))))
+
+
+(defun make-image-data (width height bpp)
+ "Make an octet vector suitable for use as the image data vector of a
+backing image."
+ (make-array (* width height bpp)
+ :element-type '(unsigned-byte 8)
+ :initial-element #x00))
+
+(defun state-image (state width height)
+ "Set the backing image of the graphics state to an image of the
+specified dimensions."
+ (setf (image state)
+ (make-instance 'png:png
+ :width width
+ :height height
+ :color-type +png-color-type+
+ :image-data (make-image-data width height
+ +png-channels+))
+ (width state) width
+ (height state) height
+ (clipping-path state) (make-clipping-path width height))
+ (apply-matrix state (translation-matrix 0 (- height))))
+
+
+(defun find-font-loader (state file)
+ (let* ((cache (font-loaders state))
+ (key (namestring (truename file))))
+ (or (gethash key cache)
+ (setf (gethash key cache) (zpb-ttf:open-font-loader file)))))
+
+(defgeneric close-font-loaders (state)
+ (:documentation "Close any font loaders that were obtained with GET-FONT.")
+ (:method (state)
+ (maphash (lambda (filename loader)
+ (declare (ignore filename))
+ (ignore-errors (zpb-ttf:close-font-loader loader)))
+ (font-loaders state))))
+
+(defgeneric clear-state (state)
+ (:documentation "Clean up any state in STATE.")
+ (:method ((state graphics-state))
+ (close-font-loaders state)))
+
+
+(defmethod copy ((state graphics-state))
+ (make-instance 'graphics-state
+ :paths (paths state)
+ :path (path state)
+ :height (height state)
+ :width (width state)
+ :image (image state)
+ :stroke-color (copy (stroke-color state))
+ :line-width (line-width state)
+ :dash-vector (copy-seq (dash-vector state))
+ :dash-phase (dash-phase state)
+ :fill-color (copy (fill-color state))
+ :join-style (join-style state)
+ :cap-style (cap-style state)
+ :transform-matrix (copy-seq (transform-matrix state))
+ :clipping-path (copy (clipping-path state))
+ :after-paint-fun (after-paint-fun state)
+ :font-loaders (font-loaders state)
+ :font (font state)))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/package.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/package.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/package.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,87 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: package.lisp,v 1.17 2007/10/01 14:13:11 xach Exp $
+
+(cl:defpackage #:vecto
+ (:use #:cl)
+ (:import-from #:zpb-ttf
+ #:open-font-loader
+ #:xmin
+ #:xmax
+ #:ymin
+ #:ymax
+ #:bounding-box)
+ (:export
+ ;; canvas operations
+ #:with-canvas
+ #:clear-canvas
+ #:save-png
+ #:save-png-stream
+ ;; path construction
+ #:move-to
+ #:line-to
+ #:curve-to
+ #:quadratic-to
+ #:close-subpath
+ ;; Clipping
+ #:end-path-no-op
+ #:clip-path
+ #:even-odd-clip-path
+ ;; path construction one-offs
+ #:rectangle
+ #:rounded-rectangle
+ #:centered-ellipse-path
+ #:centered-circle-path
+ #:+kappa+
+ ;; painting
+ #:fill-path
+ #:even-odd-fill
+ #:stroke
+ #:fill-and-stroke
+ #:even-odd-fill-and-stroke
+ ;; graphics state
+ #:with-graphics-state
+ #:set-line-cap
+ #:set-line-join
+ #:set-line-width
+ #:set-dash-pattern
+ #:set-rgba-stroke
+ #:set-rgb-stroke
+ #:set-rgba-fill
+ #:set-rgb-fill
+ ;; graphics state coordinate transforms
+ #:translate
+ #:rotate
+ #:rotate-degrees
+ #:skew
+ #:scale
+ ;; text
+ #:get-font
+ #:set-font
+ #:draw-string
+ #:string-bounding-box
+ #:draw-centered-string))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/paths.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/paths.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/paths.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,137 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: paths.lisp,v 1.2 2007/09/28 18:11:35 xach Exp $
+
+(in-package #:vecto)
+
+;;; Applying a transform function to a path
+
+(defgeneric transformablep (interpolation)
+ (:method (interpolation)
+ nil)
+ (:method ((interpolation paths::bezier))
+ t)
+ (:method ((interpolation (eql :straight-line)))
+ t))
+
+(defun transform-point (point fun)
+ (multiple-value-call #'paths:make-point
+ (funcall fun (paths:point-x point) (paths:point-y point))))
+
+(defgeneric transform-interpolation (interpolation fun)
+ (:method (interpolation fun)
+ (declare (ignore fun))
+ (error "Unhandled interpolation ~A" interpolation))
+ (:method ((interpolation symbol) fun)
+ (declare (ignore fun))
+ interpolation)
+ (:method ((interpolation paths::bezier) fun)
+ (let ((control-points (slot-value interpolation
+ 'paths::control-points)))
+ (dotimes (i (length control-points) interpolation)
+ (setf (aref control-points i)
+ (transform-point (aref control-points i) fun))))))
+
+(defun empty-path-p (path)
+ (zerop (length (paths::path-knots path))))
+
+
+(defun transform-path (path fun)
+ (when (empty-path-p path)
+ (return-from transform-path path))
+ (let ((new-path (paths:create-path (paths::path-type path)))
+ (iterator (paths:path-iterator-segmented path
+ (complement #'transformablep))))
+ (loop
+ (multiple-value-bind (interpolation knot endp)
+ (paths:path-iterator-next iterator)
+ (paths:path-extend new-path
+ (transform-interpolation interpolation fun)
+ (transform-point knot fun))
+ (when endp
+ (return new-path))))))
+
+(defun transform-paths (paths fun)
+ (mapcar (lambda (path) (transform-path path fun)) paths))
+
+
+;;; Applying a dash pattern
+
+(defun apply-dash-phase (dash-vector phase)
+ "cl-vectors and PDF have different semantics for dashes. Given
+a PDF-style dash vector and phase value, return a
+cl-vectors-style dash vector and TOGGLE-P value."
+ (let ((sum (reduce #'+ dash-vector)))
+ (when (or (zerop phase)
+ (= phase sum))
+ ;; Don't bother doing anything for an empty phase
+ (return-from apply-dash-phase (values dash-vector 0))))
+ (let ((index 0)
+ (invertp t))
+ (flet ((next-value ()
+ (cond ((< index (length dash-vector))
+ (setf invertp (not invertp)))
+ (t
+ (setf invertp nil
+ index 0)))
+ (prog1
+ (aref dash-vector index)
+ (incf index)))
+ (join (&rest args)
+ (apply 'concatenate 'vector
+ (mapcar (lambda (thing)
+ (if (vectorp thing)
+ thing
+ (vector thing)))
+ args))))
+ (loop
+ (let ((step (next-value)))
+ (decf phase step)
+ (when (not (plusp phase))
+ (let ((result (join (- phase)
+ (subseq dash-vector index)
+ dash-vector)))
+ (when invertp
+ (setf result (join 0 result)))
+ (return (values result
+ (- (length result) (length dash-vector)))))))))))
+
+
+
+(defun dash-paths (paths dash-vector dash-phase)
+ (if dash-vector
+ (multiple-value-bind (sizes cycle-index)
+ (apply-dash-phase dash-vector dash-phase)
+ (paths:dash-path paths sizes :cycle-index cycle-index))
+ paths))
+
+(defun stroke-paths (paths &key line-width join-style cap-style)
+ (mapcan (lambda (path)
+ (paths:stroke-path path line-width
+ :joint join-style
+ :caps cap-style))
+ paths))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/test.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/test.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/test.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,306 @@
+
+(in-package #:vecto)
+
+(defun test (output-file)
+ (with-canvas (:width 100 :height 100)
+ (set-line-width 5.0)
+ ;; red stroke
+ (set-rgb-stroke 1 0 0)
+ (move-to 10 10)
+ (line-to 90 90)
+ (stroke)
+ ;; green stroke
+ (set-rgb-stroke 0 1 0)
+ (move-to 10 90)
+ (line-to 90 10)
+ (stroke)
+ ;; blue+alpha transform stroke
+ (set-rgba-stroke 0 0 1 0.5)
+ (flet ((elbow (radians)
+ (with-graphics-state
+ (translate 50 50)
+ (rotate radians)
+ (scale 0.25 0.25)
+ (move-to 0 0)
+ (curve-to 0 100
+ 0 100
+ 100 100)
+ (set-line-width 10.0)
+ (stroke))))
+ (let* ((rotations 25)
+ (step (/ (* pi 2) rotations)))
+ (dotimes (i rotations)
+ (elbow (* i step)))))
+ (save-png output-file)))
+
+
+(defun test-rotate (output-file)
+ (with-canvas (:width 100 :height 100)
+ (translate 50 50)
+ (move-to 0 0)
+ (line-to 0 10)
+ (rotate (- (/ pi 4)))
+ (set-line-width 15)
+ (stroke)
+ (save-png output-file)))
+
+(defun test-skew (output-file)
+ (with-canvas (:width 100 :height 100)
+ (move-to 0 0)
+ (line-to 0 75)
+ (skew (- (/ pi 4)) (- (/ pi 4)))
+ (set-line-width 15)
+ (stroke)
+ (save-png output-file)))
+
+(defun hole-test (file)
+ (with-canvas (:width 100 :height 100)
+ (translate 10 10)
+ (scale 50 50)
+ (set-line-width 0.1)
+ (move-to 0 0)
+ (line-to 0 1)
+ (line-to 1 1)
+ (line-to 1 0)
+ (line-to 0 0)
+ (move-to 0.1 0.8)
+ (line-to 0.1 0.1)
+ (line-to 0.8 0.1)
+ (line-to 0.8 0.8)
+ (line-to 0.1 0.8)
+ (fill-path)
+ (save-png file)))
+
+(defun rectangle-test (file)
+ (with-canvas (:width 100 :height 100)
+ (rectangle 10 10 50 50)
+ (fill-path)
+ (save-png file)))
+
+(defun rectangle-fill-test (file)
+ (with-canvas (:width 5 :height 5)
+ (set-rgba-fill 1 0 0 0.5)
+ (rectangle 0 0 5 5)
+ (fill-path)
+ (save-png file)))
+
+(defun circle-test (string file)
+ (with-canvas (:width 250 :height 180)
+ (set-rgb-fill 1 1 1)
+ (set-line-width 1)
+ (translate 10 10)
+ (centered-circle-path 0 0 5)
+ (fill-and-stroke)
+ (translate 15 15)
+ (centered-circle-path 0 0 8)
+ (fill-and-stroke)
+ (translate 20 24)
+ (centered-circle-path 0 0 11)
+ (fill-and-stroke)
+ (centered-ellipse-path 75 60 100 40)
+ (fill-and-stroke)
+ (let ((font (get-font "/home/xach/.fonts/vagron.ttf")))
+ (set-font font 25)
+ (translate -5 50)
+ (let ((bbox (string-bounding-box string font)))
+ (set-line-width 1)
+ (set-rgba-fill 1 0 0 0.5)
+ (rectangle (xmin bbox) (ymin bbox)
+ (- (xmax bbox) (xmin bbox))
+ (- (ymax bbox) (ymin bbox)))
+ (fill-path))
+ (set-rgb-fill 0 1 0)
+ (draw-string string))
+ (save-png file)))
+
+(defun center-test (string file)
+ (with-canvas (:width 200 :height 100)
+ (let ((font (get-font #p"times.ttf")))
+ (set-font font 36)
+ (draw-centered-string 100 25 string)
+ (set-rgba-fill 1 0 0 0.5)
+ (set-rgb-stroke 0 0 0)
+ (centered-circle-path 100 25 5)
+ (stroke)
+ (save-png file))))
+
+(defun twittertext (string size font file)
+ (zpb-ttf:with-font-loader (loader font)
+ (let ((bbox (string-bounding-box string size loader)))
+ (with-canvas (:width (- (ceiling (xmax bbox)) (floor (xmin bbox)))
+ :height (- (ceiling (ymax bbox)) (floor (ymin bbox))))
+ (set-font loader size)
+ (set-rgba-fill 1 1 1 0.1)
+ (clear-canvas)
+ (set-rgb-fill 0 0 0)
+ (translate (- (xmin bbox)) (- (ymin bbox)))
+ (draw-string 0 0 string)
+ (save-png file)))))
+
+(defun arc-to (center-x center-y radius start extent)
+ ;; An arc of extent zero will generate an error at bezarc (divide by zero).
+ ;; This case may be given by two aligned points in a polyline.
+ ;; Better do nothing.
+ (unless (zerop extent)
+ (if (<= (abs extent) (/ pi 2.0))
+ (multiple-value-bind (x1 y1 x2 y2 x3 y3)
+ (bezarc center-x center-y radius start extent)
+ (curve-to x1 y1 x2 y2 x3 y3))
+ (let ((half-extent (/ extent 2.0)))
+ (arc-to center-x center-y radius start half-extent)
+ (arc-to center-x center-y radius (+ start half-extent) half-extent)))))
+
+(defun bezarc (center-x center-y radius start extent)
+ ;; start and extent should be in radians.
+ ;; Returns first-control-point-x first-control-point-y
+ ;; second-control-point-x second-control-point-y
+ ;; end-point-x end-point-y
+ (let* ((end (+ start extent))
+ (s-start (sin start)) (c-start (cos start))
+ (s-end (sin end)) (c-end (cos end))
+ (ang/2 (/ extent 2.0))
+ (kappa (* (/ 4.0 3.0)
+ (/ (- 1 (cos ang/2))
+ (sin ang/2))))
+ (x1 (- c-start (* kappa s-start)))
+ (y1 (+ s-start (* kappa c-start)))
+ (x2 (+ c-end (* kappa s-end)))
+ (y2 (- s-end (* kappa c-end))))
+ (values (+ (* x1 radius) center-x)(+ (* y1 radius) center-y)
+ (+ (* x2 radius) center-x)(+ (* y2 radius) center-y)
+ (+ (* c-end radius) center-x)(+ (* s-end radius) center-y))))
+
+(defun degrees (degrees)
+ (* (/ pi 180) degrees))
+
+(defun arc-test (file)
+ (with-canvas (:width 100 :height 100)
+ (rotate-degrees 15)
+ (translate 0 10)
+ (set-line-width 10)
+ (move-to 75 0)
+ (arc-to 0 0 75 0 (degrees 15))
+ (stroke)
+ (save-png file)))
+
+
+(defun rect-test (file)
+ (with-canvas (:width 5 :height 5)
+ (set-rgba-fill 1 0 0 0.5)
+ (rectangle 0 0 5 5)
+ (fill-path)
+ (save-png file)))
+
+(defun text-test (&key string size font file)
+ (with-canvas (:width 200 :height 200)
+ (let ((loader (get-font font)))
+ (set-rgb-fill 0.8 0.8 0.9)
+ (clear-canvas)
+ (set-font loader size)
+ (set-rgb-fill 0.0 0.0 0.3)
+ (scale 0.5 0.5)
+ (rotate (* 15 (/ pi 180)))
+ (draw-string 10 10 string)
+ (save-png file))))
+
+
+(defun dash-test (file)
+ (with-canvas (:width 200 :height 200)
+ (rectangle 10 10 125 125)
+ (set-rgba-fill 0.3 0.5 0.9 0.5)
+ (set-line-width 4)
+ (set-dash-pattern #(10 10) 5)
+ (fill-and-stroke)
+ (save-png file)))
+
+(defun sign-test (string font file &key
+ (font-size 72)
+ (outer-border 2)
+ (stripe-width 5)
+ (inner-border 2)
+ (corner-radius 10))
+ (zpb-ttf:with-font-loader (loader font)
+ (let* ((bbox (string-bounding-box string font-size loader))
+ (text-height (ceiling (- (ymax bbox) (ymin bbox))))
+ (text-width (ceiling (- (xmax bbox) (xmin bbox))))
+ (stripe/2 (/ stripe-width 2.0))
+ (b1 (+ outer-border stripe/2))
+ (b2 (+ inner-border stripe/2))
+ (x0 0)
+ (x1 (+ x0 b1))
+ (x2 (+ x1 b2))
+ (y0 0)
+ (y1 (+ y0 b1))
+ (y2 (+ y1 b2))
+ (width (truncate (+ text-width (* 2 (+ b1 b2)))))
+ (width1 (- width (* b1 2)))
+ (height (truncate (+ text-height (* 2 (+ b1 b2)))))
+ (height1 (- height (* b1 2))))
+ (with-canvas (:width width :height height)
+ (set-rgb-fill 0.0 0.43 0.33)
+ (set-rgb-stroke 0.95 0.95 0.95)
+ ;; Stripe shadow + stripe
+ (set-line-width stripe-width)
+ (with-graphics-state
+ (translate 2 -2)
+ (set-rgba-stroke 0.0 0.0 0.0 0.3)
+ (rounded-rectangle x1 y1
+ width1 height1
+ corner-radius corner-radius)
+ (fill-and-stroke))
+ (rounded-rectangle x1 y1
+ width1 height1
+ corner-radius corner-radius)
+ (set-dash-pattern #(10 20) 0)
+ (stroke)
+ ;; Text shadow & text
+ (set-font loader font-size)
+ (translate (- (xmin bbox)) (- (ymin bbox)))
+ (with-graphics-state
+ (translate 1 -1)
+ (set-rgba-fill 0.0 0.0 0.0 1.0)
+ (draw-string x2 y2 string))
+ (set-rgb-fill 0.95 0.95 0.95)
+ (draw-string x2 y2 string)
+ (save-png file)))))
+
+
+
+
+
+
+
+
+
+
+(defun fill-test (file)
+ (with-canvas (:width 100 :height 100)
+ (set-rgb-stroke 1 0 0)
+ (set-rgb-fill 0 1 0)
+ (move-to 0 0)
+ (line-to 50 50)
+ (line-to 100 10)
+ (fill-and-stroke)
+ (save-png file)))
+
+(defun circle-test (file)
+ (with-canvas (:width 1000 :height 1000)
+ (scale 5 10)
+ (set-line-width 3)
+ (centered-circle-path 50 50 45)
+ (set-rgb-fill 1 1 0)
+ (fill-and-stroke)
+ (save-png file)))
+
+
+(defun pdf-circle (file)
+ (pdf:with-document ()
+ (pdf:with-page ()
+ (pdf:rotate 15)
+ (pdf:scale 10 5)
+ (pdf:set-line-width 3)
+ (pdf:circle 50 50 45)
+ (pdf:stroke))
+ (pdf:write-document file)))
+
+
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/text.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/text.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/text.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,135 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: text.lisp,v 1.8 2007/09/21 17:39:36 xach Exp $
+
+(in-package #:vecto)
+
+(defclass font ()
+ ((loader
+ :initarg :loader
+ :accessor loader)
+ (transform-matrix
+ :initarg :transform-matrix
+ :accessor transform-matrix)
+ (size
+ :initarg :size
+ :accessor size)))
+
+(defun glyph-path-point (point)
+ (paths:make-point (zpb-ttf:x point)
+ (zpb-ttf:y point)))
+
+(defun glyph-paths (glyph)
+ (let* ((paths '())
+ (path nil))
+ (zpb-ttf:do-contours (contour glyph (nreverse paths))
+ (when (plusp (length contour))
+ (let ((first-point (aref contour 0)))
+ (setf path (paths:create-path :polygon))
+ (push path paths)
+ (paths:path-reset path (glyph-path-point first-point))
+ (zpb-ttf:do-contour-segments* (control end)
+ contour
+ (if control
+ (paths:path-extend path (paths:make-bezier-curve
+ (list (glyph-path-point control)))
+ (glyph-path-point end))
+ (paths:path-extend path (paths:make-straight-line)
+ (glyph-path-point end)))))))))
+
+(defun string-glyphs (string loader)
+ "Return STRING converted to a list of ZPB-TTF glyph objects from FONT."
+ (map 'list (lambda (char) (zpb-ttf:find-glyph char loader)) string))
+
+(defun string-paths (x y string font)
+ "Return the paths of STRING, transformed by the font scale of FONT."
+ (let ((glyphs (string-glyphs string (loader font)))
+ (loader (loader font))
+ (matrix (mult (transform-matrix font) (translation-matrix x y)))
+ (paths '()))
+ (loop for (glyph . rest) on glyphs do
+ (let ((glyph-paths (glyph-paths glyph))
+ (fun (make-transform-function matrix)))
+ (dolist (path glyph-paths)
+ (push (transform-path path fun) paths))
+ (when rest
+ (let* ((next (first rest))
+ (offset (+ (zpb-ttf:advance-width glyph)
+ (zpb-ttf:kerning-offset glyph next loader))))
+ (setf matrix (nmult (translation-matrix offset 0)
+ matrix))))))
+ paths))
+
+(defun nmerge-bounding-boxes (b1 b2)
+ "Create a minimal bounding box that covers both B1 and B2 and
+destructively update B1 with its values. Returns the new box."
+ (setf (xmin b1) (min (xmin b1) (xmin b2))
+ (ymin b1) (min (ymin b1) (ymin b2))
+ (xmax b1) (max (xmax b1) (xmax b2))
+ (ymax b1) (max (ymax b1) (ymax b2)))
+ b1)
+
+(defun advance-bounding-box (bbox offset)
+ "Return a bounding box advanced OFFSET units horizontally."
+ (vector (+ (xmin bbox) offset)
+ (ymin bbox)
+ (+ (xmax bbox) offset)
+ (ymax bbox)))
+
+(defun empty-bounding-box ()
+ (vector most-positive-fixnum most-positive-fixnum
+ most-negative-fixnum most-negative-fixnum))
+
+(defun ntransform-bounding-box (bbox fun)
+ "Return BBOX transformed by FUN; destructively modifies BBOX
+with the new values."
+ (setf (values (xmin bbox) (ymin bbox))
+ (funcall fun (xmin bbox) (ymin bbox))
+ (values (xmax bbox) (ymax bbox))
+ (funcall fun (xmax bbox) (ymax bbox)))
+ bbox)
+
+(defun loader-font-scale (size loader)
+ "Return the horizontal and vertical scaling needed to draw the
+glyphs of LOADER at SIZE units."
+ (float (/ size (zpb-ttf:units/em loader))))
+
+(defun string-bounding-box (string size loader)
+ (let* ((bbox (empty-bounding-box))
+ (scale (loader-font-scale size loader))
+ (fun (make-transform-function (scaling-matrix scale scale)))
+ (glyphs (string-glyphs string loader))
+ (offset 0))
+ (loop for (glyph . rest) on glyphs do
+ (let ((glyph-box (advance-bounding-box (bounding-box glyph) offset)))
+ (setf bbox (nmerge-bounding-boxes bbox glyph-box))
+ (incf offset (zpb-ttf:advance-width glyph))
+ (when rest
+ (let* ((next-glyph (first rest))
+ (kerning (zpb-ttf:kerning-offset glyph next-glyph loader)))
+ (incf offset kerning)))))
+ (ntransform-bounding-box bbox fun)))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/transform-matrix.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/transform-matrix.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/transform-matrix.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,135 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: transform-matrix.lisp,v 1.6 2007/09/28 20:35:08 xach Exp $
+
+(in-package #:vecto)
+
+(defstruct (transform-matrix (:type vector))
+ (x-scale 1.0)
+ (y-skew 0.0)
+ (x-skew 0.0)
+ (y-scale 1.0)
+ (x-offset 0.0)
+ (y-offset 0.0))
+
+(defmacro matrix-bind (lambda-list vector &body body)
+ (when (/= (length lambda-list) 6)
+ (error "Bad lambda-list for MATRIX-BIND: 6 arguments required"))
+ (let ((vec (gensym)))
+ `(let ((,vec ,vector))
+ (let (,@(loop for i from 0 below 6
+ for var in lambda-list
+ collect (list var `(aref ,vec ,i))))
+ , at body))))
+
+(defun matrix (a b c d e f)
+ (vector a b c d e f))
+
+(defun make-transform-function (transform-matrix)
+ (matrix-bind (a b c d e f)
+ transform-matrix
+ (lambda (x y)
+ (values (+ (* a x) (* c y) e)
+ (+ (* b x) (* d y) f)))))
+
+(defun transform-coordinates (x y transform-matrix)
+ (matrix-bind (a b c d e f)
+ transform-matrix
+ (values (+ (* a x) (* c y) e)
+ (+ (* b x) (* d y) f))))
+
+
+;;; Multiplication:
+;;;
+;;; a b 0 a*b*0
+;;; c d 0 x c*d*0
+;;; e f 1 e*f*1
+
+(defun mult (m1 m2)
+ (matrix-bind (a b c d e f)
+ m1
+ (matrix-bind (a* b* c* d* e* f*)
+ m2
+ (matrix (+ (* a a*)
+ (* b c*))
+ (+ (* a b*)
+ (* b d*))
+ (+ (* c a*)
+ (* d c*))
+ (+ (* c b*)
+ (* d d*))
+ (+ (* e a*)
+ (* f c*)
+ e*)
+ (+ (* e b*)
+ (* f d*)
+ f*)))))
+
+(defun nmult (m1 m2)
+ "Destructive MULT; M2 is modified to hold the result of multiplication."
+ (matrix-bind (a b c d e f)
+ m1
+ (matrix-bind (a* b* c* d* e* f*)
+ m2
+ (setf (aref m2 0)
+ (+ (* a a*)
+ (* b c*))
+ (aref m2 1)
+ (+ (* a b*)
+ (* b d*))
+ (aref m2 2)
+ (+ (* c a*)
+ (* d c*))
+ (aref m2 3)
+ (+ (* c b*)
+ (* d d*))
+ (aref m2 4)
+ (+ (* e a*)
+ (* f c*)
+ e*)
+ (aref m2 5)
+ (+ (* e b*)
+ (* f d*)
+ f*))
+ m2)))
+
+(defun translation-matrix (tx ty)
+ (matrix 1 0 0 1 tx ty))
+
+(defun scaling-matrix (sx sy)
+ (matrix sx 0 0 sy 0 0))
+
+(defun rotation-matrix (theta)
+ (let ((cos (cos theta))
+ (sin (sin theta)))
+ (matrix cos sin (- sin) cos 0 0)))
+
+(defun skewing-matrix (alpha beta)
+ (matrix 1 (tan alpha) (tan beta) 1 0 0))
+
+(defun identity-matrix ()
+ (matrix 1.0 0.0 0.0 1.0 0.0 0.0))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/user-drawing.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/user-drawing.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/user-drawing.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,271 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: user-drawing.lisp,v 1.21 2007/10/01 14:12:55 xach Exp $
+
+(in-package #:vecto)
+
+(defvar *graphics-state*)
+(setf (documentation '*graphics-state* 'variable)
+ "The currently active graphics state. Bound for the
+ duration of WITH-GRAPICS-STATE.")
+
+;;; Low-level path construction
+
+(defun %move-to (state x y)
+ (let ((path (paths:create-path :open-polyline)))
+ (push (setf (path state) path) (paths state))
+ (paths:path-reset path (paths:make-point x y))))
+
+(defun %line-to (state x y)
+ (paths:path-extend (path state) (paths:make-straight-line)
+ (paths:make-point x y)))
+
+(defun %curve-to (state cx1 cy1 cx2 cy2 x y)
+ "Draw a cubic Bezier curve from the current point to (x,y)
+through two control points."
+ (let ((control-point-1 (paths:make-point cx1 cy1))
+ (control-point-2 (paths:make-point cx2 cy2))
+ (end-point (paths:make-point x y)))
+ (paths:path-extend (path state)
+ (paths:make-bezier-curve (list control-point-1
+ control-point-2))
+ end-point)))
+
+(defun %quadratic-to (state cx cy x y)
+ "Draw a quadratic Bezier curve from the current point to (x,y)
+through one control point."
+ (paths:path-extend (path state)
+ (paths:make-bezier-curve (list (paths:make-point cx cy)))
+ (paths:make-point x y)))
+
+(defun %close-subpath (state)
+ (setf (paths::path-type (path state)) :closed-polyline))
+
+;;; Clipping path
+
+(defun %end-path-no-op (state)
+ (after-painting state))
+
+(defun %clip-path (state)
+ (call-after-painting state
+ (make-clipping-path-function state :nonzero-winding)))
+
+(defun %even-odd-clip-path (state)
+ (call-after-painting state
+ (make-clipping-path-function state :even-odd)))
+
+;;; Text
+
+(defun %get-font (state file)
+ (find-font-loader state file))
+
+(defun %set-font (state loader size)
+ (let* ((scale (loader-font-scale size loader))
+ (matrix (scaling-matrix scale scale)))
+ (setf (font state)
+ (make-instance 'font
+ :loader loader
+ :transform-matrix matrix
+ :size size))))
+
+(defun %draw-string (state x y string)
+ (let ((font (font state)))
+ (unless font
+ (error "No font currently set"))
+ (let ((paths (string-paths x y string font)))
+ (draw-paths/state paths state))))
+
+(defun %draw-centered-string (state x y string)
+ (let* ((font (font state))
+ (bbox (string-bounding-box string (size font) (loader font)))
+ (width/2 (/ (- (xmax bbox) (xmin bbox)) 2.0)))
+ (draw-string (- x width/2) y string)))
+
+
+;;; Low-level transforms
+
+(defun %translate (state tx ty)
+ (apply-matrix state (translation-matrix tx ty)))
+
+(defun %scale (state sx sy)
+ (apply-matrix state (scaling-matrix sx sy)))
+
+(defun %skew (state x y)
+ (apply-matrix state (skewing-matrix x y)))
+
+(defun %rotate (state radians)
+ (apply-matrix state (rotation-matrix radians)))
+
+;;; User-level commands
+
+(defun move-to (x y)
+ (%move-to *graphics-state* x y))
+
+(defun line-to (x y)
+ (%line-to *graphics-state* x y))
+
+(defun curve-to (cx1 cy1 cx2 cy2 x y)
+ (%curve-to *graphics-state* cx1 cy1 cx2 cy2 x y))
+
+(defun quadratic-to (cx cy x y)
+ (%quadratic-to *graphics-state* cx cy x y))
+
+(defun close-subpath ()
+ (%close-subpath *graphics-state*))
+
+(defun end-path-no-op ()
+ (%end-path-no-op *graphics-state*)
+ (clear-paths *graphics-state*))
+
+(defun clip-path ()
+ (%clip-path *graphics-state*))
+
+(defun even-odd-clip-path ()
+ (%even-odd-clip-path *graphics-state*))
+
+(defun get-font (file)
+ (%get-font *graphics-state* file))
+
+(defun set-font (font size)
+ (%set-font *graphics-state* font size))
+
+(defun draw-string (x y string)
+ (%draw-string *graphics-state* x y string))
+
+(defun draw-centered-string (x y string)
+ (%draw-centered-string *graphics-state* x y string))
+
+(defun set-dash-pattern (vector phase)
+ (if (zerop (length vector))
+ (setf (dash-vector *graphics-state*) nil
+ (dash-phase *graphics-state*) nil)
+ (setf (dash-vector *graphics-state*) vector
+ (dash-phase *graphics-state*) phase)))
+
+(defun set-line-cap (style)
+ (assert (member style '(:butt :square :round)))
+ (setf (cap-style *graphics-state*) style))
+
+(defun set-line-join (style)
+ (assert (member style '(:bevel :miter :round)))
+ (setf (join-style *graphics-state*) (if (eql style :bevel) :none style)))
+
+(defun set-line-width (width)
+ (setf (line-width *graphics-state*) width))
+
+(defun set-rgba-color (color r g b a)
+ (setf (red color) (clamp-range 0.0 r 1.0)
+ (green color) (clamp-range 0.0 g 1.0)
+ (blue color) (clamp-range 0.0 b 1.0)
+ (alpha color) (clamp-range 0.0 a 1.0))
+ color)
+
+(defun set-rgb-color (color r g b)
+ (setf (red color) (clamp-range 0.0 r 1.0)
+ (green color) (clamp-range 0.0 g 1.0)
+ (blue color) (clamp-range 0.0 b 1.0)
+ (alpha color) 1.0)
+ color)
+
+(defun set-rgb-stroke (r g b)
+ (set-rgb-color (stroke-color *graphics-state*) r g b))
+
+(defun set-rgba-stroke (r g b a)
+ (set-rgba-color (stroke-color *graphics-state*) r g b a))
+
+(defun set-rgb-fill (r g b)
+ (set-rgb-color (fill-color *graphics-state*) r g b))
+
+(defun set-rgba-fill (r g b a)
+ (set-rgba-color (fill-color *graphics-state*) r g b a))
+
+(defun stroke ()
+ (draw-stroked-paths *graphics-state*)
+ (clear-paths *graphics-state*))
+
+(defun fill-path ()
+ (draw-filled-paths *graphics-state*)
+ (after-painting *graphics-state*)
+ (clear-paths *graphics-state*))
+
+(defun even-odd-fill ()
+ (draw-even-odd-filled-paths *graphics-state*)
+ (after-painting *graphics-state*)
+ (clear-paths *graphics-state*))
+
+(defun fill-and-stroke ()
+ (draw-filled-paths *graphics-state*)
+ (draw-stroked-paths *graphics-state*)
+ (clear-paths *graphics-state*))
+
+(defun even-odd-fill-and-stroke ()
+ (draw-even-odd-filled-paths *graphics-state*)
+ (draw-stroked-paths *graphics-state*)
+ (after-painting *graphics-state*)
+ (clear-paths *graphics-state*))
+
+
+(defun clear-canvas ()
+ (let ((color (fill-color *graphics-state*)))
+ (fill-image (image-data *graphics-state*)
+ (red color)
+ (green color)
+ (blue color)
+ (alpha color))))
+
+(defun translate (x y)
+ (%translate *graphics-state* x y))
+
+(defun scale (x y)
+ (%scale *graphics-state* x y))
+
+(defun skew (x y)
+ (%skew *graphics-state* x y))
+
+(defun rotate (radians)
+ (%rotate *graphics-state* radians))
+
+(defun rotate-degrees (degrees)
+ (%rotate *graphics-state* (* (/ pi 180) degrees)))
+
+(defun save-png (file)
+ (png:write-png (image *graphics-state*) file))
+
+(defun save-png-stream (stream)
+ (png:write-png-stream (image *graphics-state*) stream))
+
+(defmacro with-canvas ((&key width height) &body body)
+ `(let ((*graphics-state* (make-instance 'graphics-state)))
+ (state-image *graphics-state* ,width ,height)
+ (unwind-protect
+ (progn
+ , at body)
+ (clear-state *graphics-state*))))
+
+(defmacro with-graphics-state (&body body)
+ `(let ((*graphics-state* (copy *graphics-state*)))
+ , at body))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/user-shortcuts.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/user-shortcuts.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/user-shortcuts.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,107 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: user-shortcuts.lisp,v 1.6 2007/09/21 01:39:07 xach Exp $
+
+(in-package #:vecto)
+
+(defconstant +kappa+ (* 4.d0 (/ (- (sqrt 2.0d0) 1.0d0) 3.0d0))
+ "From http://www.whizkidtech.redprince.net/bezier/circle/, the top
+Google hit for my vague recollection of this constant.")
+
+(defun centered-ellipse-path (x y rx ry)
+ "Add an elliptical subpath centered at X,Y with x radius RX and
+y radius RY."
+ (let ((cx (* rx +kappa+))
+ (cy (* ry +kappa+)))
+ ;; upper left
+ (move-to (- x rx) y)
+ (curve-to (- x rx) (+ y cy)
+ (- x cx) (+ y ry)
+ x (+ y ry))
+ ;; upper right
+ (curve-to (+ x cx) (+ y ry)
+ (+ x rx) (+ y cy)
+ (+ x rx) y)
+ ;; lower right
+ (curve-to (+ x rx) (- y cy)
+ (+ x cx) (- y ry)
+ x (- y ry))
+ (curve-to (- x cx) (- y ry)
+ (- x rx) (- y cy)
+ (- x rx) y)
+ (close-subpath)))
+
+(defun centered-circle-path (x y radius)
+ "Add a circular subpath centered at X,Y with radius RADIUS."
+ (centered-ellipse-path x y radius radius))
+
+(defun rectangle (x y width height)
+ (move-to x y)
+ (line-to (+ x width) y)
+ (line-to (+ x width) (+ y height))
+ (line-to x (+ y height))
+ (close-subpath))
+
+(defun rounded-rectangle (x y width height rx ry)
+ ;; FIXME: This should go counter-clockwise, like RECTANGLE!
+ (let* ((x3 (+ x width))
+ (x2 (- x3 rx))
+ (x1 (+ x rx))
+ (x0 x)
+ (xkappa (* rx +kappa+))
+ (y3 (+ y height))
+ (y2 (- y3 ry))
+ (y1 (+ y ry))
+ (y0 y)
+ (ykappa (* ry +kappa+)))
+ ;; west
+ (move-to x0 y1)
+ (line-to x0 y2)
+ ;; northwest
+ (curve-to x0 (+ y2 ykappa)
+ (- x1 xkappa) y3
+ x1 y3)
+ ;; north
+ (line-to x2 y3)
+ ;; northeast
+ (curve-to (+ x2 xkappa) y3
+ x3 (+ y2 ykappa)
+ x3 y2)
+ ;; east
+ (line-to x3 y1)
+ ;; southeast
+ (curve-to x3 (- y1 ykappa)
+ (+ x2 xkappa) y0
+ x2 y0)
+ ;; south
+ (line-to x1 y0)
+ ;; southwest
+ (curve-to (- x1 xkappa) y0
+ x0 (+ y0 ykappa)
+ x0 y1)
+ ;; fin
+ (close-subpath)))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/utils.lisp
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/utils.lisp 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/utils.lisp 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,40 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: utils.lisp,v 1.3 2007/09/20 17:41:21 xach Exp $
+
+(in-package #:vecto)
+
+(defun clamp-range (low value high)
+ (min (max value low) high))
+
+(defun float-octet (float)
+ "Convert a float in the range 0.0 - 1.0 to an octet."
+ (values (round (* float 255.0))))
+
+(defun octet-float (octet)
+ "Convert an octet to a float."
+ (/ octet 255.0))
Added: branches/trunk-reorg/thirdparty/vecto-1.0.2/vecto.asd
===================================================================
--- branches/trunk-reorg/thirdparty/vecto-1.0.2/vecto.asd 2007-10-05 06:02:12 UTC (rev 2218)
+++ branches/trunk-reorg/thirdparty/vecto-1.0.2/vecto.asd 2007-10-05 06:02:33 UTC (rev 2219)
@@ -0,0 +1,75 @@
+;;; Copyright (c) 2007 Zachary Beane, 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.
+;;;
+;;; $Id: vecto.asd,v 1.10 2007/10/01 16:24:50 xach Exp $
+
+(asdf:defsystem #:vecto
+ :depends-on (#:cl-vectors
+ (:version #:salza-png "1.0.1")
+ #:zpb-ttf)
+ :version "1.0.2"
+ :components ((:file "package")
+ (:file "utils"
+ :depends-on ("package"))
+ (:file "copy"
+ :depends-on ("package"))
+ (:file "color"
+ :depends-on ("package"
+ "copy"))
+ (:file "paths"
+ :depends-on ("package"))
+ (:file "transform-matrix"
+ :depends-on ("package"))
+ (:file "clipping-paths"
+ :depends-on ("package"
+ "copy"))
+ (:file "graphics-state"
+ :depends-on ("package"
+ "color"
+ "clipping-paths"
+ "transform-matrix"
+ "copy"))
+ (:file "drawing"
+ :depends-on ("package"
+ "utils"
+ "paths"
+ "graphics-state"
+ "transform-matrix"))
+ (:file "text"
+ :depends-on ("package"
+ "transform-matrix"
+ "graphics-state"
+ "drawing"))
+ (:file "user-drawing"
+ :depends-on ("package"
+ "utils"
+ "clipping-paths"
+ "graphics-state"
+ "transform-matrix"
+ "text"))
+ (:file "user-shortcuts"
+ :depends-on ("user-drawing"))))
+
More information about the Bknr-cvs
mailing list