October 2007 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] r2223 - branches/trunk-reorg/thirdparty/asdf
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 17:23:22 -0400 (Sat, 06 Oct 2007) New Revision: 2223 Modified: branches/trunk-reorg/thirdparty/asdf/asdf.lisp Log: Commit patch to make error message for dangling link clear, thanks to antifuchs. Modified: branches/trunk-reorg/thirdparty/asdf/asdf.lisp =================================================================== --- branches/trunk-reorg/thirdparty/asdf/asdf.lisp 2007-10-06 08:49:40 UTC (rev 2222) +++ branches/trunk-reorg/thirdparty/asdf/asdf.lisp 2007-10-06 21:23:22 UTC (rev 2223) @@ -384,6 +384,7 @@ (in-memory (gethash name *defined-systems*)) (on-disk (system-definition-pathname name))) (when (and on-disk + (probe-file on-disk) (or (not in-memory) (< (car in-memory) (file-write-date on-disk)))) (let ((package (make-temporary-package)))

1 0

[bknr-cvs] r2222 - branches/trunk-reorg/projects/eboy
by bknr＠bknr.net 06 Oct '07

06 Oct '07

Author: hhubner Date: 2007-10-06 04:49:40 -0400 (Sat, 06 Oct 2007) New Revision: 2222 Removed: branches/trunk-reorg/projects/eboy/src.old/ Log: remove cruft

1 0

[bknr-cvs] r2221 - in branches/trunk-reorg/projects/scrabble: src website/de
by bknr＠bknr.net 05 Oct '07

05 Oct '07

Author: hhubner Date: 2007-10-05 03:31:39 -0400 (Fri, 05 Oct 2007) New Revision: 2221 Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp branches/trunk-reorg/projects/scrabble/src/package.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.lisp branches/trunk-reorg/projects/scrabble/website/de/double-letter.png branches/trunk-reorg/projects/scrabble/website/de/double-word.png branches/trunk-reorg/projects/scrabble/website/de/scrabble.css branches/trunk-reorg/projects/scrabble/website/de/triple-letter.png branches/trunk-reorg/projects/scrabble/website/de/triple-word.png Log: checkpoint Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-10-05 07:31:39 UTC (rev 2221) @@ -4,16 +4,32 @@ (defparameter *special-tile-texts* (make-hash-table)) (setf (gethash :de *special-tile-texts*) - '(:double-letter "DOPPELTER\nBUCHSTABEN\nWERT" - :double-word "DOPPELTER\nWORT\nWERT" - :triple-letter "DREIFACHER\nBUCHSTABEN\nWERT" - :triple-word "DREIFACHER\nWORT\nWERT")) + '(:double-letter "DOPPELTER +BUCHSTABEN +WERT" + :double-word "DOPPELTER +WORT +WERT" + :triple-letter "DREIFACHER +BUCHSTABEN +WERT" + :triple-word "DREIFACHER +WORT +WERT")) (setf (gethash :en *special-tile-texts*) - '(:double-letter "DOUBLE\nLETTER\nSCORE" - :double-word "DOUBLE\nWORD\nSCORE" - :triple-letter "TRIPLE\nLETTER\nSCORE" - :triple-word "TRIPLE\nWORD\nSCORE")) + '(:double-letter "DOUBLE +LETTER +SCORE" + :double-word "DOUBLE +WORD +SCORE" + :triple-letter "TRIPLE +LETTER +SCORE" + :triple-word "TRIPLE +WORD +SCORE")) (defparameter *special-tile-colors* '(:double-letter (0.53 0.8 0.94) @@ -70,7 +86,11 @@ (cond (text (set-font regular-font 6) - (draw-centered-string 26 3 text)) + (let* ((lines (cl-ppcre:split "\\n" text)) + (position (+ 20 (* 6 (/ 2 (length lines)))))) + (dolist (line lines) + (draw-centered-string 20 position line) + (decf position 6)))) (star )) (save-png (make-pathname :name (string-downcase (symbol-name name)) :type "png"))))) @@ -80,7 +100,8 @@ (make-special-tile tile-name (getf *special-tile-colors* tile-name) :text (getf (gethash language *special-tile-texts*) tile-name))) - (make-special-tile :standard (getf *special-tile-colors* :standard) :star t)) + (make-special-tile :standard (getf *special-tile-colors* :standard) :star nil) + (make-special-tile :standard (getf *special-tile-colors* :double-word) :star t)) (defun make-tile-set (directory language) Modified: branches/trunk-reorg/projects/scrabble/src/package.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/src/package.lisp 2007-10-05 07:31:39 UTC (rev 2221) @@ -1,6 +1,6 @@ (defpackage :scrabble - (:use :cl :alexandria :anaphora) + (:use :cl :alexandria :anaphora :bknr.datastore) (:export "*BOARD-SCORING*" "*TILE-SETS*" "FIELD-TYPE")) Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-05 07:31:39 UTC (rev 2221) @@ -8,7 +8,7 @@ (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) - (:triple-word nil nil :double-letter nil nil nil :triple-word nil nil nil :double-letter nil nil :triple-word) + (:triple-word nil nil :double-letter nil nil nil :double-word nil nil nil :double-letter nil nil :triple-word) (nil nil :double-letter nil nil nil :double-letter nil :double-letter nil nil nil :double-letter nil nil) (nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil nil nil :triple-letter nil) (nil nil nil nil :double-word nil nil nil nil nil :double-word nil nil nil nil) @@ -79,8 +79,9 @@ (or (< (x-of a) (x-of b)) (< (y-of a) (y-of b)))) -(defclass board () - ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil)))) +(defclass board (store-object) + ((placed-tiles :accessor placed-tiles-of :initform (make-array '(15 15) :initial-element nil))) + (:metaclass persistent-class)) (defmethod print-object ((board board) stream) (print-unreadable-object (board stream :type t :identity t) @@ -99,9 +100,10 @@ (defmethod put-letter ((board board) tile x y) (setf (aref (placed-tiles-of board) x y) tile)) -(defclass tile () +(defclass tile (store-object) ((char :reader char-of :initarg :char) - (value :reader value-of :initarg :value))) + (value :reader value-of :initarg :value)) + (:metaclass persistent-class)) (defmethod print-object ((tile tile) stream) (print-unreadable-object (tile stream :type t :identity nil) @@ -109,10 +111,11 @@ (format stream "~A (~A)" char value)))) (defun make-tile (char value) - (make-instance 'tile :char char :value value)) + (make-object 'tile :char char :value value)) -(defclass tile-bag () - ((tiles :initarg :tiles :accessor tiles-of))) +(defclass tile-bag (store-object) + ((tiles :initarg :tiles :accessor tiles-of)) + (:metaclass persistent-class)) (defmethod remaining-tile-count ((tile-bag tile-bag)) (fill-pointer (tiles-of tile-bag))) Modified: branches/trunk-reorg/projects/scrabble/website/de/double-letter.png =================================================================== (Binary files differ) Modified: branches/trunk-reorg/projects/scrabble/website/de/double-word.png =================================================================== (Binary files differ) Modified: branches/trunk-reorg/projects/scrabble/website/de/scrabble.css =================================================================== --- branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-05 06:04:47 UTC (rev 2220) +++ branches/trunk-reorg/projects/scrabble/website/de/scrabble.css 2007-10-05 07:31:39 UTC (rev 2221) @@ -114,7 +114,7 @@ #playfield #field-7-4 { background-image: url(standard.png); left: 308; top: 176 } #playfield #field-7-5 { background-image: url(standard.png); left: 308; top: 220 } #playfield #field-7-6 { background-image: url(standard.png); left: 308; top: 264 } -#playfield #field-7-7 { background-image: url(triple-word.png); left: 308; top: 308 } +#playfield #field-7-7 { background-image: url(double-word.png); left: 308; top: 308 } #playfield #field-7-8 { background-image: url(standard.png); left: 308; top: 352 } #playfield #field-7-9 { background-image: url(standard.png); left: 308; top: 396 } #playfield #field-7-10 { background-image: url(standard.png); left: 308; top: 440 } Modified: branches/trunk-reorg/projects/scrabble/website/de/triple-letter.png =================================================================== (Binary files differ) Modified: branches/trunk-reorg/projects/scrabble/website/de/triple-word.png =================================================================== (Binary files differ)

1 0

[bknr-cvs] r2220 - in branches/trunk-reorg/thirdparty: . salza-png-1.0.1
by bknr＠bknr.net 05 Oct '07

05 Oct '07

Author: hhubner Date: 2007-10-05 02:04:47 -0400 (Fri, 05 Oct 2007) New Revision: 2220 Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/ branches/trunk-reorg/thirdparty/salza-png-1.0.1/README branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd Removed: branches/trunk-reorg/thirdparty/salza-png-1.0/ Log: update salza-png Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/README =================================================================== --- branches/trunk-reorg/thirdparty/salza-png-1.0.1/README 2007-10-05 06:02:33 UTC (rev 2219) +++ branches/trunk-reorg/thirdparty/salza-png-1.0.1/README 2007-10-05 06:04:47 UTC (rev 2220) @@ -0,0 +1,35 @@ +The salza-png software is a standalone version of the PNG writer from +the salza examples directory. Documentation, such as it is, is at the +start of png.lisp. + +For questions or comments, please contact me, Zach Beane, at +xach(a)xach.com. + +salza-png is offered under the following license: + +;;; +;;; 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/salza-png-1.0.1/png.lisp =================================================================== --- branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp 2007-10-05 06:02:33 UTC (rev 2219) +++ branches/trunk-reorg/thirdparty/salza-png-1.0.1/png.lisp 2007-10-05 06:04:47 UTC (rev 2220) @@ -0,0 +1,203 @@ +;;; +;;; png.lisp +;;; +;;; Created: 2005-03-14 by Zach Beane <xach(a)xach.com> +;;; +;;; An example use of the salza ZLIB interface functions. +;;; +;;; (setq png (make-instance 'png +;;; :color-type :truecolor +;;; :height 10 +;;; :width 10 +;;; :image-data <300 bytes of image data>)) +;;; +;;; (write-png png "example.png") +;;; +;;; +;;; 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: png.lisp,v 1.2 2007/10/01 13:37:47 xach Exp $ + +(defpackage #:png + (:use #:cl #:salza #:salza-deflate) + (:export #:png + #:write-png + #:write-png-stream)) + +(in-package :png) + + +;;; Chunks + +(defclass chunk () + ((buffer :initarg :buffer :reader buffer) + (pos :initform 4 :accessor pos))) + +(defun chunk-write-byte (byte chunk) + "Save one byte to CHUNK." + (setf (aref (buffer chunk) (pos chunk)) byte) + (incf (pos chunk))) + +(defun chunk-write-uint32 (integer chunk) + "Save INTEGER to CHUNK as four bytes." + (dotimes (i 4) + (setf (aref (buffer chunk) (pos chunk)) + (logand #xFF (ash integer (+ -24 (* i 8))))) + (incf (pos chunk)))) + +(defun make-chunk (a b c d size) + "Make a chunk that uses A, B, C, and D as the signature bytes, with +data size SIZE." + (let ((buffer (make-array (+ size 4) :element-type '(unsigned-byte 8)))) + (setf (aref buffer 0) a + (aref buffer 1) b + (aref buffer 2) c + (aref buffer 3) d) + (make-instance 'chunk + :buffer buffer))) + +(defun write-uint32 (integer stream) + (dotimes (i 4) + (write-byte (logand #xFF (ash integer (+ -24 (* i 8)))) stream))) + +(defun write-chunk (chunk stream) + (write-uint32 (- (pos chunk) 4) stream) + (write-sequence (buffer chunk) stream :end (pos chunk)) + (write-sequence (crc32-sequence (buffer chunk) :end (pos chunk)) stream)) + + +;;; PNGs + +(defclass png () + ((width :initarg :width :reader width) + (height :initarg :height :reader height) + (color-type :initform :truecolor :initarg :color-type :reader color-type) + (bpp :initform 8 :initarg :bpp :reader bpp) + (image-data :initarg :image-data :reader image-data))) + +(defmethod initialize-instance :after ((png png) &rest args) + (declare (ignore args)) + (assert (= (length (image-data png)) + (* (height png) (rowstride png))))) + +(defgeneric write-png (png pathname &key if-exists)) +(defgeneric write-ihdr (png stream)) +(defgeneric ihdr-color-type (png)) +(defgeneric write-idat (png stream)) +(defgeneric write-iend (png stream)) +(defgeneric write-png-header (png stream)) +(defgeneric scanline-offset (png scanline)) +(defgeneric rowstride (png)) +(defgeneric samples/pixel (png)) + +(defmethod samples/pixel (png) + (ecase (color-type png) + (:grayscale 1) + (:truecolor 3) + (:indexed-color 1) + (:grayscale-alpha 2) + (:truecolor-alpha 4))) + + +(defmethod rowstride (png) + (* (width png) (samples/pixel png))) + +(defmethod scanline-offset (png scanline) + (* scanline (rowstride png))) + +(defmethod write-png-header (png stream) + (let ((header (make-array 8 + :element-type '(unsigned-byte 8) + :initial-contents '(137 80 78 71 13 10 26 10)))) + (write-sequence header stream))) + +(defvar *color-types* + '((:grayscale . 0) + (:truecolor . 2) + (:indexed-color . 3) + (:grayscale-alpha . 4) + (:truecolor-alpha . 6))) + +(defmethod ihdr-color-type (png) + (cdr (assoc (color-type png) *color-types*))) + +(defmethod write-ihdr (png stream) + (let ((chunk (make-chunk 73 72 68 82 13))) + (chunk-write-uint32 (width png) chunk) + (chunk-write-uint32 (height png) chunk) + (chunk-write-byte (bpp png) chunk) + (chunk-write-byte (ihdr-color-type png) chunk) + ;; compression method + (chunk-write-byte 0 chunk) + ;; filtering + (chunk-write-byte 0 chunk) + ;; interlace + (chunk-write-byte 0 chunk) + (write-chunk chunk stream))) + +(defmethod write-idat (png stream) + (let* ((chunk (make-chunk 73 68 65 84 16384)) + (filter-type (make-array 1 + :element-type '(unsigned-byte 8) + :initial-element 0))) + (flet ((write-full-chunk (zlib-stream) + (setf (pos chunk) (zlib-stream-position zlib-stream)) + (write-chunk chunk stream) + (fill (buffer chunk) 0 :start 4) + (setf (zlib-stream-position zlib-stream) 4))) + (let ((zlib-stream (make-zlib-stream (buffer chunk) + :start 4 + :callback #'write-full-chunk))) + (dotimes (i (height png)) + (let* ((start-offset (scanline-offset png i)) + (end-offset (+ start-offset (rowstride png)))) + (zlib-write-sequence filter-type zlib-stream) + (zlib-write-sequence (image-data png) zlib-stream + :start start-offset + :end end-offset))) + (finish-zlib-stream zlib-stream))))) + + + +(defmethod write-iend (png stream) + (let ((chunk (make-chunk 73 69 78 68 0))) + (write-chunk chunk stream))) + +(defmethod write-png-stream (png stream) + (write-png-header png stream) + (write-ihdr png stream) + (write-idat png stream) + (write-iend png stream)) + +(defmethod write-png (png file &key (if-exists :supersede)) + (with-open-file (stream file + :direction :output + :if-exists if-exists + :if-does-not-exist :create + :element-type '(unsigned-byte 8)) + (write-png-stream png stream) + (truename file))) Added: branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd =================================================================== --- branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd 2007-10-05 06:02:33 UTC (rev 2219) +++ branches/trunk-reorg/thirdparty/salza-png-1.0.1/salza-png.asd 2007-10-05 06:04:47 UTC (rev 2220) @@ -0,0 +1,35 @@ +;;; +;;; salza-png.asd +;;; +;;; 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: salza-png.asd,v 1.2 2007/10/01 13:37:29 xach Exp $ + +(asdf:defsystem #:salza-png + :depends-on (#:salza) + :version "1.0.1" + :components ((:file "png")))

1 0

[bknr-cvs] r2219 - in branches/trunk-reorg/thirdparty: . vecto-1.0.2 vecto-1.0.2/doc
by bknr＠bknr.net 05 Oct '07

05 Oct '07

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> + +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. + +Vecto is used by <a href="http://wigflip.com/easystreet/">Easystreet</a>. + +The canonical location for Vecto +is <a href="http://www.xach.com/lisp/vecto/">http://www.xach.com/lisp/vecto/</a>. + +Download shortcut: + +<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> + +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. + +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> + +The easiest way to install Vecto and all its dependencies is +with <a href="http://www.cliki.net/asdf-install">ASDF-Install</a>. + +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. + +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. + +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. + +All measurements are in pixels. + +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> + +Other limitations: + +<ul> +<li> No output formats other than 8-bit, truecolor-alpha PNGs +<li> No access to underlying pixel data +</ul> + +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> + +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> + +The following symbols are exported from the <tt>VECTO</tt> package. + +<a name='sect-canvases'><h4>Canvases</h4></a> + +<a name='with-canvas'>[Macro]</a> +with-canvas (<tt>&key</tt> width height) +<tt>&body</tt> body + +<blockquote> +Evaluates body 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> + + +<a name='clear-canvas'>[Function]</a> +clear-canvas => | + +<blockquote> +Completely fills the canvas with the current fill color. Any marks on +the canvas are cleared. +</blockquote> + + +<a name='save-png'>[Function]</a> +save-png file => truename + +<blockquote> +Writes the contents of the canvas as the PNG file, and returns +the truename of file. +</blockquote> + + +<a name='save-png-stream'>[Function]</a> +save-png-stream stream => | + +<blockquote> +Writes the contents of the canvas as a PNG to stream, which +must accept <tt>(unsigned-byte 8)</tt> data. +</blockquote> + + +<a name='sect-graphics-state'><h4>Graphics State</h4></a> + +The graphics state stores several parameters used for graphic +operations. + +<a name='with-graphics-state'>[Macro]</a> +with-graphics-state <tt>&body</tt> body + +<blockquote> +Evaluates the forms of body with a copy of the current graphics +state. Any modifications to the state are undone at the end of the +form. +</blockquote> + + +<a name='set-rgba-fill'>[Functions]</a> +set-rgba-fill r g b alpha => | +set-rgb-fill r g b => | + +<blockquote> +Sets the fill color. r, g, b, and alpha +should be in the range of 0.0 to 1.0. + +<tt>set-rgb-fill</tt> is the same as <tt>set-rgba-fill</tt> with an +implicit alpha value of 1.0. + +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> + +<a name='set-rgba-stroke'>[Functions]</a> +set-rgba-stroke r g b alpha => | +set-rgb-stroke r g b => | + +<blockquote> +Sets the stroke color. r, g, b, and alpha +should be in the range of 0.0 to 1.0. + +<tt>set-rgb-stroke</tt> is the same as <tt>set-rgba-stroke</tt> +with an implicit alpha value of 1.0. + +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> + + +<a name='set-line-cap'>[Function]</a> +set-line-cap style => | + +<blockquote> +Sets the line cap style to style, which must be one +of <tt>:BUTT</tt>, <tt>:SQUARE</tt>, or <tt>:ROUND</tt>. The initial +value is <tt>:BUTT</tt>. + +<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> + + +<a name='set-line-join'>[Function]</a> +set-line-join style => | + +<blockquote> +Sets the line join style to style, which must be one +of <tt>:MITER</tt>, <tt>:BEVEL</tt>, or <tt>:ROUND</tt>. The initial +value is <tt>:MITER</tt>. + +<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> + + +<a name='set-line-width'>[Function]</a> +set-line-width width => | + +<blockquote> +Sets the line width for strokes to width. +</blockquote> + + + +<a name='set-dash-pattern'>[Function]</a> +set-dash-pattern dash-vector phase => | + +<blockquote> +Sets the dash pattern according to dash-vector and phase. + +dash-vector should be a vector of numbers denoting on and +off patterns for a stroke. An empty dash-vector is the same as +having no dash pattern at all. + +phase is how far along the dash pattern to proceed before +applying the pattern to the current stroke. + + +<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> + + +<a name='translate'>[Function]</a> +translate x y => | + +<blockquote> +Offsets the coordinate system by x units horizontally +and y units vertically. +</blockquote> + + +<a name='rotate'>[Function]</a> +rotate radians => | + +<blockquote> +Rotates the coordinate system by radians. +</blockquote> + + +<a name='scale'>[Function]</a> +scale sx sy => | + +<blockquote> +Scales the coordinate system by sx horizontally +and sy vertically. +</blockquote> + + +<a name='skew'>[Function]</a> +skew ax ay => | + +<blockquote> +Skews the X axis of the coordinate system by ax radians and the +Y axis by ay radians. +</blockquote> + + +<a name='clip-path'>[Function]</a> +clip-path => | + +<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>. + +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. + +The outline of the clipping path is defined with the nonzero +winding rule, as with <a href='#fill-path'><tt>FILL-PATH</tt></a>. + +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>. + + +<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> + + +<a name='even-odd-clip-path'>[Function]</a> +even-odd-clip-path => | + +<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> + +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. + +<a name='move-to'>[Function]</a> +move-to x y => | + +<blockquote> +Starts a new subpath at (x,y). <tt>move-to</tt> must be the +first step of constructing a subpath. +</blockquote> + + +<a name='line-to'>[Function]</a> +line-to x y => | + +<blockquote> +Appends a straight line ending at (x,y) to the +current subpath. +</blockquote> + + +<a name='curve-to'>[Function]</a> +curve-to +cx1 cy1 +cx2 cy2 +x y => | + +<blockquote> +Appends a +cubic <a href="http://en.wikipedia.org/wiki/B%C3%A9zier_curve">Bézier +curve</a> ending at (x,y) and with control +points (cx1,cy1) and (cx2,cy2) to the current +subpath. +</blockquote> + + +<a name='quadratic-to'>[Function]</a> +quadratic-to +cx cy +x y => | + +<blockquote> +Appends a quadratic Bézier curve ending at (x,y) +and with the control point (cx,cy) to the current +subpath. +</blockquote> + + +<a name='close-subpath'>[Function]</a> +close-subpath => | + +<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. + +Subpaths with start and end points that coincidentally overlap are +not the same as closed subpaths. The distinction is important when +stroking: + +<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> + +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> + + +<a name='rectangle'>[Function]</a> +rectangle x y width height + +<blockquote> +Creates a rectangular subpath with the given width +and height that has its lower-left corner at +(x,y). 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> + +<a name='centered-ellipse-path'>[Function]</a> +centered-ellipse-path +x y +rx ry + +<blockquote> +Adds a closed subpath that outlines an ellipse centered at +(x,y) with an X radius of rx and a Y radius +of ry. +</blockquote> + +<a name='centered-circle-path'>[Function]</a> +centered-circle-path x y radius => | + +<blockquote> +Adds a closed subpath that outlines a circle centered at +(x,y) with a radius of radius. It is effectively +the same as: + +<pre> +(centered-ellipse-path x y radius radius) +</pre> +</blockquote> + + + +<a name='sect-painting'><h4>Painting</h4></a> + +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. + + +<a name='fill-path'>[Function]</a> +fill-path => | + +<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> + + +<a name='even-odd-fill'>[Function]</a> +even-odd-fill => | + +<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> + + +<a name='stroke'>[Function]</a> +stroke => | + +<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> + + +<a name='fill-and-stroke'>[Function]</a> +fill-and-stroke => | + +<blockquote> +Fills the current path, then strokes it. +</blockquote> + + +<a name='even-odd-fill-and-stroke'>[Function]</a> +even-odd-fill-and-stroke => | + +<blockquote> +Fills the current path using the even/odd rule, then strokes it. +</blockquote> + + +<a name='end-path-no-op'>[Function]</a> +end-path-no-op => | + +<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> + +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>. + +<a name='get-font'>[Function]</a> +get-font font-file => font-loader + +<blockquote> +Creates and returns a ZPB-TTF font loader object +from font-file. 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> + + +<a name='set-font'>[Function]</a> +set-font font-loader size => | + +<blockquote> +Sets the active font to the font associated +with font-loader, scaled to size units per line. + +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> + + +<a name='draw-string'>[Function]</a> +draw-string x y string => | + +<blockquote> +Draws string on the canvas with the active font. The glyph +origin of the first character in the string is positioned at x +and the baseline of the string is positioned at y. The text is +filled with the current <a href='#set-rgba-fill'>fill color</a>. + +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> + + +<a name='draw-centered-string'>[Function]</a> +draw-centered-string x y string => | + +<blockquote> +Draws string on the canvas with the active font. The horizontal +center of the string is positioned at x and the baseline of the +string is positioned at y. +</blockquote> + + +<a name='string-bounding-box'>[Function]</a> +string-bounding-box string size loader +=> #(xmin ymin xmax ymax) + +<blockquote> +Calculates the bounding box of string for font-loader +at size. +</blockquote> + + +<a name='sect-miscellaneous'><h3>Miscellaneous</h3></a> + +<a name='const-kappa'>[Constant]</a> ++kappa+ => 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> + +If you have any questions, comments, bug reports, or other feedback +regarding Vecto, please email <a href="mailto:xach@xach.com">Zach +Beane</a>. + +<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)))) + ,@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 + ,@body) + (clear-state *graphics-state*)))) + +(defmacro with-graphics-state (&body body) + `(let ((*graphics-state* (copy *graphics-state*))) + ,@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")))) +

1 0

[bknr-cvs] r2218 - branches/trunk-reorg/thirdparty
by bknr＠bknr.net 05 Oct '07

05 Oct '07

Author: hhubner Date: 2007-10-05 02:02:12 -0400 (Fri, 05 Oct 2007) New Revision: 2218 Removed: branches/trunk-reorg/thirdparty/cl-interpol/ branches/trunk-reorg/thirdparty/vecto-1.0.1/ Log: Update vecto

1 0

[bknr-cvs] r2217 - branches/trunk-reorg/projects/scrabble/src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 18:51:42 -0400 (Thu, 04 Oct 2007) New Revision: 2217 Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp branches/trunk-reorg/projects/scrabble/src/scrabble.lisp branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp Log: Add english tile set. Modified: branches/trunk-reorg/projects/scrabble/src/make-letters.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-10-04 22:33:26 UTC (rev 2216) +++ branches/trunk-reorg/projects/scrabble/src/make-letters.lisp 2007-10-04 22:51:42 UTC (rev 2217) @@ -9,6 +9,12 @@ :triple-letter "DREIFACHER\nBUCHSTABEN\nWERT" :triple-word "DREIFACHER\nWORT\nWERT")) +(setf (gethash :en *special-tile-texts*) + '(:double-letter "DOUBLE\nLETTER\nSCORE" + :double-word "DOUBLE\nWORD\nSCORE" + :triple-letter "TRIPLE\nLETTER\nSCORE" + :triple-word "TRIPLE\nWORD\nSCORE")) + (defparameter *special-tile-colors* '(:double-letter (0.53 0.8 0.94) :double-word (0.97 0.67 0.6) Modified: branches/trunk-reorg/projects/scrabble/src/scrabble.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-04 22:33:26 UTC (rev 2216) +++ branches/trunk-reorg/projects/scrabble/src/scrabble.lisp 2007-10-04 22:51:42 UTC (rev 2217) @@ -24,36 +24,17 @@ (defparameter *tile-sets* (make-hash-table)) (setf (gethash :de *tile-sets*) - '((#\A 1 5) - (#\B 3 2) - (#\C 4 2) - (#\D 1 4) - (#\E 1 15) - (#\F 4 2) - (#\G 2 3) - (#\H 2 4) - (#\I 1 6) - (#\J 6 1) - (#\K 4 2) - (#\L 2 3) - (#\M 3 4) - (#\N 1 9) - (#\O 2 3) - (#\P 4 1) - (#\Q 10 1) - (#\R 1 6) - (#\S 1 7) - (#\T 1 6) - (#\U 1 6) - (#\V 6 1) - (#\W 3 1) - (#\X 8 1) - (#\Y 10 1) - (#\Z 3 1) - #-cmu (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1) - #-cmu (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1) - #-cmu (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1) + '((#\A 1 5) (#\B 3 2) (#\C 4 2) (#\D 1 4) (#\E 1 15) (#\F 4 2) (#\G 2 3) (#\H 2 4) (#\I 1 6) + (#\J 6 1) (#\K 4 2) (#\L 2 3) (#\M 3 4) (#\N 1 9) (#\O 2 3) (#\P 4 1) (#\Q 10 1) (#\R 1 6) + (#\S 1 7) (#\T 1 6) (#\U 1 6) (#\V 6 1) (#\W 3 1) (#\X 8 1) (#\Y 10 1) (#\Z 3 1) + (#\LATIN_CAPITAL_LETTER_A_WITH_DIAERESIS 6 1) + (#\LATIN_CAPITAL_LETTER_O_WITH_DIAERESIS 8 1) + (#\LATIN_CAPITAL_LETTER_U_WITH_DIAERESIS 6 1) (nil 0 2))) +(setf (gethash :en *tile-sets*) + '((#\A 1 9) (#\B 3 2) (#\C 3 2) (#\D 2 4) (#\E 1 12) (#\F 4 2) (#\G 2 3) (#\H 4 2) (#\I 1 9) + (#\J 8 1) (#\K 5 1) (#\L 1 4) (#\M 3 2) (#\N 1 6) (#\O 1 8) (#\P 3 2) (#\Q 10 1) (#\R 1 6) + (#\S 1 4) (#\T 1 6) (#\U 1 4) (#\V 4 2) (#\W 4 2) (#\X 8 1) (#\Y 4 2) (#\Z 10 1) (nil 0 2))) (define-condition invalid-move (simple-error) () Modified: branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp =================================================================== --- branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-10-04 22:33:26 UTC (rev 2216) +++ branches/trunk-reorg/projects/scrabble/src/start-webserver.lisp 2007-10-04 22:51:42 UTC (rev 2217) @@ -7,9 +7,9 @@ (defparameter *mochikit-directory* (make-pathname :name nil :type nil :version nil - :defaults (merge-pathnames #p"../../../../thirdparty/MochiKit/MochiKit/"))) + :defaults (merge-pathnames #p"../../../thirdparty/MochiKit/MochiKit/"))) -(when (and (boundp '*server*) *server) +(when (and (boundp '*server*) *server*) (stop-server *server*)) (setq *dispatch-table*

1 0

[bknr-cvs] r2216 - in branches/trunk-reorg/bknr/datastore: . doc experimental src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 18:33:26 -0400 (Thu, 04 Oct 2007) New Revision: 2216 Added: branches/trunk-reorg/bknr/datastore/doc/README-orig branches/trunk-reorg/bknr/datastore/experimental/fswrap/ Removed: branches/trunk-reorg/bknr/datastore/README branches/trunk-reorg/bknr/datastore/src/fswrap/ Log: move around cruft Deleted: branches/trunk-reorg/bknr/datastore/README =================================================================== --- branches/trunk-reorg/bknr/datastore/README 2007-10-04 22:31:22 UTC (rev 2215) +++ branches/trunk-reorg/bknr/datastore/README 2007-10-04 22:33:26 UTC (rev 2216) @@ -1,48 +0,0 @@ -BKNR CODENAME: SPUTNIK - -Hans Huebner, David Lichteblau, Manuel Odendahl - -1. Introduction - -BKNR is a software launch platform for LISP satellites. You could -replace ``launch platform'' with framework and ``satellites'' with -``applications'', but that would be too many buzzwords. - -BKNR is made of facilities that are not very useful on their own, but -they can be used to quickly build shiny and elegant LISP -satellites. For example, a very important component of BKNR is its -datastore, which brings persistence to CLOS in a very simple way. By -adding a few declarations to your class definitions, you can have -persistent objects. You can also add XML import/export to your objects -in a similar way. I think this is the single most attractive feature -of BKNR: no more mapping from a relational database to LISP objects, -no more XML parsing and XML generation, you just write plain -application code. - -2. Installation - -BKNR has been developed with CMUCL 19a under FreeBSD, and has been -tested with Allegro Common Lisp 6.2 under Windows and Freebsd. Install -the BKNR sourcecode and the thirdparty sourcecode. - -Then configure the pathnames in bknr/init.lisp, and load -bknr/init.lisp. Afterwards, you can use ASDF to load the BKNR -facilities. - -To load the BKNR indices facility: -(asdf:oos 'asdf:load-op :bknr-indices) - -To load the BKNR datastore facility: -(asdf:oos 'asdf:load-op :bknr-indices) - -To load the BKNR impex facility: -(asdf:oos 'asdf:load-op :bknr-indices) - -To load the BKNR framework: -(asdf:oos 'asdf:load-op :bknr) - -3. Further documentation - -You can read the BKNR manual in bknr/doc/ . You can also browse the -sourcecode for the tutorials in bknr/src/indices/tutorial.lisp, -bknr/src/data/tutorial.lisp and bknr/src/xml-impex/tutorial.lisp. Copied: branches/trunk-reorg/bknr/datastore/doc/README-orig (from rev 2212, branches/trunk-reorg/bknr/datastore/README) Copied: branches/trunk-reorg/bknr/datastore/experimental/fswrap (from rev 2212, branches/trunk-reorg/bknr/datastore/src/fswrap)

1 0

[bknr-cvs] r2215 - branches/trunk-reorg/bknr/datastore
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 18:31:22 -0400 (Thu, 04 Oct 2007) New Revision: 2215 Removed: branches/trunk-reorg/bknr/datastore/init.lisp Log: cruft Deleted: branches/trunk-reorg/bknr/datastore/init.lisp =================================================================== --- branches/trunk-reorg/bknr/datastore/init.lisp 2007-10-04 22:26:55 UTC (rev 2214) +++ branches/trunk-reorg/bknr/datastore/init.lisp 2007-10-04 22:31:22 UTC (rev 2215) @@ -1,108 +0,0 @@ -(in-package :cl-user) - -;;;;;;;;;;;;; -;; Tweak this -(eval-when (:execute :compile-toplevel :load-toplevel) - #+allegro - (setf (logical-pathname-translations "bknr") - `(("**;*.*.*" "bknr/**/")) - (logical-pathname-translations "bknr-thirdparty") - `(("**;*.*.*" "thirdparty/**/")) - (logical-pathname-translations "eboy") - `(("**;*.*.*" "eboy/**/"))) - - #+cmu - (setf (logical-pathname-translations "bknr") - `(("**;*.*.*" "home:bknr-sputnik/bknr/**/")) - (logical-pathname-translations "bknr-thirdparty") - `(("**;*.*.*" "home:bknr-sputnik/thirdparty/**/")) - (logical-pathname-translations "eboy") - `(("**;*.*.*" "home:bknr-sputnik/eboy/**/"))) - - #+sbcl - (setf (logical-pathname-translations "bknr") - `(("**;*.*.*" - ,(merge-pathnames - (make-pathname :directory '(:relative "bknr-svn" "bknr" :wild-inferiors) - :name :wild - :type :wild - :version :wild) - (user-homedir-pathname)))) - (logical-pathname-translations "bknr-thirdparty") - `(("**;*.*.*" - ,(merge-pathnames - (make-pathname :directory '(:relative "bknr-svn" "thirdparty" :wild-inferiors) - :name :wild - :type :wild - :version :wild) - (user-homedir-pathname)))) - (logical-pathname-translations "eboy") - `(("**;*.*.*" - ,(merge-pathnames - (make-pathname :directory '(:relative "bknr-svn" "eboy" :wild-inferiors) - :name :wild - :type :wild - :version :wild) - (user-homedir-pathname)))))) - -(eval-when (:execute :compile-toplevel :load-toplevel) - #-sbcl - (load #p"bknr-thirdparty:asdf;asdf") - #+sbcl - (require :asdf)) - -(pushnew (translate-logical-pathname #p"bknr:src;") asdf:*central-registry* :test #'equal) -(pushnew (translate-logical-pathname #p"eboy:src;") asdf:*central-registry* :test #'equal) - -(defparameter *patch-directory* "bknr:patches;") - -(defun load-patches (&optional (directory *patch-directory*)) - (dolist (file (directory (merge-pathnames directory #p"patch-*.lisp"))) - (warn "; Loading patch from file ~A~%" file) - (load file))) - -(defun fix-dpd () - #+cmu - ;; Die Sache mit dem aktuellen Verzeichnis hat CMUCL noch immer nicht im - ;; Griff. Nachbessern! - (setf *default-pathname-defaults* - (pathname - (concatenate 'string - (nth-value 1 (unix:unix-current-directory)) - "/")))) - -(defun make-wild-pathname (type directory) - (merge-pathnames (make-pathname :type type - :name :wild - :directory '(:relative :wild-inferiors)) - directory)) - -(defun setup-registry () - (mapc #'(lambda (asd-pathname) - (pushnew (make-pathname :directory (pathname-directory asd-pathname)) - asdf:*central-registry* - :test #'equal)) - (append (directory #p"bknr-thirdparty:**;*.asd") - (directory #p"bknr:**;*.asd")))) - -(defun clean-registry (&optional (dirs asdf:*central-registry*)) - (let ((files (mapcan #'directory - (mapcan #'(lambda (dir) - (when (pathnamep dir) - (list (make-wild-pathname "fas" dir) - (make-wild-pathname "lib" dir) - (make-wild-pathname "x86f" dir) - (make-wild-pathname "fasl" dir)))) - dirs)))) - (dolist (file files) - (when (probe-file file) - (format t "Deleting binary file ~S~%" file) - (delete-file file))))) - -#+cmu -(load-patches) - -(setup-registry) -(fix-dpd) - -(pushnew :cl-gd-gif *features*)

1 0

[bknr-cvs] r2214 - in branches/trunk-reorg/bknr/datastore: . src
by bknr＠bknr.net 04 Oct '07

04 Oct '07

Author: hhubner Date: 2007-10-04 18:26:55 -0400 (Thu, 04 Oct 2007) New Revision: 2214 Added: branches/trunk-reorg/bknr/datastore/src/xml/ Removed: branches/trunk-reorg/bknr/datastore/xml/ Log: move xml compatibility stuff under src Copied: branches/trunk-reorg/bknr/datastore/src/xml (from rev 2212, branches/trunk-reorg/bknr/datastore/xml)

1 0