bknr-cvs January 2008

bknr-cvs@common-lisp.net

3 participants
103 discussions

[bknr-cvs] r2434 - in branches/trunk-reorg/bknr/web/src: . rss web
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 07:53:36 2008 New Revision: 2434 Modified: branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/rss/rss.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp branches/trunk-reorg/bknr/web/src/web/templates.lisp Log: Fix some RSS related problems. Extend RSS API so that encoded content can be generated. Begin removing all code that depends on :rune-is-integer. Raymond Toy says that he'll add Unicode support to CMUCL, and I'm sick of the string-related kludging. Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Thu Jan 31 07:53:36 2008 @@ -65,6 +65,7 @@ #:rss-item-enclosure #:rss-item-guid #:rss-item-source + #:rss-item-encoded-content ;; textinput #:rss-textinput Modified: branches/trunk-reorg/bknr/web/src/rss/rss.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/rss/rss.lisp (original) +++ branches/trunk-reorg/bknr/web/src/rss/rss.lisp Thu Jan 31 07:53:36 2008 @@ -74,6 +74,7 @@ (with-xml-output (make-character-stream-sink stream) (with-element "rss" (attribute "version" "2.0") + (attribute* "xmlns" "content" "http://purl.org/rss/1.0/modules/content/") (with-element "channel" (dolist (slot '(title link description)) (render-mandatory-element channel slot)) @@ -145,7 +146,10 @@ (with-element "description" (cdata it))) (with-element "pubDate" - (text (format-date-time (rss-item-pub-date item) :mail-style t))))) + (text (format-date-time (rss-item-pub-date item) :mail-style t))) + (aif (rss-item-encoded-content item) + (with-element* ("content" "encoded" ) + (cdata it))))) ;; All items present on an RSS stream can implement the access ;; methods below. @@ -169,4 +173,8 @@ (defmethod rss-item-enclosure (item)) (defmethod rss-item-guid (item)) (defmethod rss-item-source (item)) - +(defgeneric rss-item-encoded-content (item) + (:documentation "Return the content for ITEM in encoded (usually HTML) form as string.") + (:method (item) + (declare (ignore item)) + nil)) Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Jan 31 07:53:36 2008 @@ -427,9 +427,7 @@ (defmethod handle :around ((handler xml-handler)) (with-http-response (:content-type "text/xml") (with-http-body () - (let ((sink (#-rune-is-integer cxml:make-character-stream-sink - #+rune-is-integer cxml:make-character-stream-sink/utf8 - *html-stream* :canonical t)) + (let ((sink (cxml:make-character-stream-sink *html-stream* :canonical t)) (style-path (or (query-param "style") (xml-handler-style-path handler)))) (cxml:with-xml-output sink Modified: branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/rss-handlers.lisp Thu Jan 31 07:53:36 2008 @@ -11,5 +11,4 @@ (defmethod handle-object ((handler rss-handler) (channel bknr.rss:rss-channel)) (with-http-response (:content-type "text/xml; charset=UTF-8") (with-http-body () - (html (:princ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>") - (bknr.rss:rss-channel-xml channel *html-stream*))))) + (bknr.rss:rss-channel-xml channel *html-stream*)))) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Thu Jan 31 07:53:36 2008 @@ -103,8 +103,7 @@ (defun emit-template (expander stream node env) (let* ((*template-expander* expander) (*template-env* env) - (sink (#-rune-is-integer cxml:make-character-stream-sink #+rune-is-integer cxml:make-character-stream-sink/utf8 - stream :canonical nil)) + (sink (cxml:make-character-stream-sink stream :canonical nil)) (*html-sink* (cxml:make-recoder sink #'cxml::utf8-string-to-rod))) (if (node-attribute node "suppress-xml-headers") (emit-template-node node)

1 0

[bknr-cvs] r2433 - branches/trunk-reorg/xhtmlgen
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 07:33:43 2008 New Revision: 2433 Modified: branches/trunk-reorg/xhtmlgen/package.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: Change xhtmlgen again so that it does not depend on Alexandria just for the sake of WITH-GENSYMS. Modified: branches/trunk-reorg/xhtmlgen/package.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp (original) +++ branches/trunk-reorg/xhtmlgen/package.lisp Thu Jan 31 07:33:43 2008 @@ -1,7 +1,7 @@ (in-package :cl-user) (defpackage :xhtml-generator - (:use :common-lisp :alexandria) + (:use :common-lisp) (:export #:html #:html-stream #:*html-sink* Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Thu Jan 31 07:33:43 2008 @@ -46,7 +46,7 @@ (defmacro html (&rest forms &environment env) ;; just emit html to the current stream - (with-gensyms (body) + (let ((body (gensym))) `(labels ((,body () ,(process-html-forms forms env))) (if (boundp '*html-sink*)

1 0

[bknr-cvs] r2432 - branches/trunk-reorg/xhtmlgen
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 07:32:06 2008 New Revision: 2432 Modified: branches/trunk-reorg/xhtmlgen/package.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: Fix xhtmlgen so that it properly flushes the output ystream when it is done. Modified: branches/trunk-reorg/xhtmlgen/package.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/package.lisp (original) +++ branches/trunk-reorg/xhtmlgen/package.lisp Thu Jan 31 07:32:06 2008 @@ -1,7 +1,7 @@ (in-package :cl-user) (defpackage :xhtml-generator - (:use :common-lisp) + (:use :common-lisp :alexandria) (:export #:html #:html-stream #:*html-sink* Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Thu Jan 31 07:32:06 2008 @@ -24,7 +24,6 @@ (in-package :xhtml-generator) -;; fixme (defvar *html-sink*) ;; html generation @@ -45,48 +44,21 @@ (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes ) -;; support for strings encoded in latin-1 or utf-8 on non-unicode lisps - -#-rune-is-character -(defun make-sink-for-utf8-strings (stream) - (cxml:make-recoder (cxml:make-character-stream-sink/utf8 stream :canonical nil :indentation 3) - #'cxml::utf8-string-to-rod)) - -#-rune-is-character -(defun make-sink-for-latin1-strings (stream) - (cxml:make-recoder (cxml:make-character-stream-sink/utf8 stream :canonical nil :indentation 3) - #'cxml::string-rod)) - -#-rune-is-character -(defvar *make-sink-for-internal-strings-fn* #'make-sink-for-utf8-strings) - -#-rune-is-character -(defun make-sink-for-internal-strings (stream) - (funcall *make-sink-for-internal-strings-fn* stream)) - -#-rune-is-character -(defun set-string-encoding (encoding) - (ecase encoding - (:latin-1 (setf *make-sink-for-internal-strings-fn* #'make-sink-for-latin1-strings)) - (:utf-8 (setf *make-sink-for-internal-strings-fn* #'make-sink-for-utf8-strings)))) - (defmacro html (&rest forms &environment env) ;; just emit html to the current stream - `(let ((*html-sink* (if (boundp '*html-sink*) - *html-sink* - #+rune-is-character - (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3) - #-rune-is-character - (make-sink-for-internal-strings *standard-output*)))) - ,(process-html-forms forms env))) + (with-gensyms (body) + `(labels ((,body () + ,(process-html-forms forms env))) + (if (boundp '*html-sink*) + (,body) + (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3))) + (,body) + (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* - #+rune-is-character - (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3) - #-rune-is-character - (make-sink-for-internal-strings ,stream))) - ,(process-html-forms forms env))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3))) + ,(process-html-forms forms env) + (sax:end-document *html-sink*))) (defun get-process (form) (let ((ent (gethash form *html-process-table*)))

1 0

[bknr-cvs] r2431 - branches/trunk-reorg/projects/quickhoney/src
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:51:58 2008 New Revision: 2431 Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp branches/trunk-reorg/projects/quickhoney/src/init.lisp Log: Produce warning message for invalid query. Change path in library loading hack. Modified: branches/trunk-reorg/projects/quickhoney/src/handlers.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/handlers.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/handlers.lisp Thu Jan 31 05:51:58 2008 @@ -122,7 +122,12 @@ (let ((preproduced-buttons (buttons-for-category category subcategory))) (if preproduced-buttons (format nil "/image/~D" (store-object-id (random-elt preproduced-buttons))) - (format nil "/image/~D/cutout-button,~(~A~),~A" (store-object-id (random-elt (subseq (images-sorted-by-time category subcategory) 0 10))) subcategory background-color)))) + (let ((images (images-sorted-by-time category subcategory))) + (if images + (format nil "/image/~D/cutout-button,~(~A~),~A" + (store-object-id (random-elt (subseq images 0 10))) + subcategory background-color) + (warn "No images for ~A ~A found"category subcategory)))))) (defun find-button-images (query-elements) (loop for (category-string subcategories-string) on query-elements by #'cddr Modified: branches/trunk-reorg/projects/quickhoney/src/init.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/init.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/init.lisp Thu Jan 31 05:51:58 2008 @@ -4,7 +4,10 @@ (setq cxml::*default-catalog* '("/home/hans/share/xml/catalog")) ;; XXX hack hack hack (mapcar #'cl-gd::load-foreign-library - '("/usr/lib/libcrypto.so" "/usr/lib/libssl.so" "/usr/local/lib/libgd.so" "/home/hans/bknr-svn/thirdparty/cl-gd/cl-gd-glue.so")) + '("/usr/lib/libcrypto.so" + "/usr/lib/libssl.so" + "/usr/local/lib/libgd.so" + "/home/hans/bknr-svn/thirdparty/cl-gd-0.5.6/cl-gd-glue.so")) (when *store* (close-store)) (make-instance 'store

1 0

[bknr-cvs] r2430 - in branches/trunk-reorg/bknr: datastore/src/utils modules/feed modules/mail modules/stats modules/text web/src web/src/images web/src/web
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:50:52 2008 New Revision: 2430 Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp branches/trunk-reorg/bknr/modules/text/article-tags.lisp branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp branches/trunk-reorg/bknr/web/src/images/image-tags.lisp branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/packages.lisp branches/trunk-reorg/bknr/web/src/web/handlers.lisp branches/trunk-reorg/bknr/web/src/web/menu.lisp branches/trunk-reorg/bknr/web/src/web/sessions.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/bknr/web/src/web/templates.lisp branches/trunk-reorg/bknr/web/src/web/web-macros.lisp branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Log: Replace (request-uri) by (script-name), as the former may contain query parameters. Modified: branches/trunk-reorg/bknr/datastore/src/utils/package.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/package.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/package.lisp Thu Jan 31 05:50:52 2008 @@ -54,8 +54,6 @@ #:group-on #:find-all #:genlist - #+no-alexandria - #:rotate #:nrotate #:shift-until #:count-multiple @@ -67,8 +65,6 @@ #:incf-hash ;; randomize - #+no-alexandria - #:random-elt #:random-elts #:randomize-list Modified: branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp (original) +++ branches/trunk-reorg/bknr/datastore/src/utils/utils.lisp Thu Jan 31 05:50:52 2008 @@ -351,11 +351,6 @@ (setf l (randomize l))))) l) -#+no-alexandria -(defun random-elt (choices) - (when choices - (elt choices (random (length choices))))) - (defun random-elts (choices num) (subseq (randomize-list choices) 0 num)) Modified: branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/feed/feed-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -45,7 +45,7 @@ object) (let* ((title (object-list-handler-title handler object)) (feeds (object-list-handler-get-objects handler object)) - (rss-feed (merge-feeds title (render-uri (request-uri) nil) + (rss-feed (merge-feeds title (render-uri (script-name) nil) title (remove nil (mapcar #'feed-rss-feed feeds)))) (grouped-items (rss-feed-group-items rss-feed))) grouped-items)) @@ -135,7 +135,7 @@ (defmethod create-object-rss-feed ((handler rss-feed-list-handler) keyword) (let ((feeds (object-list-handler-get-objects handler keyword))) (merge-feeds (object-list-handler-title handler keyword) - (render-uri (request-uri) nil) + (render-uri (script-name) nil) (object-list-handler-title handler keyword) (remove nil (mapcar #'feed-rss-feed feeds))))) Modified: branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/mail/mailinglist-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -172,7 +172,7 @@ ((:table :border "1") (:tr (:td "Name") (:td (:princ-safe (mailinglist-name mailinglist)))) (:tr (:td "Email") (:td (:princ-safe (mailinglist-email mailinglist))))) - ((:form :action (request-uri) :method "post") + ((:form :action (script-name) :method "post") (:table (:tr (:td "Subscribe email") (:td (text-field "email")))) (submit-button "subscribe" "subscribe")))) Modified: branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp (original) +++ branches/trunk-reorg/bknr/modules/stats/stats-handler.lisp Thu Jan 31 05:50:52 2008 @@ -41,7 +41,7 @@ (html (:table (:tr (:td "Date") (:td (:princ-safe (format-date-time time)))) (:tr (:td "URL") (:td (cmslink - (render-uri (merge-uris url (request-uri)) nil) + (render-uri (merge-uris url (script-name)) nil) (:princ-safe url)))) (:tr ((:td :colspan "2") (:princ-safe error))) (:tr ((:td :colspan "2") (:pre (:princ-safe backtrace)))))))))) Modified: branches/trunk-reorg/bknr/modules/text/article-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/article-tags.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/article-tags.lisp Thu Jan 31 05:50:52 2008 @@ -221,7 +221,7 @@ (if (= i page) (html (:princ-safe i)) (html ((:a :href (format nil "~A?page=~A" - (request-uri) i)) + (script-name) i)) (:princ-safe i)))) " ")) (loop for result in results Modified: branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp (original) +++ branches/trunk-reorg/bknr/modules/text/billboard-handlers.lisp Thu Jan 31 05:50:52 2008 @@ -22,7 +22,7 @@ (let ((may-edit (admin-p (bknr-session-user)))) (with-bknr-page (:title "billboards") (html - ((:form :method "post" :action (request-uri)) + ((:form :method "post" :action (script-name)) ((:table :width "640") (:tr (:th "name") (:th "new" :br "msgs") Modified: branches/trunk-reorg/bknr/web/src/images/image-tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/image-tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/image-tags.lisp Thu Jan 31 05:50:52 2008 @@ -13,7 +13,7 @@ (html (:princ " ") (if (= i page) (html (:princ-safe i)) - (html (cmslink (format nil "~A?page=~A" (request-uri) i) (:princ-safe i)))) + (html (cmslink (format nil "~A?page=~A" (script-name) i) (:princ-safe i)))) (:princ " "))))))) (define-bknr-tag banner (&key link keyword width height) Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Thu Jan 31 05:50:52 2008 @@ -133,8 +133,6 @@ (with-default-image (input-image) (let ((colors (loop for (old new) on color-mappings by #'cddr collect (cons (parse-color old) (parse-color new))))) - #+nil - (format t "color: ~A~%" colors) (do-pixels (input-image) (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) (when (cdr new-color) Modified: branches/trunk-reorg/bknr/web/src/packages.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/packages.lisp (original) +++ branches/trunk-reorg/bknr/web/src/packages.lisp Thu Jan 31 05:50:52 2008 @@ -401,6 +401,7 @@ :cl-gd :cl-interpol :cl-ppcre + :alexandria :hunchentoot :puri :xhtml-generator @@ -411,6 +412,7 @@ :bknr.utils :bknr.user) (:shadowing-import-from :cl-interpol #:quote-meta-chars) + (:shadowing-import-from :bknr.indices #:array-index) (:export #:imageproc #:define-imageproc-handler #:image-handler ; plain images only Modified: branches/trunk-reorg/bknr/web/src/web/handlers.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/handlers.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/handlers.lisp Thu Jan 31 05:50:52 2008 @@ -196,7 +196,7 @@ (defgeneric page-handler-url (page-handler)) (defmethod handler-path ((handler page-handler)) - (subseq (request-uri) + (subseq (script-name) (length (page-handler-prefix handler)))) (defmethod decoded-handler-path ((handler page-handler)) @@ -233,7 +233,7 @@ (if (not (authorized-p handler)) (progn (setf (session-value :login-redirect-uri) - (redirect-uri (request-uri))) + (redirect-uri (script-name))) (redirect (website-make-path *website* "login"))) (if *catch-errors-p* (handle handler) @@ -320,13 +320,18 @@ ((destination :initarg :destination :reader page-handler-destination))) +(defmethod request-pathname ((handler directory-handler)) + (or (aux-request-value 'request-pathname) + (setf (aux-request-value 'request-pathname) + (subseq (script-name) (1+ (length (page-handler-prefix handler))))))) + (defmethod handler-matches ((handler directory-handler)) (and (call-next-method) - (probe-file (merge-pathnames (script-name) + (probe-file (merge-pathnames (request-pathname handler) (page-handler-destination handler))))) (defmethod handle ((handler directory-handler)) - (handle-static-file (merge-pathnames (subseq (script-name) (1+ (length (page-handler-prefix handler)))) + (handle-static-file (merge-pathnames (request-pathname handler) (page-handler-destination handler)))) (defclass file-handler (page-handler) Modified: branches/trunk-reorg/bknr/web/src/web/menu.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/menu.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/menu.lisp Thu Jan 31 05:50:52 2008 @@ -50,7 +50,7 @@ (when title (html ((:div :class "title") (:princ-safe title)))) (dolist (item (menu-items menu)) - (let ((item-is-active (in-subtree (request-uri) (item-url item)))) + (let ((item-is-active (in-subtree (script-name) (item-url item)))) (with-slots (url title active-image inactive-image) item (let ((link-url (format nil "~A~A" (website-base-href *website*) url))) (cond Modified: branches/trunk-reorg/bknr/web/src/web/sessions.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/sessions.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/sessions.lisp Thu Jan 31 05:50:52 2008 @@ -18,13 +18,13 @@ (slot-value (bknr-session) 'user)) (defun do-log-request () - (format *debug-io* "Log: ~A~%" (request-uri)) + (format *debug-io* "Log: ~A~%" (script-name)) (return-from do-log-request) #+(or) (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) - (url (request-uri)) + (url (script-name)) (referer (header-in :referer)) (user-agent (header-in :user-agent)) (time (get-universal-time))) @@ -46,7 +46,7 @@ (let* ((session (bknr-session)) (user (bknr-session-user session)) (host (bknr-session-host session)) - (url (request-uri)) + (url (script-name)) (referer (header-in :referer)) (time (get-universal-time))) (make-event 'web-server-error-event Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Thu Jan 31 05:50:52 2008 @@ -198,7 +198,7 @@ (define-bknr-tag navi-button (&key url text) (html (:princ " ")) - (if (equal (request-uri) + (if (equal (script-name) url) (html (:princ-safe text)) (html (cmslink url (:princ-safe text)))) @@ -255,7 +255,7 @@ (define-bknr-tag site-menu () (destructuring-bind (empty first-level &optional second-level &rest rest) - (split "/" (request-uri)) + (split "/" (script-name)) (declare (ignore empty rest)) (html ((:div :id "navcontainer") (let ((*standard-output* *html-stream*)) Modified: branches/trunk-reorg/bknr/web/src/web/templates.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/templates.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/templates.lisp Thu Jan 31 05:50:52 2008 @@ -294,7 +294,7 @@ (defmethod handler-matches ((handler template-handler)) (handler-case - (find-template-pathname handler (request-uri)) + (find-template-pathname handler (script-name)) (template-not-found (c) (declare (ignore c)) nil))) @@ -304,7 +304,7 @@ ;; Erst body ausfuehren... (let ((body (expand-template handler - (subseq (request-uri) + (subseq (script-name) (length (page-handler-prefix handler))) :env (initial-template-environment handler)))) ;; ... und wenn keine Fehler entdeckt wurden, rausschreiben Modified: branches/trunk-reorg/bknr/web/src/web/web-macros.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-macros.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-macros.lisp Thu Jan 31 05:50:52 2008 @@ -59,7 +59,7 @@ (defmacro with-image-from-uri ((image-variable prefix) &rest body) `(multiple-value-bind (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (request-uri)) + (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (script-name)) (unless match (http-error +http-bad-request+ "bad request - missing image path or loid")) (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) Modified: branches/trunk-reorg/bknr/web/src/web/web-utils.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/web-utils.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/web-utils.lisp Thu Jan 31 05:50:52 2008 @@ -108,7 +108,7 @@ (mapcar (lambda (param) (cons (car param) (iconv:iconv request-charset "utf-8" (cdr param)))) - (remove "" (append (form-urlencoded-to-query (uri-query (request-uri))) + (remove "" (append (form-urlencoded-to-query (uri-query (script-name))) (aux-request-value 'bknr-parsed-body-parameters)) :key #'cdr :test #'string-equal))))) (aux-request-value 'bknr-parsed-parameters)) @@ -157,11 +157,11 @@ (#\> ">"))))) (defun parse-url () - (values-list (cddr (mapcar #'url-decode (split "/" (request-uri)))))) + (values-list (cddr (mapcar #'url-decode (split "/" (script-name)))))) (defun last-url-component () (register-groups-bind (last) - ("/([^\\/]+)$" (request-uri)) + ("/([^\\/]+)$" (script-name)) last)) (defun parse-date-field (name) @@ -180,12 +180,12 @@ (defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" (let ((len (length (page-handler-prefix handler)))) - (subseq (request-uri) len))) + (subseq (script-name) len))) (defun self-url (&key command prefix) (destructuring-bind (empty old-prefix object-id &rest old-command) - (split "/" (request-uri)) + (split "/" (script-name)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))"))

1 0

[bknr-cvs] r2429 - branches/trunk-reorg/thirdparty/cl-gd-0.5.6
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:46:46 2008 New Revision: 2429 Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp Log: Fix buglet with DO-PIXELS/GET-PIXEL that made SBCL choke. Modified: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp ============================================================================== --- branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp (original) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp Thu Jan 31 05:46:46 2008 @@ -220,12 +220,12 @@ (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) (declare (type pixels-array ,raw-pixels)) (dotimes (,y-var ,height) - (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-char)) ,y-var))) + (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-byte)) ,y-var))) (declare (type pixels-row ,row)) (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) `(dotimes (,,x-var ,',width) (macrolet ((raw-pixel () - `(deref-array ,',',row '(:array :unsigned-char) ,',,x-var))) + `(deref-array ,',',row '(:array :unsigned-byte) ,',,x-var))) (locally ,@,inner-body))))) (locally

1 0

[bknr-cvs] r2428 - in branches/trunk-reorg/thirdparty: cl-gd cl-gd-0.5.6 cl-gd-0.5.6/doc cl-gd-0.5.6/test cl-gd-0.5.6/test/orig
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 05:22:39 2008 New Revision: 2428 Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/CHANGELOG branches/trunk-reorg/thirdparty/cl-gd-0.5.6/Makefile branches/trunk-reorg/thirdparty/cl-gd-0.5.6/README branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-glue.c branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.asd branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors-aux.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/anti-aliased-lines.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/brushed-arc.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/chart.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/clipped-tangent.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/demooutp.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/gddemo.c branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/index.html branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/smallzappa.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/strings.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/triangle.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-ellipse.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-green.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/drawing.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/gd-uffi.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/images.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/init.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/packages.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/specials.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/strings.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/demoin.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/anti-aliased-lines.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/brushed-arc.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/chart.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/circle.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/clipped-tangent.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/triangle.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-ellipse.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-green.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/smallzappa.png (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/zappa.jpg (contents, props changed) branches/trunk-reorg/thirdparty/cl-gd-0.5.6/transform.lisp branches/trunk-reorg/thirdparty/cl-gd-0.5.6/util.lisp Removed: branches/trunk-reorg/thirdparty/cl-gd/ Log: Update cl-gd. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/CHANGELOG ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/CHANGELOG Thu Jan 31 05:22:39 2008 @@ -0,0 +1,102 @@ +Version 0.5.6 +2007-07-29 +Make WITH-TRANSFORMATIONS thread-safe (thanks to Alain Picard) + +Version 0.5.5 +2007-04-24 +Ugh, fix the fix once more (again thanks to Jong-won Choi) + +Version 0.5.4 +2007-04-06 +Trying to fix the 0.5.3 fix... (bug reported by Jong-won Choi) + +Version 0.5.3 +2007-03-19 +Fixed bug in DRAW-FREETYPE-STRING (reported by Andrei Stebakov) + +Version 0.5.2 +2007-02-28 +Fix CONVERT-TO-CHAR-REFERENCES (bug caught by Luo Yong) +Documentation fixes (thanks to Yoni Rabkin Katzenell) + +Version 0.5.1 +2005-10-04 +Support for OpenMCL via CFFI (thanks to Bryan O'Connor) + +Version 0.5.0 +2005-09-26 +Experimental CLISP/CFFI support (thanks to Luis Oliveira) +Don't redefine what's already there (for LispWorks) + +Version 0.4.8 +2005-05-17 +Re-enabled the ability to build without GIF support + +Version 0.4.7 +2005-05-07 +Added GET-PIXEL (provided by Alan Shields) + +Version 0.4.6 +2005-03-31 +Fixed typo in WITH-IMAGE* (thanks to Peter Barabas) +Handle CMUCL search lists correctly (thanks to Hans H�bner) +Added -lc option to linker call and included makefile (thanks to Hans H�bner) + +Version 0.4.5 +2005-03-16 +Fixed type check in MAKE-STREAM-FN (thanks to Walter C. Pelissero) + +Version 0.4.4 +2005-03-09 +More bug fixes (thanks to Carlos Ungil) + +Version 0.4.3 +2005-03-09 +Some bug fixes (thanks to Carlos Ungil) + +Version 0.4.2 +2004-11-26 +Build GIF support by default +Added link to cl-gd-glue.dll for Windows and corresponding documentation +Updated files in test/orig + +Version 0.4.1 +2004-05-21 +Replaced WRITE-BYTE with WRITE-SEQUENCE for LispWorks - see <http://article.gmane.org/gmane.lisp.lispworks.general/1827> + +Version 0.3.1 +2004-04-25 +Two separate C source files (with and without GIF support) +Added note about failed tests +Added hyperdoc support +Added :CL-GD to *FEATURES* + +Version 0.3.0 +2004-03-29 +Added GIF support (thanks to Hans H�bner) +Added Gentoo link + +Version 0.2.0 +2003-10-26 +Added DO-PIXELS and friends (proposed by Kevin Rosenberg) +Added Debian link + +Version 0.1.4 +2003-08-29 +Added library path for Debian compatibility (thanks to Kevin Rosenberg) + +Version 0.1.3 +2003-08-29 +Make CL-GD-TEST output less verbose for SBCL (thanks to Christophe Rhodes) + +Version 0.1.2 +2003-08-28 +Changed WITH-TRANSFORMATION macro to keep SBCL from complaining (thanks to Christophe Rhodes) + +Version 0.1.1 +2003-08-28 +Fixed *NULL-IMAGE* bug in DRAW-FREETYPE-STRING + +Version 0.1.0 +2003-08-26 +Initial release Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/Makefile ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/Makefile Thu Jan 31 05:22:39 2008 @@ -0,0 +1,11 @@ +# this should work for FreeBSD and most Linux distros + +cl-gd-glue.so: + gcc -I/usr/local/include -fPIC -c cl-gd-glue.c + ld -shared -lgd -lz -lpng -ljpeg -lfreetype -liconv -lm -lc cl-gd-glue.o -o cl-gd-glue.so -L/usr/local/lib + rm cl-gd-glue.o + +# this should work for Mac OS X + +cl-gd-glue.dylib: + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/README ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/README Thu Jan 31 05:22:39 2008 @@ -0,0 +1,69 @@ +Complete documentation for CL-GD can be found in the 'doc' +directory. + +CL-GD also supports Nikodemus Siivola's HYPERDOC, see +<http://common-lisp.net/project/hyperdoc/> and +<http://www.cliki.net/hyperdoc>. + +1. Installation (see doc/index.html for Windows instructions) + +1.1. Download and install a recent version of asdf. + +1.2. Download and install UFFI. CL-GD needs at least version 1.3.4 of + UFFI to work properly. However, as of August 2003, only + AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported + because CL-GD needs the new UFFI macros WITH-CAST-POINTER and + DEF-FOREIGN-VAR which haven't yet been ported to all UFFI + platforms. + +1.3. Download and install a recent version of GD and its supporting + libraries libpng, zlib, libjpeg, libiconv, and libfreetype. CL-GD has + been tested with GD 2.0.33, versions older than 2.0.28 won't + work. Note that you won't be able to compile CL-GD unless you have + installed all supporting libraries. This is different from using + GD directly from C where you only have to install the libraries + you intend to use. + +1.4. Unzip and untar the file cl-gd.tgz and put the resulting + directory wherever you want, then cd into this directory. + +1.5. Compile cl-gd-glue.c into a shared library for your platform. On + Linux this would be + + gcc -fPIC -c cl-gd-glue.c + ld -lgd -lz -lpng -ljpeg -lfreetype -lm -liconv -shared cl-gd-glue.o -o cl-gd-glue.so + rm cl-gd-glue.o + + For Mac OS X, use + + gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib + +1.6. Make sure that cl-gd.asd can be seen from asdf (this is usually + achieved by a symbolic link), start your favorite Lisp, and compile + CL-GD: + + (asdf:oos 'asdf:compile-op :cl-gd) + + From now on you can simply load CL-GD into a running Lisp image + with + + (asdf:oos 'asdf:load-op :cl-gd) + +2. Test + +CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then + + (asdf:oos 'asdf:load-op :cl-gd-test) + (cl-gd-test:test) + +If you have the georgiab.ttf TrueType font from Microsoft you can also +check the FreeType support of CL-GD with + + (cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") + +where you should obviously replace the path above with the full path +to the font on your machine. + +(See the note about failed tests in the documentation.) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-glue.c ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-glue.c Thu Jan 31 05:22:39 2008 @@ -0,0 +1,187 @@ +/* Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED + OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY + DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE + GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ + +#include <errno.h> +#include <stdio.h> +#include "gd.h" + +gdImagePtr gdImageCreateFromJpegFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromJpeg(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +#ifndef GD_DONT_USE_GIF +gdImagePtr gdImageCreateFromGifFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGif(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} +#endif + +gdImagePtr gdImageCreateFromPngFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromPng(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGdFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2File (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromGd2PartFile (char *filename, int *err, int srcX, int srcY, int w, int h) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromGd2Part(in, srcX, srcY, w, h); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +gdImagePtr gdImageCreateFromXbmFile (char *filename, int *err) { + FILE *in; + gdImagePtr im; + + if (in = fopen(filename, "rb")) { + im = gdImageCreateFromXbm(in); + if (im == NULL) { + *err = 0; + return NULL; + } + fclose(in); + return im; + } + *err = errno; + return NULL; +} + +int gdImageGetAlpha (gdImagePtr im, int color) { + return gdImageAlpha(im, color); +} + +int gdImageGetRed (gdImagePtr im, int color) { + return gdImageRed(im, color); +} + +int gdImageGetGreen (gdImagePtr im, int color) { + return gdImageGreen(im, color); +} + +int gdImageGetBlue (gdImagePtr im, int color) { + return gdImageBlue(im, color); +} + +int gdImageGetSX (gdImagePtr im) { + return gdImageSX(im); +} + +int gdImageGetSY (gdImagePtr im) { + return gdImageSY(im); +} + +int gdImageGetColorsTotal (gdImagePtr im) { + return gdImageColorsTotal(im); +} + +/* dumb names, I know... */ +int gdImageGetGetInterlaced (gdImagePtr im) { + return gdImageGetInterlaced(im); +} + +int gdImageGetGetTransparent (gdImagePtr im) { + return gdImageGetTransparent(im); +} Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.asd Thu Jan 31 05:22:39 2008 @@ -0,0 +1,45 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.asd,v 1.11 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd-test.system + (:use :cl :asdf)) + +(in-package :cl-gd-test.system) + +(defparameter *cl-gd-test-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd-test + :version "0.4.8" + :components ((:file "cl-gd-test")) + :depends-on (:cl-gd)) + Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd-test.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,490 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd-test.lisp,v 1.26 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage #:cl-gd-test + (:use #:cl + #:cl-gd) + (:export #:test)) + +(in-package :cl-gd-test) + +(defparameter *test-directory* + (merge-pathnames (make-pathname :directory '(:relative "test")) + (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + + "Where test files are put.") + +(defun test-file-location (name &optional (type :unspecific)) + "Create test file location from NAME and TYPE component." + (make-pathname :name name + :type type + :defaults *test-directory*)) + +(defun compare-files (file &key type expected-result) + "Compare test file FILE to orginal file in subdirectory ORIG." + (with-image-from-file (image file) + (with-image-from-file (orig (merge-pathnames + (make-pathname :type + (or type (pathname-type file)) + :directory + '(:relative "orig")) + file)) + (equal (differentp image orig) + expected-result)))) + +(defun test-001 () + (let ((file (test-file-location "one-pixel" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-002 () + (let ((file (test-file-location "one-pixel" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; black pixel in the middle + (set-pixel 20 20 :color (allocate-color 0 0 0)) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-003 () + (let ((file (test-file-location "one-line" "png"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to PNG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing file + (compare-files file))) + +(defun test-004 () + (let ((file (test-file-location "one-line" "jpg"))) + ;; 40x40 image + (with-image* (40 40) + ;; white background + (allocate-color 255 255 255) + ;; anti-aliased black line + (draw-line 20 20 30 30 + :color (make-anti-aliased + (allocate-color 0 0 0))) + ;; write to JPEG target + (write-image-to-file file :if-exists :supersede)) + ;; compare to existing PNG file + (compare-files file))) + +(defun test-005 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (let ((num (number-of-colors))) + (find-color 255 255 255 :resolve t) + (multiple-value-bind (width height) + (image-size) + (and (= width 40) + (= height 40) + ;; FIND-COLOR should not have changed the number of + ;; colors + (= num (number-of-colors))))))) + +(defun test-006 () + (with-image-from-file* ((test-file-location "one-pixel" "png")) + (with-transformation (:x1 0.1 :x2 0.5 :y1 10.8 :y2 20.9) + (multiple-value-bind (width height) + (image-size) + ;; make sure WITH-TRANSFORMATION returns transformed size + (and (>= 0.0001 (abs (- 0.4 width))) + (>= 0.0001 (abs (- 10.1 height)))))))) + +(defun test-007 () + (let ((file (test-file-location "circle" "png"))) + (with-image* (40 40) + (allocate-color 255 255 255) + (let ((black (allocate-color 0 0 0))) + (with-default-color (black) + ;; move origin to center and stretch + (with-transformation (:x1 -100 :width 200 :y1 -100 :height 200) + (draw-filled-circle 0 0 50) + (write-image-to-file file + :if-exists :supersede))))) + (compare-files file))) + +(defun test-008 () + (with-image (image 40 40) + (allocate-color 255 255 255 :image image) + (with-default-color ((allocate-color 0 0 0 :image image)) + ;; no transformation and use more general ellipse function + (draw-filled-ellipse 20 20 20 20 :image image) + (with-image-from-file (other-image + (test-file-location "circle" "png")) + (not (differentp image other-image)))))) + +(defun test-009 () + (let ((file (test-file-location "chart" "png"))) + ;; create 200x200 pixel image + (with-image* (200 200) + ;; background color + (allocate-color 68 70 85) + (let ((beige (allocate-color 222 200 81)) + (brown (allocate-color 206 150 75)) + (green (allocate-color 104 156 84)) + (red (allocate-color 163 83 84)) + (white (allocate-color 255 255 255)) + (two-pi (* 2 pi))) + ;; move origin to center of image + (with-transformation (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) + ;; draw some 'pie slices' + (draw-arc 0 0 130 130 0 (* .6 two-pi) + :center-connect t :filled t :color beige) + (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) + :center-connect t :filled t :color brown) + (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) + :center-connect t :filled t :color green) + (draw-arc 0 0 130 130 (* .95 two-pi) two-pi + :center-connect t :filled t :color red) + ;; use GD fonts + (with-default-color (white) + (with-default-font (:small) + (draw-string -8 -30 "60%") + (draw-string -20 40 "20%") + (draw-string 20 30 "15%")) + (draw-string -90 90 "Global Revenue" + :font :large)) + (write-image-to-file file + :compression-level 6 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-010 () + (let ((file (test-file-location "zappa-green" "jpg"))) + ;; get JPEG from disk + (with-image-from-file (old (test-file-location "zappa" "jpg")) + (multiple-value-bind (width height) + (image-size old) + (with-image (new width height) + ;; green color for background + (allocate-color 0 255 0 :image new) + ;; merge with original JPEG + (copy-image old new 0 0 0 0 width height + :merge 50) + (write-image-to-file file + :image new + :if-exists :supersede)))) + (compare-files file))) + +(defun test-011 () + ;; small image + (with-image* (10 10) + (loop for i below +max-colors+ do + ;; allocate enough colors (all gray) to fill the palette + (allocate-color i i i)) + (and (= +max-colors+ (number-of-colors)) + (null (find-color 255 0 0 :exact t)) + (let ((match (find-color 255 0 0))) ; green + (and (= 85 + (color-component :red match) + (color-component :green match) + (color-component :blue match))))))) + +(defun test-012 () + (let ((file (test-file-location "triangle" "png"))) + (with-image* (100 100) + (allocate-color 255 255 255) ; white background + (let ((red (allocate-color 255 0 0)) + (yellow (allocate-color 255 255 0)) + (orange (allocate-color 255 165 0))) + ;; thin black border + (draw-rectangle* 0 0 99 99 + :color (allocate-color 0 0 0)) + ;; lines are five pixels thick + (with-thickness (5) + ;; colored triangle + (draw-polygon (list 10 10 90 50 50 90) + ;; styled color + :color (list red red red + yellow yellow yellow + nil nil nil + orange orange orange)) + (write-image-to-file file + :compression-level 8 + :if-exists :supersede)))) + (compare-files file))) + +(defun test-013 () + (let ((file (test-file-location "brushed-arc" "png"))) + (with-image* (200 100) + (allocate-color 255 165 0) ; orange background + (with-image (brush 6 6) + (let* ((black (allocate-color 0 0 0 :image brush)) ; black background + (red (allocate-color 255 0 0 :image brush)) + (blue (allocate-color 0 0 255 :image brush))) + (setf (transparent-color brush) black) ; make background transparent + ;; now set the pixels in the brush + (set-pixels '(2 2 2 3 3 2 3 3) + :color blue :image brush) + (set-pixels '(1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) + :color red :image brush) + ;; then use it to draw an arc + (draw-arc 100 50 180 80 180 300 :color (make-brush brush))) + (write-image-to-file file + :compression-level 7 + :if-exists :supersede))) + (compare-files file))) + +(defun test-014 () + (let ((file (test-file-location "anti-aliased-lines" "png"))) + (with-image* (150 50) + (let ((orange (allocate-color 255 165 0)) ; orange background + (white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0))) + ;; white background rectangle in the middle third + (draw-rectangle* 50 0 99 49 + :filled t + :color white) + (with-thickness (2) + ;; just a red line + (draw-line 5 10 145 10 :color red) + ;; anti-aliased red line + (draw-line 5 25 145 25 :color (make-anti-aliased red)) + ;; anti-aliased red line which should stand out against + ;; orange background + (draw-line 5 40 145 40 :color (make-anti-aliased red orange)))) + (write-image-to-file file + :compression-level 3 + :if-exists :supersede)) + (compare-files file))) + +(defun test-015 () + (let ((file (test-file-location "clipped-tangent" "png"))) + (with-image* (150 150) + (allocate-color 255 255 255) ; white background + ;; transform such that x axis ranges from (- PI) to PI and y + ;; axis ranges from -3 to 3 + (with-transformation (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) + (let ((black (allocate-color 0 0 0)) + (red (allocate-color 255 0 0)) + (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) + (with-default-color (black) + ;; draw axes + (draw-line 0 -3 0 3 :color black) + (draw-line (- pi) 0 pi 0)) + ;; show clipping rectangle (styled) + (draw-rectangle rectangle :color (list black black black nil black nil)) + (with-clipping-rectangle (rectangle) + ;; draw tangent function + (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do + (set-pixel x (tan x) :color red))))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun gd-demo-picture (file random-state &optional write-file) + (with-image* ((+ 256 384) 384 t) + (let ((white (allocate-color 255 255 255)) + (red (allocate-color 255 0 0)) + (green (allocate-color 0 255 0)) + (blue (allocate-color 0 0 255)) + (vertices (list 64 0 0 128 128 128)) + (image-width (image-width)) + (image-height (image-height))) + (setf (transparent-color) white) + (draw-rectangle* 0 0 image-width image-height :color white) + (with-image-from-file (in-file (test-file-location "demoin" "png")) + (copy-image in-file *default-image* + 0 0 32 32 192 192 + :resize t + :dest-width 255 + :dest-height 255 + :resample t) + (multiple-value-bind (in-width in-height) + (image-size in-file) + (loop for a below 360 by 45 do + (copy-image in-file *default-image* + 0 0 + (+ 256 192 (* 128 (cos (* a .0174532925)))) + (- 192 (* 128 (sin (* a .0174532925)))) + in-width in-height + :rotate t + :angle a)) + (with-default-color (green) + (with-thickness (4) + (draw-line 16 16 240 16) + (draw-line 240 16 240 240) + (draw-line 240 240 16 240) + (draw-line 16 240 16 16)) + (draw-polygon vertices :filled t)) + (dotimes (i 3) + (incf (nth (* 2 i) vertices) 128)) + (draw-polygon vertices + :color (make-anti-aliased green) + :filled t) + (with-default-color (blue) + (draw-arc 128 128 60 20 0 720) + (draw-arc 128 128 40 40 90 270) + (fill-image 8 8)) + (with-image (brush 16 16 t) + (copy-image in-file brush + 0 0 0 0 + in-width in-height + :resize t + :dest-width (image-width brush) + :dest-height (image-height brush)) + (draw-line 0 255 255 0 + :color (cons (make-brush brush) + (list nil nil nil nil nil nil nil t)))))) + (with-default-color (red) + (draw-string 32 32 "hi" :font :giant) + (draw-string 64 64 "hi" :font :small)) + (with-clipping-rectangle* (0 (- image-height 100) 100 image-height) + (with-default-color ((make-anti-aliased white)) + (dotimes (i 100) + (draw-line (random image-width random-state) + (random image-height random-state) + (random image-width random-state) + (random image-height random-state)))))) + (setf (interlacedp) t) + (true-color-to-palette) + (if write-file + (write-image-to-file file + :if-exists :supersede) + (with-image-from-file (demo-file file) + (not (differentp demo-file *default-image*)))))) + +(defun test-016 () + (let* ((file (test-file-location "demooutp" "png")) + (random-state-1 (make-random-state t)) + (random-state-2 (make-random-state random-state-1))) + (gd-demo-picture file random-state-1 t) + (gd-demo-picture file random-state-2))) + +(defun test-017 () + (let ((file (test-file-location "zappa-ellipse" "png"))) + (with-image* (250 150) + (with-image-from-file (zappa (test-file-location "smallzappa" "png")) + (setf (transparent-color) (allocate-color 255 255 255)) + (draw-filled-ellipse 125 75 250 150 + :color (make-tile zappa))) + (write-image-to-file file + :if-exists :supersede)) + (compare-files file))) + +(defun test-018 () + (let (result) + (with-image* (3 3) + (allocate-color 255 255 255) + (draw-line 0 0 2 2 :color (allocate-color 0 0 0)) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 1) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 1) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 1)))))) + +(defun test-019 () + (let (result) + (with-image* (3 3 t) + (draw-rectangle* 0 0 2 2 :color (allocate-color 0 0 0)) + (draw-line 0 0 2 2 :color (allocate-color 255 255 255)) + (do-pixels () + (unless (zerop (raw-pixel)) + (decf (raw-pixel) #xff))) + (do-rows (y) + (let (row) + (do-pixels-in-row (x) + (push (list x y (raw-pixel)) row)) + (push (nreverse row) result)))) + (equal + (nreverse result) + '(((0 0 #xffff00) (1 0 0) (2 0 0)) + ((0 1 0) (1 1 #xffff00) (2 1 0)) + ((0 2 0) (1 2 0) (2 2 #xffff00)))))) + +(defun test-020 (georgia) + ;; not used for test suite because of dependency on font + (with-image* (200 200) + ;; set background (white) and make it transparent + (setf (transparent-color) + (allocate-color 255 255 255)) + (loop for angle from 0 to (* 2 pi) by (/ pi 6) + for blue downfrom 255 by 20 do + (draw-freetype-string 100 100 "Common Lisp" + :font-name georgia + :angle angle + ;; note that ALLOCATE-COLOR won't work + ;; here because the anti-aliasing uses + ;; up too much colors + :color (find-color 0 0 blue + :resolve t))) + (write-image-to-file (test-file-location "strings" "png") + :if-exists :supersede))) + +(defun test% (georgia) + (loop for i from 1 to (if georgia 20 19) do + (handler-case + (format t "Test ~A ~:[failed~;succeeded~].~%" i + (let ((test-function + (intern (format nil "TEST-~3,'0d" i) + :cl-gd-test))) + (if (= i 20) + (funcall test-function georgia) + (funcall test-function)))) + (error (condition) + (format t "Test ~A failed with the following error: ~A~%" + i condition))) + (force-output)) + (format t "Done.~%")) + +(defun test (&optional georgia) + #-:sbcl + (test% georgia) + #+:sbcl + (handler-bind ((sb-ext:compiler-note #'muffle-warning)) + (test% georgia))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/cl-gd.asd Thu Jan 31 05:22:39 2008 @@ -0,0 +1,58 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/cl-gd.asd,v 1.18 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-user) + +(defpackage :cl-gd.system + (:use :cl :asdf) + (:export :*cl-gd-directory*)) + +(in-package :cl-gd.system) + +(defparameter *cl-gd-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defsystem :cl-gd + :version "0.5.6" + :serial t + :components ((:file "packages") + (:file "util") + (:file "specials") + (:file "init") + (:file "gd-uffi") + (:file "transform") + (:file "images") + (:file "colors-aux") + (:file "colors") + (:file "drawing") + (:file "strings") + (:file "misc")) + :depends-on (#-(or :clisp :openmcl) :uffi + #+(or :clisp :openmcl) :cffi-uffi-compat)) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors-aux.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors-aux.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,168 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors-aux.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun current-brush (&optional (image *default-image*)) + "Returns the GD image which is the current brush of IMAGE \(or NIL +if there is no current brush)." + (check-type image image) + (let ((brush (get-slot-value (img image) 'gd-image 'brush))) + (if (null-pointer-p brush) + nil + brush))) + +(defun (setf current-brush) (brush &optional (image *default-image*)) + "Sets BRUSH \(which must be a GD image) to be the current brush +for IMAGE." + (check-type brush image) + (check-type image image) + (gd-image-set-brush (img image) (img brush)) + brush) + +(defun current-tile (&optional (image *default-image*)) + "Returns the GD image which is the current tile of IMAGE \(or NIL +if there is no current tile)." + (check-type image image) + (let ((tile (get-slot-value (img image) 'gd-image 'tile))) + (if (null-pointer-p tile) + nil + tile))) + +(defun (setf current-tile) (tile &optional (image *default-image*)) + "Sets TILE \(which must be a GD image) to be the current tile +for IMAGE." + (check-type tile (or image null)) + (check-type image image) + (gd-image-set-tile (img image) (img tile)) + tile) + +(defun current-style (&optional (image *default-image*)) + "Returns the current style of IMAGE as a list." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop for i below style-length + collect (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))))) + +(defun current-style* (&key (image *default-image*)) + "Returns the current style of IMAGE as an array." + (check-type image image) + (let ((style-length (get-slot-value (img image) 'gd-image 'style-length)) + (style (get-slot-value (img image) 'gd-image 'style))) + (loop with result = (make-array style-length) + for i below style-length + do (setf (aref result i) + (let ((color (deref-array style '(:array :int) i))) + (if (= color +transparent+) + nil + color))) + finally (return result)))) + +(defgeneric (setf current-style) (style &optional image) + (:documentation "Sets STYLE to be the current drawing style for +IMAGE. STYLE can be a LIST or a VECTOR. Each element of STYLE is +either a color or NIL \(for transparent pixels).")) + +(defmethod (setf current-style) ((style list) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color in style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defmethod (setf current-style) ((style vector) &optional (image *default-image*)) + (check-type image image) + (let ((length (length style))) + (with-safe-alloc (c-style (allocate-foreign-object :int length) + (free-foreign-object c-style)) + (loop for color across style + for i from 0 + do (setf (deref-array c-style '(:array :int) i) + (typecase color + (null +transparent+) + (integer color) + (t 1)))) + (gd-image-set-style (img image) c-style length) + style))) + +(defun set-anti-aliased (color do-not-blend &optional (image *default-image*)) + "Set COLOR to be the current anti-aliased color of +IMAGE. DO-NOT-BLEND \(if provided) is the background color +anti-aliased lines stand out against clearly." + (check-type color integer) + (check-type do-not-blend (or integer null)) + (check-type image image) + (gd-image-set-anti-aliased-do-not-blend (img image) + color + (or do-not-blend -1))) + +(defun resolve-c-color (color image) + "Accepts a CL-GD 'color' COLOR and returns the corresponding +argument for GD, modifying internal slots of IMAGE if needed." + (etypecase color + (brush + (setf (current-brush image) color) + +brushed+) + (tile + (setf (current-tile image) color) + +tiled+) + ((cons brush (or vector list)) + (setf (current-brush image) (car color) + (current-style image) (cdr color)) + +styled-brushed+) + (anti-aliased-color + (set-anti-aliased (color color) + (do-not-blend color) + image) + +anti-aliased+) + ((or vector list) + (setf (current-style image) color) + +styled+) + (integer + color))) + +(defmacro with-color-argument (&body body) + "Internal macro used to give correct color arguments to enclosed +foreign functions. Assumes fixed names COLOR and IMAGE." + (with-unique-names (c-color-arg) + `(let ((,c-color-arg (resolve-c-color color image))) + ,@(sublis (list (cons 'color c-color-arg)) + body :test #'eq)))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/colors.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,247 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/colors.lisp,v 1.25 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-color ((color) &body body) + "Executes BODY with *DEFAULT-COLOR* bound to COLOR so that you don't +have to provide the COLOR keyword/optional argument to drawing +functions." + `(let ((*default-color* ,color)) + ,@body)) + +(defun allocate-color (red green blue &key alpha (errorp t) (image *default-image*)) + "Finds the first available color index in the image IMAGE specified, +sets its RGB values to those requested \(255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value +in the case of a true color image. In either case you can then use the +returned value as a COLOR parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If ALPHA +\(not greater than 127) is provided, an RGBA color will always be +allocated. If all +GD-MAX-COLORS+ have already been allocated this +function will, depending on the value of ERRORP, either raise an error +or return NIL." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (let ((result + (if alpha + (gd-image-color-allocate-alpha (img image) red green blue alpha) + (gd-image-color-allocate (img image) red green blue)))) + (cond ((and errorp + (= result -1)) + (error "Can't allocate color")) + ((= result -1) + nil) + (t + result)))) + +(defun deallocate-color (color &optional (image *default-image*)) + "Marks the specified color COLOR as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image IMAGE." + (check-type color integer) + (check-type image image) + (gd-image-color-deallocate (img image) color)) + +(defun transparent-color (&optional (image *default-image*)) + "Returns the transparent color of IMAGE \(or NIL if there is none)." + (check-type image image) + (gd-image-get-transparent (img image))) + +(defun (setf transparent-color) (color &optional (image *default-image*)) + "Makes COLOR the transparent color of IMAGE. If COLOR is NIL the +image won't have a transparent color. Note that JPEG images don't +support transparency." + (check-type color (or null integer)) + (check-type image image) + (gd-image-color-transparent (img image) (or color -1)) + color) + +(defun true-color-p (&optional (image *default-image*)) + "Returns true iff IMAGE is a true color image." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'true-color)))) + +(defun number-of-colors (&key (image *default-image*)) + "Returns the number of color allocated in IMAGE. Returns NIL if +IMAGE is a true color image." + (check-type image image) + (if (true-color-p image) + nil + (get-slot-value (img image) 'gd-image 'colors-total))) + +(defun find-color (red green blue &key alpha exact hwb resolve (image *default-image*)) + "Tries to find and/or allocate a color from IMAGE's color +palette. If EXACT is true, the color will only be returned if it is +already allocated. If EXACT is NIL, a color which is 'close' to the +color specified by RED, GREEN, and BLUE \(and probably ALPHA) might be +returned \(unless there aren't any colors allocated in the image +yet). If HWB is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If RESOLVE is true a color \(probably a new one) will +always be returned, otherwise the result of this function might be +NIL. If ALPHA \(not greater than 127) is provided, an RGBA color (or +NIL) will be returned. + +ALPHA, EXACT, and HWB are mutually exclusive. RESOLVE can't be used +together with EXACT or HWB." + (check-type red integer) + (check-type green integer) + (check-type blue integer) + (check-type alpha (or null integer)) + (check-type image image) + (when (< 1 (count-if #'identity (list alpha exact hwb))) + (error "You can't specify two of ALPHA, EXACT, and HWB at the same +time")) + (when (and hwb resolve) + (error "You can't specify HWB and RESOLVE at the same time")) + (when (and exact resolve) + (error "You can't specify EXACT and RESOLVE at the same time")) + (let ((result + (cond ((and resolve alpha) + (gd-image-color-resolve-alpha (img image) red green blue alpha)) + (resolve + (gd-image-color-resolve (img image) red green blue)) + (alpha + (gd-image-color-closest-alpha (img image) red green blue alpha)) + (exact + (gd-image-color-exact (img image) red green blue)) + (hwb + (gd-image-color-closest-hwb (img image) red green blue)) + (t + (gd-image-color-closest (img image) red green blue))))) + (if (= result -1) + nil + result))) + +(defun thickness (&optional (image *default-image*)) + "Gets the width of lines drawn by the drawing functions. Note that +this is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type image image) + (get-slot-value (img image) 'gd-image 'thick)) + +(defun (setf thickness) (thickness &optional (image *default-image*)) + "Sets the width of lines drawn by the drawing functions. Note that +THICKNESS is measured in pixels and is NOT affected by +WITH-TRANSFORMATION." + (check-type thickness integer) + (check-type image image) + (gd-image-set-thickness (img image) thickness) + thickness) + +(defmacro with-thickness ((thickness &key (image '*default-image*)) &body body) + "Executes BODY with the current line width of IMAGE set to +THICKNESS. The image's previous line width is guaranteed to be +restored before the macro exits. Note that the line width is measured +in pixels and is not affected by WITH-TRANSFORMATION." + (with-unique-names (old-thickness) + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (thickness image) + `(let ((,old-thickness (thickness ,image))) + (unwind-protect + (progn + (setf (thickness ,image) ,thickness)) + ,@body) + (setf (thickness ,image) ,old-thickness))))) + +(defun alpha-blending-p (&optional (image *default-image*)) + "Returns whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(return value is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(return value is true). This is +only meaningful for true color images." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'alpha-blending-flag)))) + +(defun (setf alpha-blending-p) (blending &optional (image *default-image*)) + "Determines whether pixels drawn on IMAGE will be copied literally +including alpha channel information \(if BLENDING is false) or if +their alpha channel information will determine how much of the +underlying color will shine through \(if BLENDING is true). This is +only meaningful for true color images." + (check-type image image) + (gd-image-alpha-blending (img image) (if blending 1 0)) + blending) + +(defun save-alpha-p (&optional (image *default-image*)) + "Returns whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (not (zerop (get-slot-value (img image) 'gd-image 'save-alpha-flag)))) + +(defun (setf save-alpha-p) (save &key (image *default-image*)) + "Determines whether PNG images will be saved with full alpha channel +information." + (check-type image image) + (gd-image-save-alpha (img image) (if save 1 0)) + save) + +(defun color-component (component color &key (image *default-image*)) + "Returns the specified color component of COLOR. COMPONENT can be +one of :RED, :GREEN, :BLUE, and :ALPHA." + (check-type color integer) + (check-type image image) + (funcall (ecase component + ((:red) #'gd-image-get-red) + ((:green) #'gd-image-get-green) + ((:blue) #'gd-image-get-blue) + ((:alpha) #'gd-image-get-alpha)) + (img image) + color)) + +(defun color-components (color &key (image *default-image*)) + "Returns a list of the color components of COLOR. The +components are in the order red, green, blue, alpha." + (mapcar #'(lambda (c) (color-component c color :image image)) + '(:red :green :blue :alpha))) + +(defun find-color-from-image (color source-image &key alpha exact hwb + resolve (image *default-image*)) + "Returns the color in IMAGE corresponding to COLOR in +SOURCE-IMAGE. The keyword parameters are passed to FIND-COLOR." + (let ((red (color-component :red color + :image source-image)) + (blue (color-component :blue color + :image source-image)) + (green (color-component :green color + :image source-image)) + (alpha (when alpha + (color-component :alpha color + :image source-image)))) + (find-color red green blue + :alpha alpha + :exact exact + :hwb hwb + :resolve resolve + :image image))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/brushed-arc.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/chart.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/demooutp.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/gddemo.c ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/gddemo.c Thu Jan 31 05:22:39 2008 @@ -0,0 +1,169 @@ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include <stdio.h> +#include <math.h> +#include <stdlib.h> +#include "gd.h" +#include "gdfontg.h" +#include "gdfonts.h" + +int +main (void) +{ +#ifdef HAVE_LIBPNG + /* Input and output files */ + FILE *in; + FILE *out; + + /* Input and output images */ + gdImagePtr im_in = 0, im_out = 0; + + /* Brush image */ + gdImagePtr brush; + + /* Color indexes */ + int white; + int blue; + int red; + int green; + + /* Points for polygon */ + gdPoint points[3]; + int i; + + /* Create output image, in true color. */ + im_out = gdImageCreateTrueColor (256 + 384, 384); + /* 2.0.2: first color allocated would automatically be background in a + palette based image. Since this is a truecolor image, with an + automatic background of black, we must fill it explicitly. */ + white = gdImageColorAllocate (im_out, 255, 255, 255); + gdImageFilledRectangle (im_out, 0, 0, gdImageSX (im_out), + gdImageSY (im_out), white); + + /* Set transparent color. */ + gdImageColorTransparent (im_out, white); + + /* Try to load demoin.png and paste part of it into the + output image. */ + in = fopen ("demoin.png", "rb"); + if (!in) + { + fprintf (stderr, "Can't load source image; this demo\n"); + fprintf (stderr, "is much more impressive if demoin.png\n"); + fprintf (stderr, "is available.\n"); + im_in = 0; + } + else + { + int a; + im_in = gdImageCreateFromPng (in); + fclose (in); + /* Now copy, and magnify as we do so */ + gdImageCopyResampled (im_out, im_in, 32, 32, 0, 0, 192, 192, 255, 255); + /* Now display variously rotated space shuttles in a circle of our own */ + for (a = 0; (a < 360); a += 45) + { + int cx = cos (a * .0174532925) * 128; + int cy = -sin (a * .0174532925) * 128; + gdImageCopyRotated (im_out, im_in, + 256 + 192 + cx, 192 + cy, + 0, 0, gdImageSX (im_in), gdImageSY (im_in), a); + } + } + red = gdImageColorAllocate (im_out, 255, 0, 0); + green = gdImageColorAllocate (im_out, 0, 255, 0); + blue = gdImageColorAllocate (im_out, 0, 0, 255); + /* Fat Rectangle */ + gdImageSetThickness (im_out, 4); + gdImageLine (im_out, 16, 16, 240, 16, green); + gdImageLine (im_out, 240, 16, 240, 240, green); + gdImageLine (im_out, 240, 240, 16, 240, green); + gdImageLine (im_out, 16, 240, 16, 16, green); + gdImageSetThickness (im_out, 1); + /* Circle */ + gdImageArc (im_out, 128, 128, 60, 20, 0, 720, blue); + /* Arc */ + gdImageArc (im_out, 128, 128, 40, 40, 90, 270, blue); + /* Flood fill: doesn't do much on a continuously + variable tone jpeg original. */ + gdImageFill (im_out, 8, 8, blue); + /* Polygon */ + points[0].x = 64; + points[0].y = 0; + points[1].x = 0; + points[1].y = 128; + points[2].x = 128; + points[2].y = 128; + gdImageFilledPolygon (im_out, points, 3, green); + /* 2.0.12: Antialiased Polygon */ + gdImageSetAntiAliased (im_out, green); + for (i = 0; (i < 3); i++) + { + points[i].x += 128; + } + gdImageFilledPolygon (im_out, points, 3, gdAntiAliased); + /* Brush. A fairly wild example also involving a line style! */ + if (im_in) + { + int style[8]; + brush = gdImageCreateTrueColor (16, 16); + gdImageCopyResized (brush, im_in, + 0, 0, 0, 0, + gdImageSX (brush), gdImageSY (brush), + gdImageSX (im_in), gdImageSY (im_in)); + gdImageSetBrush (im_out, brush); + /* With a style, so they won't overprint each other. + Normally, they would, yielding a fat-brush effect. */ + style[0] = 0; + style[1] = 0; + style[2] = 0; + style[3] = 0; + style[4] = 0; + style[5] = 0; + style[6] = 0; + style[7] = 1; + gdImageSetStyle (im_out, style, 8); + /* Draw the styled, brushed line */ + gdImageLine (im_out, 0, 255, 255, 0, gdStyledBrushed); + } + /* Text (non-truetype; see gdtestft for a freetype demo) */ + gdImageString (im_out, gdFontGiant, 32, 32, (unsigned char *) "hi", red); + gdImageStringUp (im_out, gdFontSmall, 64, 64, (unsigned char *) "hi", red); + /* Random antialiased lines; coordinates all over the image, + but the output will respect a small clipping rectangle */ + gdImageSetClip(im_out, 0, gdImageSY(im_out) - 100, + 100, gdImageSY(im_out)); + /* Fixed seed for reproducibility of results */ + srand(100); + for (i = 0; (i < 100); i++) { + int x1 = rand() % gdImageSX(im_out); + int y1 = rand() % gdImageSY(im_out); + int x2 = rand() % gdImageSX(im_out); + int y2 = rand() % gdImageSY(im_out); + gdImageSetAntiAliased(im_out, white); + gdImageLine (im_out, x1, y1, x2, y2, gdAntiAliased); + } + /* Make output image interlaced (progressive, in the case of JPEG) */ + gdImageInterlace (im_out, 1); + out = fopen ("demoout.png", "wb"); + /* Write PNG */ + gdImagePng (im_out, out); + fclose (out); + /* 2.0.12: also write a paletteized version */ + out = fopen ("demooutp.png", "wb"); + gdImageTrueColorToPalette (im_out, 0, 256); + gdImagePng (im_out, out); + fclose (out); + gdImageDestroy (im_out); + if (im_in) + { + gdImageDestroy (im_in); + } +#else + fprintf (stderr, "No PNG library support.\n"); +#endif /* HAVE_LIBPNG */ + return 0; +} Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/index.html ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/index.html Thu Jan 31 05:22:39 2008 @@ -0,0 +1,1441 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<html> + +<head> + <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1"> + <title>CL-GD - Use the GD Graphics library from Common Lisp</title> + <style type="text/css"> + pre { padding:5px; background-color:#e0e0e0 } + h3, h4 { text-decoration: underline; } + a { text-decoration: none; padding: 1px 2px 1px 2px; } + a:visited { text-decoration: none; padding: 1px 2px 1px 2px; } + a:hover { text-decoration: none; padding: 1px 1px 1px 1px; border: 1px solid #000000; } + a:focus { text-decoration: none; padding: 1px 2px 1px 2px; border: none; } + a.none { text-decoration: none; padding: 0; } + a.none:visited { text-decoration: none; padding: 0; } + a.none:hover { text-decoration: none; border: none; padding: 0; } + a.none:focus { text-decoration: none; border: none; padding: 0; } + a.noborder { text-decoration: none; padding: 0; } + a.noborder:visited { text-decoration: none; padding: 0; } + a.noborder:hover { text-decoration: none; border: none; padding: 0; } + a.noborder:focus { text-decoration: none; border: none; padding: 0; } + pre.none { padding:5px; background-color:#ffffff } + </style> +</head> + +<body bgcolor=white> + +<h2>CL-GD - Use the GD Graphics library from Common Lisp</h2> + +<blockquote> +   <h3>Abstract</h3> + +CL-GD is a library for Common Lisp which provides an interface to the +<a href="http://www.boutell.com/gd/">GD Graphics Library</a> for the +dynamic creation of images. It is based on <a +href="http://uffi.b9.com/">UFFI</a> and should thus be portable to all +CL implementations supported by UFFI. + +A version which also works with CLISP is available from <a +href="http://ungil.com/cl-gd-clisp.tgz">http://ungil.com/cl-gd-clisp.tgz</a> +thanks to Carlos Ungil. Also, beginning from version 0.5.0/0.5.1, CL-GD +contains initial code to support CLISP and OpenMCL via <a +href="http://common-lisp.net/project/cffi/">CFFI</a> (<a href="http://common-lisp.net/pipermail/cl-gd-devel/2005-September/000030.html">thanks to Luis +Oliveira</a> and Bryan O'Connor). Please try it and report to <a href="#mail">the mailing list</a> if you +have problems. + +The focus of CL-GD is convenience and correctness, not necessarily speed. If you think CL-GD is too slow and you're concerned about speed, <a href="#mail">contact me</a> before you start coding in C... :) + +CL-GD comes with a <a +href="http://www.opensource.org/licenses/bsd-license.php">BSD-style +license</a> so you can basically do with it whatever you want. Please send bug reports to <a href="#mail">the mailing list</a> mentioned below if you encounter any problems with CL-GD. (I'm glad to fix CL-GD but I can't do much about GD, of course. So if CL-GD basically works for you but you encounter seemingly strange behaviour when drawing please try if and how you can achieve the intended result with GD directly. That would help me a lot. Thanks.) + +CL-GD is used by <a href="http://www.quickhoney.com/">QuickHoney</a>. + + +Download shortcut: <a href="http://weitz.de/files/cl-gd.tar.gz">http://weitz.de/files/cl-gd.tar.gz</a>. +</blockquote> + +   <h3><a href="#contents" name="example" class=none>A simple example</a></h3> + +The image to the right was created with this piece of code: + +<pre> +<img alt="chart.png" title="chart.png" align=right border=0 vspace=10 hspace=10 width=200 height=200 src="chart.png">(<a class=noborder href="#with-image*">with-image*</a> (200 200) ; create 200x200 pixel image + (<a class=noborder href="#allocate-color">allocate-color</a> 68 70 85) ; background color + (let ((beige (allocate-color 222 200 81)) + (brown (allocate-color 206 150 75)) + (green (allocate-color 104 156 84)) + (red (allocate-color 163 83 84)) + (white (allocate-color 255 255 255)) + (two-pi (* 2 pi))) + ;; move origin to center of image + (<a class=noborder href="#with-transformation">with-transformation</a> (:x1 -100 :x2 100 :y1 -100 :y2 100 :radians t) + ;; draw some 'pie slices' + (<a class=noborder href="#draw-arc">draw-arc</a> 0 0 130 130 0 (* .6 two-pi) + :center-connect t :filled t :color beige) + (draw-arc 0 0 130 130 (* .6 two-pi) (* .8 two-pi) + :center-connect t :filled t :color brown) + (draw-arc 0 0 130 130 (* .8 two-pi) (* .95 two-pi) + :center-connect t :filled t :color green) + (draw-arc 0 0 130 130 (* .95 two-pi) two-pi + :center-connect t :filled t :color red) + (<a class=noborder href="#with-default-color">with-default-color</a> (white) + (<a class=noborder href="#with-default-font">with-default-font</a> (:small) + (<a class=noborder href="#draw-string">draw-string</a> -8 -30 "60%") + (draw-string -20 40 "20%") + (draw-string 20 30 "15%")) + (<a class=noborder href="#draw-freetype-string">draw-freetype-string</a> -90 75 "Global Revenue" + ;; this assumes that 'DEFAULT_FONTPATH' + ;; is set correctly + :font-name "verdanab")))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "chart.png" + :compression-level 6 :if-exists :supersede)) +</pre> + + +See below for more examples. + +   <h3><a class=none name="contents">Contents</a></h3> +<ul> + <li><a href="#example">A simple example</a> + <li><a href="#install">Download and installation</a> + <li><a href="#mail">Support and mailing lists</a> + <li><a href="#images">Images</a> + <ul> + <li><a href="#create-image"><code>create-image</code></a> + <li><a href="#create-image-from-file"><code>create-image-from-file</code></a> + <li><a href="#create-image-from-gd2-part"><code>create-image-from-gd2-part</code></a> + <li><a href="#destroy-image"><code>destroy-image</code></a> + <li><a href="#with-image"><code>with-image</code></a> + <li><a href="#with-image-from-file"><code>with-image-from-file</code></a> + <li><a href="#with-image-from-gd2-part"><code>with-image-from-gd2-part</code></a> + <li><a href="#default-image"><code>*default-image*</code></a> + <li><a href="#with-default-image"><code>with-default-image</code></a> + <li><a href="#with-image*"><code>with-image*</code></a> + <li><a href="#with-image-from-file*"><code>with-image-from-file*</code></a> + <li><a href="#with-image-from-gd2-part*"><code>with-image-from-gd2-part*</code></a> + <li><a href="#write-jpeg-to-stream"><code>write-jpeg-to-stream</code></a> + <li><a href="#write-png-to-stream"><code>write-png-to-stream</code></a> + <li><a href="#write-wbmp-to-stream"><code>write-wbmp-to-stream</code></a> + <li><a href="#write-gif-to-stream"><code>write-gif-to-stream</code></a> + <li><a href="#write-gd-to-stream"><code>write-gd-to-stream</code></a> + <li><a href="#write-gd2-to-stream"><code>write-gd2-to-stream</code></a> + <li><a href="#write-image-to-stream"><code>write-image-to-stream</code></a> + <li><a href="#write-image-to-file"><code>write-image-to-file</code></a> + <li><a href="#image-width"><code>image-width</code></a> + <li><a href="#image-height"><code>image-height</code></a> + <li><a href="#image-size"><code>image-size</code></a> + </ul> + <li><a href="#colors">Colors</a> + <ul> + <li><a href="#default-color"><code>*default-color*</code></a> + <li><a href="#with-default-color"><code>with-default-color</code></a> + <li><a href="#allocate-color"><code>allocate-color</code></a> + <li><a href="#find-color"><code>find-color</code></a> + <li><a href="#find-color-from-image"><code>find-color-from-image</code></a> + <li><a href="#color-component"><code>color-component</code></a> + <li><a href="#color-components"><code>color-components</code></a> + <li><a href="#deallocate-color"><code>deallocate-color</code></a> + <li><a href="#true-color-p"><code>true-color-p</code></a> + <li><a href="#number-of-colors"><code>number-of-colors</code></a> + <li><a href="#max-colors"><code>+max-colors+</code></a> + <li><a href="#transparent-color"><code>transparent-color</code></a> + <li><a href="#alpha-blending-p"><code>alpha-blending-p</code></a> + <li><a href="#save-alpha-p"><code>save-alpha-p</code></a> + </ul> + <li><a href="#brushes">Styles, brushes, tiles, anti-aliased lines</a> + <ul> + <li><a href="#make-brush"><code>make-brush</code></a> + <li><a href="#make-tile"><code>make-tile</code></a> + <li><a href="#make-anti-aliased"><code>make-anti-aliased</code></a> + </ul> + <li><a href="#transformations">Transformations</a> + <ul> + <li><a href="#with-transformation"><code>with-transformation</code></a> + <li><a href="#without-transformations"><code>without-transformations</code></a> + </ul> + <li><a href="#drawing">Drawing and filling</a> + <ul> + <li><a href="#get-pixel"><code>get-pixel</code></a> + <li><a href="#set-pixel"><code>set-pixel</code></a> + <li><a href="#set-pixels"><code>set-pixels</code></a> + <li><a href="#draw-line"><code>draw-line</code></a> + <li><a href="#draw-rectangle"><code>draw-rectangle</code></a> + <li><a href="#draw-rectangle*"><code>draw-rectangle*</code></a> + <li><a href="#draw-polygon"><code>draw-polygon</code></a> + <li><a href="#draw-filled-circle"><code>draw-filled-circle</code></a> + <li><a href="#draw-filled-ellipse"><code>draw-filled-ellipse</code></a> + <li><a href="#draw-arc"><code>draw-arc</code></a> + <li><a href="#fill-image"><code>fill-image</code></a> + <li><a href="#clipping-rectangle"><code>clipping-rectangle</code></a> + <li><a href="#clipping-rectangle*"><code>clipping-rectangle*</code></a> + <li><a href="#set-clipping-rectangle*"><code>set-clipping-rectangle*</code></a> + <li><a href="#with-clipping-rectangle"><code>with-clipping-rectangle</code></a> + <li><a href="#with-clipping-rectangle*"><code>with-clipping-rectangle*</code></a> + <li><a href="#current-thickness"><code>current-thickness</code></a> + <li><a href="#with-thickness"><code>with-thickness</code></a> + </ul> + <li><a href="#strings">Strings and characters</a> + <ul> + <li><a href="#default-font"><code>*default-font*</code></a> + <li><a href="#with-default-font"><code>with-default-font</code></a> + <li><a href="#draw-character"><code>draw-character</code></a> + <li><a href="#draw-string"><code>draw-string</code></a> + <li><a href="#draw-freetype-string"><code>draw-freetype-string</code></a> + </ul> + <li><a href="#misc">Miscellaneous</a> + <ul> + <li><a href="#do-rows"><code>do-rows</code></a> + <li><a href="#do-pixels-in-row"><code>do-pixels-in-row</code></a> + <li><a href="#do-pixels"><code>do-pixels</code></a> + <li><a href="#raw-pixel"><code>raw-pixel</code></a> + <li><a href="#interlacedp"><code>interlacedp</code></a> + <li><a href="#differentp"><code>differentp</code></a> + <li><a href="#copy-image"><code>copy-image</code></a> + <li><a href="#copy-palette"><code>copy-palette</code></a> + <li><a href="#true-color-to-palette"><code>true-color-to-palette</code></a> + </ul> + <li><a href="#ack">Acknowledgements</a> +</ul> + +   <h3><a href="#contents" name="install" class=none>Download and installation</a></h3> + +CL-GD together with this documentation can be downloaded from <a +href="http://weitz.de/files/cl-gd.tar.gz">http://weitz.de/files/cl-gd.tar.gz</a>. The +current version is 0.5.6. A <a href="http://packages.debian.org/cgi-bin/search_packages.pl?keywords=cl-gd&se…">Debian package</a> is available thanks to <a href="http://pvaneynd.mailworks.org/">Peter van Eynde</a> and <a href="http://b9.com/">Kevin Rosenberg</a>, so if you're on Debian you should have no problems installing CL-GD. There's also a port +for <a href="http://www.gentoo.org/proj/en/common-lisp/index.xml">Gentoo Linux</a> thanks to Matthew Kennedy. Otherwise, proceed like this: +<ul> +<li>Download and install a recent version of <a href="http://www.cliki.net/asdf">asdf</a>. +<li>Download and install <a href="http://uffi.b9.com/">UFFI</a>. CL-GD needs at least version 1.3.4 of UFFI to work properly. However, as of August 2003, only AllegroCL, CMUCL, LispWorks, SBCL, and SCL are fully supported because CL-GD needs the new UFFI macros <a href="http://uffi.b9.com/manual/with-cast-pointer.html"><code>WITH-CAST-POINTER</code></a> and <a href="http://uffi.b9.com/manual/def-foreign-var.html"><code>DEF-FOREIGN-VAR</code></a> which haven't yet been ported to all UFFI platforms. Note: For CLISP or OpenMCL download and install <a +href="http://common-lisp.net/project/cffi/">CFFI</a> instead. +<li>Download and install a recent version of <a href="http://www.boutell.com/gd/">GD</a> and its supporting libraries <a href="http://www.libpng.org/pub/png/">libpng</a>, <a href="http://www.info-zip.org/pub/infozip/zlib/">zlib</a>, <a href="http://www.ijg.org/">libjpeg</a>, <a href="http://www.freetype.org/">libfreetype</a>, and maybe <a href="http://www.gnu.org/software/libiconv/">libiconv</a>. CL-GD has been tested and developed with GD 2.0.28, older version probably won't work. Note that you won't be able to compile CL-GD unless you have installed all supporting libraries. This is different from using GD directly from C where you only have to install the libraries you intend to use. +<li>Download <a href="http://weitz.de/files/cl-gd.tar.gz"><code>cl-gd.tar.gz</code></a>, unzip and untar the file and put the resulting directory wherever you want, then cd into this directory. +<li>Compile <code>cl-gd-glue.c</code> into a shared library for your platform. On FreeBSD or Linux this would be +<pre> +gcc -fPIC -c cl-gd-glue.c +ld -lgd -lz -lpng -ljpeg -lfreetype -lm -shared cl-gd-glue.o -o cl-gd-glue.so +rm cl-gd-glue.o +</pre> +(Note: On older versions of Linux, you might have to add <code>-liconv</code>.) + +For Mac OS X, use +<pre> +gcc -lgd -ljpeg -dynamiclib cl-gd-glue.c -o cl-gd-glue.dylib +</pre> +<li>Make sure that <code>cl-gd.asd</code> can be seen from asdf (this is usually achieved by a symbolic link), start your favorite Lisp, and compile CL-GD: +<pre> +(asdf:oos 'asdf:compile-op :cl-gd) +</pre> +<li>From now on you can simply load CL-GD into a running Lisp image with +<pre> +(asdf:oos 'asdf:load-op :cl-gd) +</pre> +<li>To build without GIF support compile the C library with the option <code>-DGD_DONT_USE_GIF</code> and push the symbol <code>:CL-GD-NO-GIF</code> onto <a href="http://www.lispworks.com/documentation/HyperSpec/Body/v_featur.htm"><code>*FEATURES*</code></a> before compiling CL-GD. + +<li>CL-GD comes with a simple test suite that can be used to check if it's +basically working. Note that this'll only test a subset of CL-GD. To +run the tests load CL-GD and then +<pre> +(asdf:oos 'asdf:load-op :cl-gd-test) +(cl-gd-test:test) +</pre> +If you have the <a +href="http://corefonts.sourceforge.net/"><code>georgiab.ttf</code> +TrueType font from Microsoft</a> you can also check the FreeType +support of CL-GD with +<pre> +(cl-gd-test:test #p"/usr/X11R6/lib/X11/fonts/truetype/georgiab.ttf") +</pre> +where you should obviously replace the path above with the pull path +to the font on your machine. </ul> + +Note that CL-GD might work correctly even if some of the tests fail +(as long as you don't get error messages). The exact results of the +tests seem to depend on the versions of the C libraries which are +used. + +It is recommended that you at least skim over the <a href="http://www.boutell.com/gd/manual2.0.33.html">original GD documentation</a> before you start using CL-GD. + +Note: If you're on Windows you might want to try this: +<ul> +<li>Download and install the supporting libraries (see above) from <a href="http://gnuwin32.sf.net/">GnuWin32</a> and put the DLLs into a place where your Lisp's FFI will find them. The folder where your Lisp image starts up is usually a good place. +<li>Download the file <code>cl-gd-glue.dll</code> from <a href="http://weitz.de/files/cl-gd-glue.dll">http://weitz.de/files/cl-gd-glue.dll</a> and put it into the CL-GD folder. You don't need to download and install GD itself because it's already integrated into <code>cl-gd-glue.dll</code>. +<li>Start your Lisp and compile CL-GD as described above. +</ul> +This works for me on Windows XP pro SP2 with AllegroCL 6.2 trial as well as with LispWorks 4.3.7 pro. + +Luís Oliveira maintains a <a href="http://darcs.net/">darcs</a> +repository of CL-GD +at <a +href="http://common-lisp.net/~loliveira/ediware/">http://common-lisp.net/~loliveira/ediware/</a>. + + +   <h3><a name="mail" class=none>Support and mailing lists</a></h3> + +For questions, bug reports, feature requests, improvements, or patches +please use the <a +href="http://common-lisp.net/mailman/listinfo/cl-gd-devel">cl-gd-devel +mailing list</a>. If you want to be notified about future releases +subscribe to the <a +href="http://common-lisp.net/mailman/listinfo/cl-gd-announce">cl-gd-announce +mailing list</a>. These mailing lists were made available thanks to +the services of <a href="http://common-lisp.net/">common-lisp.net</a>. + +If you want to send patches, please <a href="http://weitz.de/patches.html">read this first</a>. + +   <h3><a href="#contents" name="images" class=none>Images</a></h3> + +In order to work with CL-GD you first have to create at least one +image - think of it as your canvas, kind of. Images can be +created from scratch or you can load an existing image file from +disk. After you've drawn something or otherwise modified your image +you can write it to a file or a stream. Once you're done with it you +must destroy it to avoid memory leaks. It is recommended that +you use the <code>WITH-IMAGE-</code> macros instead of the +<code>CREATE-IMAGE-</code> functions so you can be sure that images +will always be destroyed no matter what happens. + + [Function] + <a class=none name="create-image">create-image width height <tt>&optional</tt> true-color => image</a> + +<blockquote> +Allocates and returns an image with size <code>width</code> <tt>x</tt> <code>height</code> (in pixels). Creates a true color image if +<code>true-color</code> is true - the default is <code>NIL</code>. You are responsible for +<a href="#destroy-image">destroying</a> the image after you're done with it. It is advisable to use +<a href="#with-image"><code>WITH-IMAGE</code></a> instead. +</blockquote> + + [Function] + <a class=none name="create-image-from-file">create-image-from-file file-name <tt>&optional</tt> type => image</a> + +<blockquote> +Creates an image from the file specified by <code>file-name</code> (which is +either a pathname or a string). The type of the image can be provided +as <code>type</code> (one of the keywords <code>:JPG</code>, <code>:JPEG</code>, <code>:GIF</code>, <code>:PNG</code>, <code>:GD</code>, <code>:GD2</code>, <code>:XBM</code>, or <code>:XPM</code>), or otherwise it will be guessed from the <code>PATHNAME-TYPE</code> of +<code>file-name</code>. You are responsible for <a href="#destroy-image">destroying</a> the image after you're +done with it. It is advisable to use <a href="#with-image-from-file"><code>WITH-IMAGE-FROM-FILE</code></a> instead. +</blockquote> + + [Function] + <a class=none name="create-image-from-gd2-part">create-image-from-gd2-part file-name src-x src-y width height => image</a> + +<blockquote> +Creates an image from the part of the GD2 file specified by <code>file-name</code> (which is +either a pathname or a string) specified by <code>src-x</code>, <code>src-y</code>, <code>width</code>, and <code>height</code>. You are responsible for <a href="#destroy-image">destroying</a> the image after you're +done with it. It is advisable to use <a href="#with-image-from-gd2-part"><code>WITH-IMAGE-FROM-GD2-PART</code></a> instead. +</blockquote> + + [Function] + <a class=none name="destroy-image">destroy-image image => result</a> + +<blockquote> +Destroys (deallocates) <code>image</code> which has been created by <a href="#create-image"><code>CREATE-IMAGE</code></a>, +<a href="#create-image-from-file"><code>CREATE-IMAGE-FROM-FILE</code></a>, or <a href="#create-image-from-gd2-part"><code>CREATE-IMAGE-FROM-GD2-PART</code></a>. <code>result</code> is always <code>NIL</code>. +</blockquote> + + [Macro] + <a class=none name="with-image">with-image (name width height <tt>&optional</tt> true-color) form* => results</a> + +<blockquote> +Creates an image as with <a +href="#create-image"><code>CREATE-IMAGE</code></a> and executes +<code>form*</code> with the image bound to +<code>name</code>. The image is +guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits. +</blockquote> + + [Macro] + <a class=none name="with-image-from-file">with-image-from-file (name file-name <tt>&optional</tt> type) form* => results</a> + +<blockquote> +Creates an image as with <a +href="#create-image-from-file"><code>CREATE-IMAGE-FROM-FILE</code></a> and executes +<code>form*</code> with the image bound to +<code>name</code>. The image is +guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits. +</blockquote> + +<pre> +(<a class=noborder href="#with-image-from-file">with-image-from-file</a> (old "zappa.jpg")<img vspace=10 hspace=10 border=0 alt="zappa-green.jpg" title="zappa-green.jpg" src="zappa-green.jpg" width=150 height=200 align=right><img vspace=10 hspace=10 border=0 alt="zappa.jpg" title="zappa.jpg" src="zappa.jpg" width=150 height=200 align=right> + (multiple-value-bind (width height) + (<a class=noborder href="#image-size">image-size</a> old) + (<a class=noborder href="#with-image">with-image</a> (new width height) + (<a class=noborder href="#allocate-color">allocate-color</a> 0 255 0 :image new) ; green background + (<a class=noborder href="#copy-image">copy-image</a> old new 0 0 0 0 width height + :merge 50) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "zappa-green.jpg" + :image new + :if-exists :supersede)))) +</pre> + + [Macro] + <a class=none name="with-image-from-gd2-part">with-image-from-gd2-part (name file-name src-x src-y width height) form* => results</a> + +<blockquote> +Creates an image as with <a +href="#create-image-from-gd2-part"><code>CREATE-IMAGE-FROM-GD2-PART</code></a> and executes +<code>form*</code> with the image bound to +<code>name</code>. The image is +guaranteed to be <a href="#destroy-image">destroyed</a> before this macro exits. +</blockquote> + + [Special variable] + <a class=none name="default-image">*default-image*</a> + +<blockquote> +Whenever a CL-GD function or macro has an optional or keyword argument called image the default is to use <code>*default-image*</code>. The idea behind this is that you'll never have to provide these arguments as long as you work with one image at a time (which should be the usual case). See the <a href="#example">example</a> at the top of the page. +</blockquote> + + [Macro] + <a class=none name="with-default-image">with-default-image (image) form* => results</a> + +<blockquote> +This is just a convenience macro which will execute <code>form*</code> with <a href="#default-image"><code>*DEFAULT-IMAGE*</code></a> bound to <code>image</code>. +</blockquote> + + + [Macro] + <a class=none name="with-image*">with-image* (width height <tt>&optional</tt> true-color) form* => results</a> + [Macro] + <a class=none name="with-image-from-file*">with-image-from-file* (file-name <tt>&optional</tt> type) form* => results</a> + [Macro] + <a class=none name="with-image-from-gd2-part*">with-image-from-gd2-part* (file-name src-x src-y width height) form* => results</a> + +<blockquote> +These are essentially like their asterisk-less counterparts but bind the image to <a href="#default-image"><code>*DEFAULT-IMAGE*</code></a> instead. +</blockquote> + + + +For the rest of this document, whenever a function expects an image as +one of its arguments you must pass a value which was created +with one of the functions or macros above. An image should be +considered an opaque object which you can pass to CL-GD functions but +should otherwise leave alone. (Internally it is a foreign pointer +wrapped in a <code>CL-GD::IMAGE</code> structure in order to enable +type checking.) + + [Function] + <a class=none name="write-jpeg-to-stream">write-jpeg-to-stream stream <tt>&key</tt> quality image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a JPEG file. If +<code>quality</code> is not specified, the default <a href="http://www.ijg.org/">IJG</a> JPEG +quality value is used. Otherwise, +<code>quality</code> must be an integer in the range 0-100. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-png-to-stream">write-png-to-stream stream <tt>&key</tt> compression-level image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a PNG file. If +<code>compression-level</code> is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of 1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-wbmp-to-stream">write-wbmp-to-stream stream <tt>&key</tt> foreground image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a WBMP (wireless bitmap) file. WBMP file support is black and white +only. The <a href="#colors">color</a> specified by the <code>foreground</code> argument is the +"foreground," and only pixels of this color will be set in the WBMP +file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-gd-to-stream">write-gd-to-stream stream <tt>&key</tt> image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a GD file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-gif-to-stream">write-gif-to-stream stream <tt>&key</tt> image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a GIF file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-gd2-to-stream">write-gd2-to-stream stream <tt>&key</tt> image => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code> as a GD2 file. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-image-to-stream">write-image-to-stream stream type <tt>&key</tt> <tt>&allow-other-keys</tt> => image</a> + +<blockquote> +Writes image <code>image</code> to the stream +<code>stream</code>. The type of the image is determined by <code>type</code> +which must be one of the keywords <code>:JPG</code>, <code>:JPEG</code>, <code>:GIF</code>, <code>:PNG</code>, <code>:WBMP</code>, <code>:GD</code>, or <code>:GD2</code>. The rest of the keyword arguments are handed over to the corresponding <code>WRITE-XXX-TO-STREAM</code> function. <code>stream</code> must be a character stream or a binary +stream of element type <code>(UNSIGNED-BYTE 8)</code>. If STREAM is a character +stream, the user of this function has to make sure the external format +yields <a href="http://cl-cookbook.sf.net/io.html#faith">faithful output</a> of all 8-bit characters. CL-GD knows about AllegroCL's <a href="http://www.franz.com/support/documentation/6.2/doc/streams.htm">simple streams</a> and the bivalent streams of <a href="http://www.lispworks.com/">LispWorks</a> 4.3 and acts accordingly, i.e. it uses <code>WRITE-BYTE</code> instead of <code>WRITE-CHAR</code> whenever possible. +</blockquote> + + [Function] + <a class=none name="write-image-to-file">write-image-to-file file-name <tt>&key</tt> type if-exists <tt>&allow-other-keys</tt> => image</a> + +<blockquote> +Writes image <code>image</code> to the file specified by <code>file-name</code> (which is +either a pathname or a string). The <code>type</code> argument is interpreted as in <a href="#write-image-to-stream"><code>WRITE-IMAGE-TO-STREAM</code></a>. If it is not provided it will be guessed from the <code>PATHNAME-TYPE</code> of +<code>file-name</code>. The <code>if-exists</code> keyword argument is given to <a href="http://www.lispworks.com/documentation/HyperSpec/Body/f_open.htm"><code>OPEN</code></a>, +the rest of the keyword arguments are handed over to the corresponding <code>WRITE-XXX-TO-STREAM</code> function. +</blockquote> + + [Function] + <a class=none name="image-width">image-width <tt>&optional</tt> image => width</a> + +<blockquote> +Returns the width of the image <code>image</code>. The result of this function is affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Function] + <a class=none name="image-height">image-height <tt>&optional</tt> image => height</a> + +<blockquote> +Returns the height of the image <code>image</code>. The result of this function is affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Function] + <a class=none name="image-size">image-size <tt>&optional</tt> image => width, height</a> + +<blockquote> +Returns the width and height of the image <code>image</code> as two values. The results of this function are affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + +   <h3><a href="#contents" name="colors" class=none>Colors</a></h3> + +Images in CL-GD are usually palette-based (although true color images +are also supported) and colors have to be <a +href="#allocate-color">allocated</a> before they can be used, i.e. whenever a function expects a color as +one of its arguments you must pass a value which was created +with one of the functions below or with a 'special' color as described in the <a href="#brushes">next section</a>. + +Colors +are determined by specifying values for their red, green, blue, and +optionally alpha <a href="#color-component">components</a>. The first +three have to be integer values in the range 0-255 while the last +one has to be in the range 0-127. For a palette-based image the +first color you allocate will be its background color. Note that +colors are allocated per image, i.e. you can't allocate a color in one +image and then use it to draw something in another image. + +See also the <a href="#brushes">next section</a> for some 'special colors.' + + [Special variable] + <a class=none name="default-color">*default-color*</a> + +<blockquote> +Whenever a CL-GD function or macro has an optional or keyword argument called color the default is to use <code>*default-color*</code>. See <a href="#with-default-color"><code>WITH-DEFAULT-COLOR</code></a> below. +</blockquote> + + [Macro] + <a class=none name="with-default-color">with-default-color (color) form* => results</a> + +<blockquote> +This is just a convenience macro which will execute <code>form*</code> with <a href="#default-color"><code>*DEFAULT-COLOR*</code></a> bound to <code>color</code>. +</blockquote> + + [Function] + <a class=none name="allocate-color">allocate-color red green blue <tt>&key</tt> alpha errorp image => color</a> + +<blockquote> +Finds the first available color index in the image <code>image</code> specified, +sets its RGB values to those requested (255 is the maximum for each), +and returns the index of the new color table entry, or an RGBA value in +the case of a true color image. In either case you can then use the +returned value as a color parameter to drawing functions. When +creating a new palette-based image, the first time you invoke this +function you are setting the background color for that image. If +<code>alpha</code> (not greater than 127) is provided, an RGBA color will always +be allocated. If all <a href="#max-colors"><code>+MAX-COLORS+</code></a> have already been allocated this +function will, depending on the value of <code>errorp</code>, either raise an error +or return <code>NIL</code>. The default is to raise an error. +</blockquote> + + [Function] + <a class=none name="find-color">find-color red green blue <tt>&key</tt> alpha exact hwb resolve image => color</a> + +<blockquote> +Tries to find and/or allocate a color from <code>image</code>'s color +palette. If <code>exact</code> is true, the color will only be returned if it is +already allocated. If <code>exact</code> is false, a color which is 'close' to +the color specified by <code>red</code>, <code>green</code>, and <code>blue</code> (and probably <code>alpha</code>) +might be returned (unless there aren't any colors allocated in the +image yet). If <code>hwb</code> is true, the 'closeness' will be determined by hue, +whiteness, and blackness, otherwise by the Euclidian distance of the +RGB values. If <code>resolve</code> is true a color (probably a new one) will +always be returned, otherwise the result of this function might be +<code>NIL</code>. If <code>alpha</code> (not greater than 127) is provided, an RGBA color (or +<code>NIL</code>) will be returned. +<code>alpha</code>, <code>exact</code>, and <code>hwb</code> are mutually exclusive. <code>resolve</code> can't be used +together with <code>exact</code> or <code>hwb</code>. +</blockquote> + + [Function] + <a class=none name="find-color-from-image">find-color-from-image color source-image <tt>&key</tt> alpha exact hwb resolve image => color</a> + +<blockquote> +Tries to find and/or allocate a color from <code>image</code>'s color +palette that corresponds to <code>color</code> in <code>source-image</code>. +<code>find-color-from-image</code> calls <a href="#find-color"><code>find-color</code></a> +with the color components of <code>color</code>. +Refer to <a href="#find-color"><code>find-color</code></a> for a description of the +keyword arguments. +</blockquote> + + [Function] + <a class=none name="color-component">color-component color component <tt>&key</tt> image => component</a> + +<blockquote> +Returns the specified color component of <code>color</code>. <code>component</code> can be +one of <code>:RED</code>, <code>:GREEN</code>, <code>:BLUE</code>, and <code>:ALPHA</code>. +</blockquote> + + [Function] + <a class=none name="color-components">color-components color <tt>&key</tt> image => components</a> + +<blockquote> +Returns the color components of <code>color</code> as a list. The components are in the +order red, green, blue, alpha. +</blockquote> + +<pre> +* (defun foo () + (<a class=noborder href="#with-image*">with-image*</a> (10 10) + (loop for i below <a class=noborder href="#max-colors">+max-colors+</a> do + ;; allocate enough colors (all gray) to fill the palette + (<a class=noborder href="#allocate-color">allocate-color</a> i i i)) + (format t "Number of colors allocated: ~A~%" (<a class=noborder href="#number-of-colors">number-of-colors</a>)) + (format t "Maximal number of colors: ~A~%" <a class=noborder href="#max-colors">+max-colors+</a>) + (format t "Exact match for red: ~A~%" (<a class=noborder href="#find-color">find-color</a> 255 0 0 :exact t)) + (format t "Red, green, and blue components of 'closest' match for red: ~A~%" + (let ((match (<a class=noborder href="#find-color">find-color</a> 255 0 0))) + (if match + (list (<a class=noborder href="#color-component">color-component</a> :red match) + (<a class=noborder href="#color-component">color-component</a> :green match) + (<a class=noborder href="#color-component">color-component</a> :blue match)))))) + (values)) + +FOO +* (foo) +Number of colors allocated: 256 +Maximal number of colors: 256 +Exact match for red: NIL +Red, green, and blue components of 'closest' match for red: (64 64 64) +</pre> + + [Function] + <a class=none name="deallocate-color">deallocate-color color <tt>&optional</tt> image => color</a> + +<blockquote> +Marks the specified color <code>color</code> as being available for reuse. No +attempt will be made to determine whether the color index is still in +use in the image <code>image</code>. +</blockquote> + + [Function] + <a class=none name="true-color-p">true-color-p <tt>&optional</tt> image => result</a> + +<blockquote> +Returns true iff <code>image</code> is a true color image. +</blockquote> + + [Function] + <a class=none name="number-of-colors">number-of-colors <tt>&optional</tt> image => result</a> + +<blockquote> +Returns the number of colors allocated in <code>image</code> or NIL if <code>image</code> is a true color image. +</blockquote> + + [Constant] + <a class=none name="max-colors">+max-colors+</a> + +<blockquote> +Maximum number of colors for palette-based images. +</blockquote> + + [Accessor] + <a class=none name="transparent-color">transparent-color <tt>&optional</tt> image => color + (setf (transparent-color <tt>&optional</tt> image) color)</a> + +<blockquote> +Gets and sets the transparent color of <code>image</code>. If <code>color</code> is <code>NIL</code> there is no transparent color. +</blockquote> + + [Accessor] + <a class=none name="alpha-blending-p">alpha-blending-p <tt>&optional</tt> image => blending + (setf (alpha-blending-p <tt>&optional</tt> image) blending)</a> + +<blockquote> +Gets and set whether pixels drawn on <code>image</code> will be copied literally +including alpha channel information (if <code>blending</code> is false) or if +their alpha channel information will determine how much of the +underlying color will shine through (if <code>blending</code> is true). This is +only meaningful for true color images. +</blockquote> + + [Accessor] + <a class=none name="save-alpha-p">save-alpha-p <tt>&optional</tt> image => save + (setf (save-alpha-p <tt>&optional</tt> image) save)</a> + +<blockquote> +Gets and sets whether PNG images will be saved with full alpha channel information. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (200 100)<img vspace=10 hspace=10 border=0 alt="brushed-arc.png" title="brushed-arc.png" src="brushed-arc.png" width=200 height=100 align=right> + (<a class=noborder href="#allocate-color">allocate-color</a> 255 165 0) ; orange background + (<a class=noborder href="#with-image">with-image</a> (brush 6 6) + (let* ((black (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0 :image brush)) ; black background + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0 :image brush)) + (blue (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 255 :image brush))) + (setf (<a class=noborder href="#transparent-color">transparent-color</a> brush) black) ; make background transparent + ;; now set the pixels in the brush + (<a class=noborder href="#set-pixels">set-pixels</a> '(2 2 2 3 3 2 3 3) + :color blue :image brush) + (<a class=noborder href="#set-pixels">set-pixels</a> '(3 2 3 3 1 2 1 3 4 2 4 3 2 1 3 1 2 4 3 4) + :color red :image brush) + ;; then use it to draw an arc + (<a class=noborder href="#draw-arc">draw-arc</a> 100 50 180 80 180 300 + ;; convert BRUSH to brush + :color (<a class=noborder href="#make-brush">make-brush</a> brush))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "brushed-arc.png" + :compression-level 7 + :if-exists :supersede))) +</pre> + +   <h3><a href="#contents" name="brushes" class=none>Styles, brushes, tiles, anti-aliased lines</a></h3> + +Most <a href="#drawing">drawing</a> and <a href="#strings">string</a> +functions (with <a +href="#draw-freetype-string"><code>DRAW-FREETYPE-STRING</code></a> +being the only exception) will, when expecting a <a +href="#colors">color</a>, also accept other types of arguments. The +full range of allowed types which can be used for +<code>color</code> keyword arguments is listed below: + +<ul> + <li>A style which is either a list or a vector of colors + allocated with one of the functions described above or + <code>NIL</code> for transparent colors. When a style is used as the + color, the colors of the pixels are drawn successively from the + sequence provided. If the corresponding element of the sequence is + <code>NIL</code>, that pixel is not altered. + + <li>A brush as created with <a + href="#make-brush"><code>MAKE-BRUSH</code></a> for drawing lines. A + brush is itself an <a href="#images">image</a> created as described + above. When a brush is used as the color, the brush image is drawn + in place of each pixel of the line drawn. (The brush is usually + larger than one pixel, creating the effect of a wide paintbrush.) + + <li>A tile as created with <a + href="#make-tile"><code>MAKE-TILE</code></a> for filling regions. A + tile is itself an <a href="#images">image</a> created as described + above. When a tile is used as the color, a pixel from the tile image + is selected in such a way as to ensure that the filled area will be + tiled with copies of the tile image. + + <li>A <code>CONS</code> where the <code>CAR</code> is a brush and + the <code>CDR</code> is a list or a vector. This is called a + styled brush. When a styled brush is used as the color, the + brush image is drawn at each pixel of the line, provided that the + corresponding element of the style sequence is true. + (Pixels are drawn successively from the style as the line is drawn, + returning to the beginning when the available pixels in the style + are exhausted.) Note that the semantics described here differ + slightly from the styles described above. + + <li>An anti-aliased color as created with <a + href="#make-anti-aliased"><code>MAKE-ANTI-ALIASED</code></a> for + drawing lines. When an anti-aliased color is used, the line is drawn + with anti-aliasing mechanisms to minimize any "jagged" + appearance. + + <li>A 'normal' color as created with one of the functions from the + <a href="#colors">previous section</a>. + +</ul> + +Note that you can't arbitrarily combine 'color types' and drawing +functions, e.g. you can't set an anti-aliased pixel. However, it +should generally be obvious which types make sense and which don't. +Check the <a +href="http://www.boutell.com/gd/manual2.0.15.html">original GD +documentation</a> for more details. + +In GD itself, if you, say, change a brush after you've 'set' it with +<a +href="http://www.boutell.com/gd/manual2.0.15.html#gdImageSetBrush"><code>gdImageSetBrush</code></a> +but before you actually use it for drawing these changes won't be +visible, i.e. the brush is 'frozen' once it's 'set.' The same applies +to tiles and styles. CL-GD's behaviour differs in this regard, +i.e. brushes, tiles, and styles are 'set' at the very moment they're +used. This introduces a little bit of overhead but feels more 'Lisp-y' +and intuitive to me. + + [Function] + <a class=none name="make-brush">make-brush image => brush</a> + +<blockquote> + +Creates a <a href="#brushes">brush</a> from the <a +href="#images">image</a> <code>image</code>. Note that the new +brush is still 'linked' to <code>image</code>, i.e. changes you +make to <code>image</code> will also be visible in the +brush - the brush is just a kind of 'tagged' image. + +</blockquote> + + [Function] + <a class=none name="make-tile">make-tile image => tile</a> + +<blockquote> + +Creates a <a href="#brushes">tile</a> from the <a +href="#images">image</a> <code>image</code>. Note that the new +tile is still 'linked' to <code>image</code>, i.e. changes you +make to <code>image</code> will also be visible in the +tile - the tile is just a kind of 'tagged' image. + +</blockquote> + + [Function] + <a class=none name="make-anti-aliased">make-anti-aliased color <tt>&optional</tt>do-not-blend => color'</a> + +<blockquote> + +Creates an <a href="#brushes">anti-aliased color</a> from the +<a href="#colors">color</a> +<code>color</code>. <code>do-not-blend</code> (if provided) is the +color anti-aliased lines stand out against clearly. + +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (150 50)<img vspace=10 hspace=10 border=0 alt="anti-aliased-lines.png" title="anti-aliased-lines.png" src="anti-aliased-lines.png" width=150 height=50 align=right> + (let ((orange (<a class=noborder href="#allocate-color">allocate-color</a> 255 165 0)) ; orange background + (white (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0))) + ;; white background rectangle in the middle third + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 50 0 99 49 + :filled t + :color white) + (<a class=noborder href="#with-thickness">with-thickness</a> (2) + ;; just a red line + (<a class=noborder href="#draw-line">draw-line</a> 5 10 145 10 :color red) + ;; anti-aliased red line + (<a class=noborder href="#draw-line">draw-line</a> 5 25 145 25 :color (<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> red)) + ;; anti-aliased red line which should stand out against + ;; orange background + (<a class=noborder href="#draw-line">draw-line</a> 5 40 145 40 :color (<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> red orange)))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "anti-aliased-lines.png" + :compression-level 3 + :if-exists :supersede)) +</pre> + +   <h3><a href="#contents" name="transformations" class=none>Transformations</a></h3> + +Usually, CL-GD coordinates and dimensions (width and height) have to be integers. The origin <code>(0,0)</code> of an <a href="#images">image</a> is its upper left corner and all other points like <code>(X,Y)</code> have positive <code>X</code> and <code>Y</code> values. Angles are also provided as integers (in the range 0-360) meaning degrees. A transformation provides a way to change this. + + [Macro] + <a class=none name="with-transformation">with-transformation (<tt>&key</tt> x1 x2 width y1 y2 height reverse-x reverse-y radians image) form* => results</a> + +<blockquote> +Executes <code>form*</code> such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of <code>image</code> will start at <code>x1</code> and end at <code>x2</code> and +have length <code>width</code>. The new y-axis of <code>image</code> will start at <code>y1</code> and end at +<code>y2</code> and have length <code>height</code>. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +<code>reverse-x</code> is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to <code>reverse-y</code>, of course. If <code>radians</code> is true angles inside of +the macro's body will be assumed to be provided in radians, otherwise in degrees. The previous transformation (if any) will be restored before this macro exits. + +<code>with-transformation</code> macros can be nested but they always transform the original coordinates of the image, i.e. you shouldn't expect that, say, two succesive applications of <code>reverse-x</code> will neutralize each other. There's a little bit of overhead involved with this macro, so it is recommended to wrap it around everything you do with an image instead of calling it repeatedly. Note that transformations are always bound to one particular image. +</blockquote> + + [Macro] + <a class=none name="without-transformations">without-transformations form* => results</a> + +<blockquote> +Executes <code>form*</code> without any transformations applied. +</blockquote> + +   <h3><a href="#contents" name="drawing" class=none>Drawing and filling</a></h3> + +This section (and the next one about <a href="#strings">strings</a>) finally describes how you can actually change the visual appearance of an <a href="#images">image</a>. You can set single pixels, draw lines or geometric figures, and fill regions. Note that the current <a href="#transformations">transformation</a> (if any) applies to the input and output of these functions. + + [Function] + <a class=none name="get-pixel">get-pixel x y <tt>&key</tt> image => color</a> + +<blockquote> +Returns the <a href="#colors">color</a> of the pixel specified by <code>x</code> and <code>y</code>. +</blockquote> + + [Function] + <a class=none name="set-pixel">set-pixel x y <tt>&key</tt> color image => x, y</a> + +<blockquote> +Sets the pixel specified by <code>x</code> and <code>y</code> to the <a href="#colors">color</a> specified by <code>color</code>. +</blockquote> + + [Generic function] + <a class=none name="set-pixels">set-pixels points <tt>&key</tt> color image => points</a> + +<blockquote> +Sets the pixels specified by <code>points</code> which can be a list <code>(X1 Y1 X2 Y2 ...)</code> or a vector <code>#(X1 Y1 X2 Y2 ...)</code> to the <a href="#colors">color</a> specified by <code>color</code>. +</blockquote> + + [Function] + <a class=none name="draw-line">draw-line x1 y1 x2 y2 <tt>&key</tt> color image => x1, y1, x2, y2</a> + +<blockquote> +Draws a line with <a href="#colors">color</a> <code>color</code> from point <code>(x1,y1)</code> to point <code>(x2,y2)</code>. +</blockquote> + + [Function] + <a class=none name="draw-rectangle">draw-rectangle rectangle <tt>&key</tt> filled color image => rectangle</a> + +<blockquote> +Draws a rectangle with upper left corner <code>(X1,Y1)</code> and lower right corner <code>(X2,Y2)</code> where <code>rectangle</code> is the list <code>(X1 Y2 X2 Y2)</code>. If <code>filled</code> is true the rectangle will be filled with <code>color</code>, otherwise it will be outlined. +</blockquote> + + [Function] + <a class=none name="draw-rectangle*">draw-rectangle* x1 y1 x2 y2 <tt>&key</tt> filled color image => x1, y1, x2, y2</a> + +<blockquote> +Draws a rectangle with upper left corner <code>(x1,y1)</code> and lower right corner <code>(x2,y2)</code>. If <code>filled</code> is true the rectangle will be filled with <code>color</code>, otherwise it will be outlined. +</blockquote> + + [Generic function] + <a class=none name="draw-polygon">draw-polygon vertices <tt>&key</tt> filled start end color image => vertices</a> + +<blockquote> +Draws a polygon with the vertices (at least three) +specified as a list <code>(X1 Y1 X2 Y2 ...)</code> or as a vector <code>#\(X1 Y1 X2 Y2 ...)</code>. +If <code>filled</code> is true the polygon will be filled with the <a href="#colors">color</a> <code>color</code>, +otherwise it will be outlined. If <code>start</code> and/or <code>end</code> are specified then +only the corresponding part of <code>vertices</code> is used as input. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (100 100)<img vspace=10 hspace=10 border=0 alt="triangle.png" title="triangle.png" src="triangle.png" width=100 height=100 align=right> + (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255) ; white background + (let ((red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0)) + (yellow (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 0)) + (orange (<a class=noborder href="#allocate-color">allocate-color</a> 255 165 0))) + ;; thin black border + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 0 0 99 99 + :color (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0)) + ;; line thickness is five pixels + (<a class=noborder href="#with-thickness">with-thickness</a> (5) + ;; triangle + (<a class=noborder href="#draw-polygon">draw-polygon</a> (list 10 10 90 50 50 90) + ;; styled color + :color (list red red red + yellow yellow yellow + nil nil nil + orange orange orange)) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "triangle.png" + :compression-level 8 + :if-exists :supersede)))) +</pre> + + [Function] + <a class=none name="draw-filled-circle">draw-filled-circle center-x center-y radius <tt>&key</tt> color image => center-x center-y radius</a> + +<blockquote> +Draws a filled circle with center <code>(center-x,center-y)</code> and radius <code>radius</code>. +</blockquote> + + [Function] + <a class=none name="draw-filled-ellipse">draw-filled-ellipse center-x center-y width height <tt>&key</tt> color image => center-x center-y width height</a> + +<blockquote> +Draws a filled ellipse with center <code>(center-x,center-y)</code>, width <code>width</code>, and height <code>height</code>. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (250 150) + (<a class=noborder href="#with-image-from-file">with-image-from-file</a> (zappa "smallzappa.png")<img vspace=10 hspace=0 border=0 alt="zappa-ellipse.png" title="zappa-ellipse.png" src="zappa-ellipse.png" width=250 height=150 align=right> + (setf (<a class=noborder href="#transparent-color">transparent-color</a>) (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (<a class=noborder href="#draw-filled-ellipse">draw-filled-ellipse</a> 125 75 250 150 + :color (<a class=noborder href="#make-tile">make-tile</a> zappa))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "zappa-ellipse.png" + :if-exists :supersede)) +</pre> + + [Function] + <a class=none name="draw-arc">draw-arc center-x center-y width height start end <tt>&key</tt> straight-line center-connect filled color image => center-x, center-y, width, height, start, end</a> + +<blockquote> +Draws a partial ellipse centered at <code>(center-x,center-y)</code> with +width <code>width</code> and height <code>height</code>. The arc begins at angle <code>start</code> and ends +at angle <code>end</code>. If <code>straight-line</code> is true the start and end points are +just connected with a straight line. If <code>center-connect</code> is true, they +are connected to the center (which is useful to create 'pie +slices' - see <a href="#example">example</a> at the top of the page.). If <code>filled</code> is true the arc will be filled with the <a href="#colors">color</a> <code>color</code>, otherwise it will be outlined. +</blockquote> + + [Function] + <a class=none name="fill-image">fill-image x y <tt>&key</tt> border color image => x, y</a> + +<blockquote> +Floods a portion of the <a href="#images">image</a> <code>image</code> with the <a href="#colors">color</a> <code>color</code> beginning +at point <code>(x,y)</code> and extending into the surrounding region. If <code>border</code> +is true it must be a <a href="#colors">color</a> and the filling will stop at the specified +border color. (You can't use <a href="#brushes">'special colors'</a> for the border color.) Otherwise only points with the same color as the +starting point will be colored. If <code>color</code> is a <a href="#brushes">tile</a> the tile must not have a <a href="#transparent-color">transparent</a> color. +</blockquote> + + [Accessor] + <a class=none name="clipping-rectangle">clipping-rectangle <tt>&optional</tt> image => rectangle + (setf (clipping-rectangle <tt>&optional</tt> image) rectangle)</a> + +<blockquote> +Gets and sets the clipping rectangle of <code>image</code> where <code>rectangle</code> should be a +list <code>(X1 Y1 X2 Y2)</code> describing the upper left and lower right corner of the rectangle. Once a clipping rectangle has been set, all future drawing operations on <code>image</code> will remain within the specified clipping area, until a new clipping rectangle is established. For instance, if a clipping rectangle <code>(25 25 75 75)</code> has been set within a 100x100 image, a diagonal line from <code>(0,0)</code> to <code>(99,99)</code> will appear only between <code>(25,25)</code> and <code>(75,75)</code>. See also <a href="#clipping-rectangle*"><code>CLIPPING-RECTANGLE*</code></a> and <a href="#set-clipping-rectangle*"><code>SET-CLIPPING-RECTANGLE*</code></a>. +</blockquote> + + [Function] + <a class=none name="clipping-rectangle*">clipping-rectangle* <tt>&optional</tt> image => x1, y1, x2, y2</a> + +<blockquote> +Returns the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> as four values. +</blockquote> + + [Function] + <a class=none name="set-clipping-rectangle*">set-clipping-rectangle* x1 y1 x2 y2 <tt>&optional</tt> image => x1, y1, x2, y2</a> + +<blockquote> +Sets the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> as if set with <code>(SETF (<a href="#clipping-rectangle"><code>CLIPPING-RECTANGLE</code></a> IMAGE) (LIST X1 Y1 X2 Y2))</code>. +</blockquote> + + [Macro] + <a class=none name="with-clipping-rectangle">with-clipping-rectangle (rectangle <tt>&key</tt> image) form* => results</a> + +<blockquote> +Executes <code>form*</code> with the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> set to <code>rectangle</code> +which should be a list as in <a href="#clipping-rectangle"><code>CLIPPING-RECTANGLE</code></a>. The previous clipping rectangle +is guaranteed to be restored before the macro exits. +</blockquote> + + [Macro] + <a class=none name="with-clipping-rectangle*">with-clipping-rectangle* (x1 y1 x2 y2 <tt>&key</tt> image) form* => results</a> + +<blockquote> +Executes <code>form*</code> with the <a href="#clipping-rectangle">clipping rectangle</a> of <code>image</code> set as if set with <code>(SETF (<a href="#clipping-rectangle"><code>CLIPPING-RECTANGLE</code></a> IMAGE) (LIST X1 Y1 X2 Y2))</code>. The previous clipping rectangle +is guaranteed to be restored before the macro exits. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (150 150)<img vspace=10 hspace=10 border=0 alt="clipped-tangent.png" title="clipped-tangent.png" src="clipped-tangent.png" width=150 height=150 align=right> + (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255) ; white background + ;; transform such that x axis ranges from (- PI) to PI and y + ;; axis ranges from -3 to 3 + (<a class=noborder href="#with-transformation">with-transformation</a> (:x1 (- pi) :width (* 2 pi) :y1 -3 :y2 3) + (let ((black (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0)) + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0)) + (rectangle (list (- .4 pi) 2.5 (- pi .4) -2.5))) + (<a class=noborder href="#with-default-color">with-default-color</a> (black) + ;; draw axes + (<a class=noborder href="#draw-line">draw-line</a> 0 -3 0 3 :color black) + (<a class=noborder href="#draw-line">draw-line</a> (- pi) 0 pi 0)) + ;; show clipping rectangle (styled) + (<a class=noborder href="#draw-rectangle">draw-rectangle</a> rectangle :color (list black black black nil black nil)) + (<a class=noborder href="#with-clipping-rectangle">with-clipping-rectangle</a> (rectangle) + ;; draw tangent function + (loop for x from (- pi) below (* 2 pi) by (/ pi 75) do + (<a class=noborder href="#set-pixel">set-pixel</a> x (tan x) :color red))))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "clipped-tangent.png" + :if-exists :supersede)) +</pre> + + [Accessor] + <a class=none name="current-thickness">current-thickness <tt>&optional</tt> image => thickness + (setf (current-thickness <tt>&optional</tt> image) thickness)</a> + +<blockquote> +Get and sets the current thickness of <code>image</code> in pixels. This determines the width of lines drawn with the <a href="#drawing">drawing</a> functions. <code>thickness</code> has to be an integer. See also <a href="#with-thickness"><code>WITH-THICKNESS</code></a>. +</blockquote> + + [Macro] + <a class=none name="with-thickness">with-thickness (thickness <tt>&key</tt> image) form* => results</a> + +<blockquote> +Executes <code>form*</code> with the <a href="#current-thickness">current thickness</a> of <code>image</code> set to <code>thickness</code>. The image's previous thickness is guaranteed to be restored +before the macro exits. +</blockquote> + +   <h3><a href="#contents" name="strings" class=none>Characters and strings</a></h3> + +CL-GD (actually GD) comes with five included fonts which can be accessed with the keywords <code>:TINY</code>, <code>:SMALL</code>, <code>:MEDIUM</code>, <code>:MEDIUM-BOLD</code> (a synonym for <code>:MEDIUM</code>), <code>:LARGE</code>, and <code>:GIANT</code> and used with <a href="#draw-string"><code>DRAW-STRING</code></a> and <a href="#draw-character"><code>DRAW-CHARACTER</code></a>. Using these fonts will make your application portable to all platforms supported by CL-GD (and thus GD). You can also invoke the <a href="http://www.freetype.org/">FreeType library</a> to draw (anti-aliased) strings with arbitrary TrueType fonts, sizes, and angles. This is, however, subject to the availability and location of the corresponding fonts on your target platform. + + [Special variable] + <a class=none name="default-font">*default-font*</a> + +<blockquote> +Whenever a CL-GD string or character function has an optional or keyword argument called font or font-name the default is to use <code>*default-font*</code>. See <a href="#with-default-font"><code>WITH-DEFAULT-FONT</code></a> below. +</blockquote> + + [Macro] + <a class=none name="with-default-font">with-default-font (font) form* => results</a> + +<blockquote> +This is just a convenience macro which will execute <code>form*</code> with <a href="#default-font"><code>*DEFAULT-FONT*</code></a> bound to <code>font</code>. But +note that the fonts used for <a href="#draw-string"><code>DRAW-STRING</code></a>/<a href="#draw-character"><code>DRAW-CHARACTER</code></a> and <a href="#draw-freetype-string"><code>DRAW-FREETYPE-STRING</code></a> are incompatible +</blockquote> + + [Function] + <a class=none name="draw-character">draw-character x y char <tt>&key</tt> up font color image => char</a> + +<blockquote> +Draws the character <code>char</code> from font <code>font</code> in color <code>color</code> at position <code>(x,y)</code>. If +<code>up</code> is true the character will be drawn from bottom to top (rotated 90 degrees). <code>font</code> must be one of the keywords listed <a href="#strings">above</a>. +</blockquote> + + [Function] + <a class=none name="draw-string">draw-string x y string <tt>&key</tt> up font color image => string</a> + +<blockquote> +Draws the string <code>string</code> in color <code>color</code> at position <code>(y,y)</code>. If +<code>up</code> is true the string will be drawn from bottom to top (rotated 90 degrees). <code>font</code> must be one of the keywords listed <a href="#strings">above</a>. +</blockquote> + + [Function] + <a class=none name="draw-freetype-string">draw-freetype-string x y string <tt>&key</tt> anti-aliased point-size angle convert-chars line-spacing font-name do-not-draw color image => bounding-rectangle</a> + +<blockquote> +Draws the string <code>string</code> in <a href="#colors">color</a> <code>color</code> at position <code>(x,y)</code> using the +<a href="http://www.freetype.org/">FreeType</a> library. <code>font-name</code> is the full path (a pathname or a string) +to a TrueType font file, or a font face name if the <code>GDFONTPATH</code> +environment variable or FreeType's <code>DEFAULT_FONTPATH</code> variable have been +set intelligently. The string may be arbitrarily scaled (<code>point-size</code>) +and rotated (<code>angle</code> in radians). The direction of rotation is +counter-clockwise, with 0 radians (0 degrees) at 3 o'clock and <code>(/ PI 2)</code> radians (90 degrees) at 12 o'clock. Note that the <code>angle</code> argument is +purposefully not affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. If <code>anti-aliased</code> if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +<code>line-spacing</code>, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like "&#192;". If <code>convert-chars</code> is true (which is the default) +characters of <code>string</code> with <code>CHAR-CODE</code> greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's <code>CHAR-CODE</code> +function returns ISO/IEC 10646 (Unicode) character codes. + +The return value is an array containing 8 elements representing +the 4 corner coordinates (lower left, lower right, upper right, upper left) of the bounding rectangle around the +string that was drawn. The points are relative to the text regardless +of the angle, so "upper left" means in the top left-hand +corner seeing the text horizontally. Set <code>do-not-draw</code> +to true to get the bounding +rectangle without rendering. This is a relatively cheap operation if +followed by a rendering of the same string, because of the caching of +the partial rendering during bounding rectangle calculation. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> (200 200)<img vspace=0 hspace=0 border=0 alt="strings.png" title="strings.png" src="strings.png" width=200 height=200 align=right> + ;; set background (white) and make it transparent + (setf (<a class=noborder href="#transparent-color">transparent-color</a>) + (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (loop for angle from 0 to (* 2 pi) by (/ pi 6) + for blue downfrom 255 by 20 do + (<a class=noborder href="#draw-freetype-string">draw-freetype-string</a> 100 100 "Common Lisp" + :font-name "/usr/X11R6/lib/X11/fonts/truetype/georgia.ttf" + :angle angle + ;; note that ALLOCATE-COLOR won't work + ;; here because the anti-aliasing uses + ;; up too much colors + :color (<a class=noborder href="#find-color">find-color</a> 0 0 blue + :resolve t))) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "strings.png" + :if-exists :supersede)) +</pre> + +   <h3><a href="#contents" class=none name="misc">Miscellaneous</a></h3> + +Things that didn't seem to fit into one of the other categories... + + [Macro] + <a class=none name="do-rows">do-rows (y-var <tt>&optional</tt> image) declaration* form* => results</a> + +<blockquote> +This macro loops through all rows (from top to bottom) in turn and +executes <code>form*</code> for each row with +<code>y-var</code> bound to the vertical index of the current row +(starting with <code>0</code>). It is not affected by <a +href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Local macro] + <a class=none name="do-pixels-in-row">do-pixels-in-row (x-var) declaration* form* => results</a> + +<blockquote> +This macro is only available within the body of a <a +href="#do-rows"><code>DO-ROWS</code></a> form. +It loops through all pixels (from left to right) in turn and +executes <code>form*</code> for each pixel with +<code>x-var</code> bound to the horizontal index of the current pixel +(starting with <code>0</code>). It is not affected by <a +href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Macro] + <a class=none name="do-pixels">do-pixels (<tt>&optional</tt> image) declaration* form* => results</a> + +<blockquote> +This is a shortcut for the previous two macros. It loops through all pixels and executes <code>form*</code> for each pixel. Obviously it only makes sense when used together with <a +href="#raw-pixel"><code>RAW-PIXEL</code></a>. +</blockquote> + + [Accessor] + <a class=none name="raw-pixel">raw-pixel => pixel + (setf (raw-pixel) pixel)</a> + +<blockquote> +This accessor is only available within the body of a <a +href="#do-pixels-in-row"><code>DO-PIXELS-IN-ROW</code></a> form (and +thus also within <a href="#do-pixels"><code>DO-PIXELS</code></a> +forms). It provides access to the "raw" pixel the loop is +currently at, i.e. for true color images you access an element of the +<code>im->tpixels</code> array, for palette-based images it's +<code>im->pixels</code>. Read the <a +href="http://www.boutell.com/gd/manual2.0.15.html">original GD +documentation</a> for details. Make sure you know what you're doing if +you change these values... +</blockquote> + +<pre> +* (<a class=noborder href="#with-image*">with-image*</a> (3 3 t) ; true-color image with 3x3 pixels + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 0 0 2 2 :color (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 0)) ; black background + (<a class=noborder href="#draw-line">draw-line</a> 0 0 2 2 :color (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) ; white line + (<a class=noborder href="#do-pixels">do-pixels</a> () + ;; loop through all pixels and change those which arent't black + (unless (zerop (<a class=noborder href="#raw-pixel">raw-pixel</a>)) + (decf (<a class=noborder href="#raw-pixel">raw-pixel</a>) #xff))) + (<a class=noborder href="#do-rows">do-rows</a> (y) + ;; loop through all rows + (format t "Starting with row ~A~%" y) + (<a class=noborder href="#do-pixels-in-row">do-pixels-in-row</a> (x) + ;; loop through all pixels in row + (format t " Pixel <~A,~A> has value ~X~%" x y (<a class=noborder href="#raw-pixel">raw-pixel</a>))) + (format t "Done with row ~A~%" y))) +Starting with row 0 + Pixel <0,0> has value FFFF00 ; the line is yellow now + Pixel <1,0> has value 0 + Pixel <2,0> has value 0 +Done with row 0 +Starting with row 1 + Pixel <0,1> has value 0 + Pixel <1,1> has value FFFF00 + Pixel <2,1> has value 0 +Done with row 1 +Starting with row 2 + Pixel <0,2> has value 0 + Pixel <1,2> has value 0 + Pixel <2,2> has value FFFF00 +Done with row 2 +NIL +</pre> + + [Accessor] + <a class=none name="interlacedp">interlacedp <tt>&optional</tt> image => interlaced + (setf (interlacedp <tt>&optional</tt> image) interlaced)</a> + +<blockquote> +Gets or sets whether <code>image</code> will be stored in an interlaced fashion. +</blockquote> + + [Function] + <a class=none name="differentp">differentp image1 image2 => different</a> + +<blockquote> +Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images. +</blockquote> + + [Function] + <a class=none name="copy-image">copy-image source destination source-x source-y dest-x dest-y width height <tt>&key</tt> resample rotate angle resize dest-width dest-height merge merge-gray => destination</a> + +<blockquote> +Copies (a part of) the <a href="#images">image</a> <code>source</code> into the image <code>destination</code>. Copies the +rectangle with the upper left corner <code>(source-x,source-y)</code> and size +<code>width</code> <tt>x</tt> <code>height</code> to the rectangle with the upper left corner <code>(dest-x,dest-y)</code>. + +If <code>resample</code> is true pixel colors will be +smoothly interpolated. If <code>resize</code> is true +the copied rectangle will be strechted or shrunk so that its size is +<code>dest-width</code> <tt>x</tt> +<code>dest-height</code>. If <code>rotate</code> is true +the image will be rotated by <code>angle</code>. In this +particular case <code>dest-x</code> and +<code>dest-y</code> specify the center of the copied +image rather than its upper left corner! If <code>merge</code> +is true then it has to be an integer in the range 0-100 and the +two images will be 'merged' by the amount specified. If +<code>merge</code> is 100 then the source image will simply be +copied. If instead <code>merge-gray</code> is true the hue of +the source image is preserved by converting the destination area to +gray pixels before merging. + +The keyword arguments <code>resample</code>, <code>rotate</code>, <code>resize</code>, <code>merge</code>, and <code>merge-gray</code> +are mutually exclusive (with the exception of <code>resample</code> and +<code>resize</code>). <code>angle</code> is assumed to be specified in degrees if it's an +integer, and in radians otherwise. This function is not affected by <a href="#with-transformation"><code>WITH-TRANSFORMATION</code></a>. +</blockquote> + + [Function] + <a class=none name="copy-palette">copy-palette source destination => destination</a> + +<blockquote> +Copies the palette of the <a href="#images">image</a> <code>source</code> to the image <code>destination</code> attempting to +match the colors in the target image to the colors in the source palette. +</blockquote> + + [Function] + <a class=none name="true-color-to-palette">true-color-to-palette <tt>&key</tt> dither colors-wanted image => image</a> + +<blockquote> +Converts the true color image <code>image</code> to a palette-based image using +a high-quality two-pass quantization routine. If <code>dither</code> is true, the +image will be dithered to approximate colors better, at the expense of +some obvious "speckling." <code>colors-wanted</code> can be any positive integer +up to 256 (which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image. +</blockquote> + +<pre> +(<a class=noborder href="#with-image*">with-image*</a> ((+ 256 384) 384 t) + (let ((white (<a class=noborder href="#allocate-color">allocate-color</a> 255 255 255)) + (red (<a class=noborder href="#allocate-color">allocate-color</a> 255 0 0)) + (green (<a class=noborder href="#allocate-color">allocate-color</a> 0 255 0)) + (blue (<a class=noborder href="#allocate-color">allocate-color</a> 0 0 255)) + (vertices (list 64 0 0 128 128 128)) + (image-width (<a class=noborder href="#image-width">image-width</a>)) + (image-height (<a class=noborder href="#image-height">image-height</a>))) + (setf (<a class=noborder href="#transparent-color">transparent-color</a>) white) + (<a class=noborder href="#draw-rectangle*">draw-rectangle*</a> 0 0 image-width image-height :color white) + ;; "demoin.png" is part of the GD distribution + (<a class=noborder href="#with-image-from-file">with-image-from-file</a> (in-file "demoin.png") + (<a class=noborder href="#copy-image">copy-image</a> in-file *default-image* + 0 0 32 32 192 192 + :resize t + :dest-width 255 + :dest-height 255 + :resample t) + (multiple-value-bind (in-width in-height) + (<a class=noborder href="#image-size">image-size</a> in-file) + (loop for a below 360 by 45 do + (<a class=noborder href="#copy-image">copy-image</a> in-file *default-image* + 0 0 + (+ 256 192 (* 128 (cos (* a .0174532925)))) + (- 192 (* 128 (sin (* a .0174532925)))) + in-width in-height + :rotate t + :angle a)) + (<a class=noborder href="#with-default-color">with-default-color</a> (green) + (<a class=noborder href="#with-thickness">with-thickness</a> (4) + (<a class=noborder href="#draw-line">draw-line</a> 16 16 240 16) + (<a class=noborder href="#draw-line">draw-line</a> 240 16 240 240) + (<a class=noborder href="#draw-line">draw-line</a> 240 240 16 240) + (<a class=noborder href="#draw-line">draw-line</a> 16 240 16 16)) + (<a class=noborder href="#draw-polygon">draw-polygon</a> vertices :filled t)) + (dotimes (i 3) + (incf (nth (* 2 i) vertices) 128)) + (<a class=noborder href="#draw-polygon">draw-polygon</a> vertices + :color (<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> green) + :filled t) + (<a class=noborder href="#with-default-color">with-default-color</a> (blue) + (<a class=noborder href="#draw-arc">draw-arc</a> 128 128 60 20 0 720) + (<a class=noborder href="#draw-arc">draw-arc</a> 128 128 40 40 90 270) + (<a class=noborder href="#fill-image">fill-image</a> 8 8)) + (<a class=noborder href="#with-image">with-image</a> (brush 16 16 t) + (<a class=noborder href="#copy-image">copy-image</a> in-file brush + 0 0 0 0 + in-width in-height + :resize t + :dest-width (<a class=noborder href="#image-width">image-width</a> brush) + :dest-height (<a class=noborder href="#image-height">image-height</a> brush)) + (<a class=noborder href="#draw-line">draw-line</a> 0 255 255 0 + :color (cons (<a class=noborder href="#make-brush">make-brush</a> brush) + (list nil nil nil nil nil nil nil t)))))) + (<a class=noborder href="#with-default-color">with-default-color</a> (red) + (<a class=noborder href="#draw-string">draw-string</a> 32 32 "hi" :font :giant) + (<a class=noborder href="#draw-string">draw-string</a> 64 64 "hi" :font :small)) + (<a class=noborder href="#with-clipping-rectangle*">with-clipping-rectangle*</a> (0 (- image-height 100) 100 image-height) + (<a class=noborder href="#with-default-color">with-default-color</a> ((<a class=noborder href="#make-anti-aliased">make-anti-aliased</a> white)) + (dotimes (i 100) + (<a class=noborder href="#draw-line">draw-line</a> (random image-width) + (random image-height) + (random image-width) + (random image-height)))))) + (setf (<a class=noborder href="#interlacedp">interlacedp</a>) t) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "demoout.png" + :if-exists :supersede) + (<a class=noborder href="#true-color-to-palette">true-color-to-palette</a>) + (<a class=noborder href="#write-image-to-file">write-image-to-file</a> "demooutp.png" + :if-exists :supersede)) +</pre> + +This last example is the demo which comes with GD. The equivalent C code is <a href="gddemo.c">here</a>. + + +<img border=0 alt="demooutp.png" title="demooutp.png" src="demooutp.png" width=640 height=384> + +   <h3><a href="#contents" class=none name="ack">Acknowledgements</a></h3> + +Thanks to Thomas Boutell for <a +href="http://www.boutell.com/gd/">GD</a> and thanks to Kevin Rosenberg +for <a href="http://uffi.b9.com/">UFFI</a> without which CL-GD would +not have been possible. Kevin was also extremely helpful when I needed +functionality which wasn't yet part of UFFI. Thanks to <a href="http://huebner.org/">Hans +Hübner</a> for the GIF patches. Thanks to <a href='http://bl0rg.net/'>Manuel Odendahl</a> for lots of useful patches. +Thanks to Luis Oliveira for CLISP/CFFI support and to Bryan O'Connor for OpenMCL support. + +$Header: /usr/local/cvsrep/gd/doc/index.html,v 1.75 2007/07/29 16:37:15 edi Exp $ +<a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> + +</body> +</html> Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/smallzappa.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/strings.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/triangle.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/doc/zappa.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/drawing.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/drawing.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,354 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/drawing.lisp,v 1.28 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun get-pixel (x y &key (image *default-image*)) + "Gets the color associated with point \(X,Y)." + (check-type image image) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-get-pixel (img image) x y))) + +(defun set-pixel (x y &key (color *default-color*) (image *default-image*)) + "Draws a pixel with color COLOR at point \(X,Y)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel (img image) x y color))) + (values x y)) + +(defgeneric set-pixels (points &key color image) + (:documentation "Draws a list \(X1 Y1 X2 Y2 ...) or vector #\(X1 Y1 +X2 Y2 ...) of pixels.")) + +(defmethod set-pixels ((points list) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (unless (evenp (length points)) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for (x y) on points by #'cddr do + (check-type x integer) + (check-type y integer) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (gd-image-set-pixel img x y color)) + finally (return image))) + +(defmethod set-pixels ((points vector) &key (color *default-color*) (image *default-image*)) + (check-type image image) + (let ((length (length points))) + (unless (evenp length) + (error "List ~S must have an even number of elements" + points)) + (loop with img = (img image) + for i below length by 2 do + (check-type (aref points i) integer) + (check-type (aref points (1+ i)) integer) + (with-transformed-alternative + (((aref points i) x-transformer) + ((aref points (1+ i)) y-transformer)) + (gd-image-set-pixel img + (aref points i) + (aref points (1+ i)) + color)) + finally (return image)))) + +(defun draw-line (x1 y1 x2 y2 &key (color *default-color*) (image *default-image*)) + "Draws a line with color COLOR from point \(X1,Y1) to point \(X2,Y2)." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-line (img image) x1 y1 x2 y2 color))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle* (x1 y1 x2 y2 &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2). If FILLED is true the rectangle will be filled with +COLOR, otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (if filled + (gd-image-filled-rectangle (img image) x1 y1 x2 y2 color) + (gd-image-rectangle (img image) x1 y1 x2 y2 color)))) + (values x1 y1 x2 y2)) + +(defun draw-rectangle (rectangle &key filled (color *default-color*) (image *default-image*)) + "Draws a rectangle with upper left corner \(X1,Y1) and lower right +corner \(X2,Y2) where RECTANGLE is the list \(X1 Y1 X2 Y2). If FILLED +is true the rectangle will be filled with COLOR, otherwise it will be +outlined." + (draw-rectangle* (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle) + :filled filled + :color color + :image image) + rectangle) + +(defgeneric draw-polygon (vertices &key filled start end color image) + (:documentation "Draws a polygon with the VERTICES \(at least three) +specified as a list \(x1 y1 x2 y2 ...) or as a vector #\(x1 y1 x2 y2 +...). If FILLED is true the polygon will be filled with COLOR, +otherwise it will be outlined. If START and/or END are specified then +only the corresponding part of VERTICES is used as input.")) + +(defmethod draw-polygon ((vertices vector) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((aref vertices i) x-transformer) + ((aref vertices (1+ i)) y-transformer)) + (loop for i from start below end by 2 + for point-ptr = (deref-array arr '(:array gd-point) (/ (- i start) 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (aref vertices i) + (get-slot-value point-ptr 'gd-point 'y) + (aref vertices (1+ i)))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defmethod draw-polygon ((vertices list) &key filled (start 0) (end (length vertices)) (color *default-color*) (image *default-image*)) + (check-type start integer) + (check-type end integer) + (check-type image image) + (let ((effective-length (- end start))) + (unless (and (>= effective-length 6) + (evenp effective-length)) + (error "We need an even number of at least six vertices")) + (with-safe-alloc (arr (allocate-foreign-object 'gd-point (/ effective-length 2)) + (free-foreign-object arr)) + (with-color-argument + (with-transformed-alternative + (((first x/y) x-transformer) + ((second x/y) y-transformer)) + (loop for i below (- end start) by 2 + ;; we don't use LOOP's destructuring capabilities here + ;; because of your simple WITH-TRANSFORMED-ALTERNATIVE + ;; macro which would get confused + for x/y on (nthcdr start vertices) by #'cddr + for point-ptr = (deref-array arr '(:array gd-point) (/ i 2)) + do (setf (get-slot-value point-ptr 'gd-point 'x) + (first x/y) + (get-slot-value point-ptr 'gd-point 'y) + (second x/y))) + (funcall (if filled + #'gd-image-filled-polygon + #'gd-image-polygon) + (img image) arr (/ effective-length 2) color) + vertices))))) + +(defun draw-filled-ellipse (center-x center-y width height &key (color *default-color*) (image *default-image*)) + "Draws a filled ellipse centered at \(CENTER-X, CENTER-Y) with width +WIDTH and height HEIGHT." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer)) + (gd-image-filled-ellipse (img image) center-x center-y width height color))) + (values center-x center-y width height)) + +(defun draw-filled-circle (center-x center-y radius &key (color *default-color*) (image *default-image*)) + "Draws a filled circle centered at \(CENTER-X, CENTER-Y) with radius +RADIUS." + (draw-filled-ellipse center-x center-y (* 2 radius) (* 2 radius) + :color color :image image) + (values center-x center-y radius)) + +(defun draw-arc (center-x center-y width height start end &key straight-line center-connect filled (color *default-color*) (image *default-image*)) + "Draws a partial ellipse centered at \(CENTER-X, CENTER-Y) with +width WIDTH and height HEIGHT. The arc begins at angle START and ends +at angle END. If STRAIGHT-LINE is true the start and end points are +just connected with a straight line. If CENTER-CONNECT is true, they +are connected to the center \(which is useful to create 'pie +slices'). If FILLED is true the arc will be filled with COLOR, +otherwise it will be outlined." + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((center-x x-transformer) + (center-y y-transformer) + (width w-transformer) + (height h-transformer) + (start angle-transformer) + (end angle-transformer)) + (cond ((not (or straight-line filled center-connect)) + (gd-image-arc (img image) center-x center-y width height start end color)) + (t + (gd-image-filled-arc (img image) center-x center-y width height start end color + (logior (if straight-line +gd-chord+ 0) + (if filled 0 +gd-no-fill+) + (if center-connect +gd-edged+ 0))))))) + (values center-x center-y width height start end)) + +(defun fill-image (x y &key border (color *default-color*) (image *default-image*)) + "Floods a portion of the image IMAGE with the color COLOR beginning +at point \(X, Y) and extending into the surrounding region. If BORDER +is true it must be a color and the filling will stop at the specified +border color. Otherwise only points with the same color as the +starting point will be colored." + (check-type border (or null integer)) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if border + (gd-image-fill-to-border (img image) x y border color) + (gd-image-fill (img image) x y color)))) + (values x y)) + +(defun clipping-rectangle (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as a list of four +elements." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (list (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun (setf clipping-rectangle) (rectangle &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE where rectangle should be a +list \(X1 Y1 X2 Y2)." + (check-type image image) + (with-transformed-alternative + (((first rectangle) x-transformer) + ((second rectangle) y-transformer) + ((third rectangle) x-transformer) + ((fourth rectangle) y-transformer)) + (gd-image-set-clip (img image) + (first rectangle) + (second rectangle) + (third rectangle) + (fourth rectangle))) + rectangle) + +(defun clipping-rectangle* (&optional (image *default-image*)) + "Returns the clipping rectangle of IMAGE as four values." + (check-type image image) + (with-transformed-alternative + (((deref-pointer x1p) x-inv-transformer) + ((deref-pointer y1p) y-inv-transformer) + ((deref-pointer x2p) x-inv-transformer) + ((deref-pointer y2p) y-inv-transformer)) + (with-foreign-object (x1p :int) + (with-foreign-object (y1p :int) + (with-foreign-object (x2p :int) + (with-foreign-object (y2p :int) + (gd-image-get-clip (img image) x1p y1p x2p y2p) + (values (deref-pointer x1p :int) + (deref-pointer y1p :int) + (deref-pointer x2p :int) + (deref-pointer y2p :int)))))))) + +(defun set-clipping-rectangle* (x1 y1 x2 y2 &optional (image *default-image*)) + "Sets the clipping rectangle of IMAGE to be the rectangle with upper +left corner \(X1, Y1) and lower right corner \(X2, Y2)." + (check-type image image) + (with-transformed-alternative + ((x1 x-transformer) + (y1 y-transformer) + (x2 x-transformer) + (y2 y-transformer)) + (gd-image-set-clip (img image) x1 y1 x2 y2)) + (values x1 y1 x2 y2)) + +(defmacro with-clipping-rectangle ((rectangle &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to RECTANGLE +which should be a list \(X1 Y1 X2 Y2). The previous clipping rectangle +is guaranteed to be restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (rectangle image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (setf (clipping-rectangle ,image) ,rectangle) + ,@body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) + +(defmacro with-clipping-rectangle* ((x1 y1 x2 y2 &key (image '*default-image*)) &body body) + "Executes BODY with the clipping rectangle of IMAGE set to the +rectangle with upper left corner \(X1, Y1) and lower right corner +\(X2, Y2). The previous clipping rectangle is guaranteed to be +restored before the macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (x1 y1 x2 y2 image) + (with-unique-names (%x1 %y1 %x2 %y2) + `(multiple-value-bind (,%x1 ,%y1 ,%x2 ,%y2) + (without-transformations + (clipping-rectangle* ,image)) + (unwind-protect + (progn + (set-clipping-rectangle* ,x1 ,y1 ,x2 ,y2 ,image) + ,@body) + (without-transformations + (set-clipping-rectangle* ,%x1 ,%y1 ,%x2 ,%y2 ,image))))))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/gd-uffi.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/gd-uffi.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,731 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/gd-uffi.lisp,v 1.32 2007/04/05 23:22:24 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +;; internal representation of an image in GD +(def-struct gd-image + (pixels (* (* :unsigned-char))) + (sx :int) + (sy :int) + (colors-total :int) + (red (:array :int #.+max-colors+)) + (green (:array :int #.+max-colors+)) + (blue (:array :int #.+max-colors+)) + (open (:array :int #.+max-colors+)) + (transparent :int) + (poly-ints (* :int)) + (poly-allocated :int) + (brush :pointer-self) + (tile :pointer-self) + (brush-color-map (:array :int #.+max-colors+)) + (tile-color-map (:array :int #.+max-colors+)) + (style-length :int) + (style-pos :int) + (style (* :int)) + (interface :int) + (thick :int) + (alpha (:array :int #.+max-colors+)) + (true-color :int) + (t-pixels (* (* :int))) + (alpha-blending-flag :int) + (save-alpha-flag :int) + (aa :int) + (aa-color :int) + (aa-do-not-blend :int) + (aa-opacity (* (* :unsigned-char))) + (aa-polygon :int) + (aal-x1 :int) + (aal-y1 :int) + (aal-x2 :int) + (aal-y2 :int) + (aal-bx-ax :int) + (aal-by-ay :int) + (aal-lab-2 :int) + (aal-lab :float) + (cx1 :int) + (cy1 :int) + (cx2 :int) + (cy2 :int)) + +(def-type pixels-array (* (* :unsigned-char))) +(def-type pixels-row (* :unsigned-char)) +(def-type t-pixels-array (* (* :int))) +(def-type t-pixels-row (* :int)) + +(def-foreign-type gd-image-ptr (* gd-image)) + +;; initialize special variable +(setq *null-image* (make-image (make-null-pointer 'gd-image))) + +;; internal representation of a point in GD, used by the polygon +;; functions +(def-struct gd-point + (x :int) + (y :int)) + +(def-foreign-type gd-point-ptr (* gd-point)) + +;; internal representation of a font in GD, used by the (non-FreeType) +;; functions which draw characters and strings +(def-struct gd-font + (nchars :int) + (offset :int) + (w :int) + (h :int) + (data (* :char))) + +(def-foreign-type gd-font-ptr (* gd-font)) + +;; additional info for calls to the FreeType library - currently only +;; used for line spacing +(def-struct gd-ft-string-extra + (flags :int) + (line-spacing :double) + (charmap :int)) + +(def-foreign-type gd-ft-string-extra-ptr (* gd-ft-string-extra)) + +;; the GD standard fonts used when drawing characters or strings +;; without invoking the FreeType library +(def-foreign-var ("gdFontTiny" +gd-font-tiny+) gd-font-ptr "gd") +(def-foreign-var ("gdFontSmall" +gd-font-small+) gd-font-ptr "gd") +(def-foreign-var ("gdFontMediumBold" +gd-font-medium-bold+) gd-font-ptr "gd") +(def-foreign-var ("gdFontLarge" +gd-font-large+) gd-font-ptr "gd") +(def-foreign-var ("gdFontGiant" +gd-font-giant+) gd-font-ptr "gd") + +;;; all GD functions which are accessed from CL-GD + +(def-function ("gdImageCreate" gd-image-create) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateTrueColor" gd-image-create-true-color) + ((sx :int) + (sy :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromJpegFile" gd-image-create-from-jpeg-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromPngFile" gd-image-create-from-png-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGdFile" gd-image-create-from-gd-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2File" gd-image-create-from-gd2-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromGd2PartFile" gd-image-create-from-gd2-part-file) + ((filename :cstring) + (err (* :int)) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageCreateFromXbmFile" gd-image-create-from-xbm-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +#-:win32 +(def-function ("gdImageCreateFromXpm" gd-image-create-from-xpm) + ((filename :cstring)) + :returning gd-image-ptr + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageCreateFromGifFile" gd-image-create-from-gif-file) + ((filename :cstring) + (err (* :int))) + :returning gd-image-ptr + :module "gd") + +(def-function ("gdImageJpegPtr" gd-image-jpeg-ptr) + ((im gd-image-ptr) + (size (* :int)) + (quality :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGdPtr" gd-image-gd-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageGd2Ptr" gd-image-gd2-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageWBMPPtr" gd-image-wbmp-ptr) + ((im gd-image-ptr) + (size (* :int)) + (fg :int)) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtr" gd-image-png-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImagePngPtrEx" gd-image-png-ptr-ex) + ((im gd-image-ptr) + (size (* :int)) + (level :int)) + :returning :pointer-void + :module "gd") + +#-:cl-gd-no-gif +(def-function ("gdImageGifPtr" gd-image-gif-ptr) + ((im gd-image-ptr) + (size (* :int))) + :returning :pointer-void + :module "gd") + +(def-function ("gdImageDestroy" gd-image-destroy) + ((im gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageColorAllocate" gd-image-color-allocate) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorAllocateAlpha" gd-image-color-allocate-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorDeallocate" gd-image-color-deallocate) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageColorExact" gd-image-color-exact) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosest" gd-image-color-closest) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestHWB" gd-image-color-closest-hwb) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorClosestAlpha" gd-image-color-closest-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolve" gd-image-color-resolve) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorResolveAlpha" gd-image-color-resolve-alpha) + ((im gd-image-ptr) + (r :int) + (g :int) + (b :int) + (a :int)) + :returning :int + :module "gd") + +(def-function ("gdImageColorTransparent" gd-image-color-transparent) + ((im gd-image-ptr) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetTransparent" gd-image-get-transparent) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetAntiAliased" gd-image-set-anti-aliased) + ((im gd-image-ptr) + (c :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetAntiAliasedDontBlend" gd-image-set-anti-aliased-do-not-blend) + ((im gd-image-ptr) + (c :int) + (dont-blend :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetBrush" gd-image-set-brush) + ((im gd-image-ptr) + (brush gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetTile" gd-image-set-tile) + ((im gd-image-ptr) + (tile gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageSetStyle" gd-image-set-style) + ((im gd-image-ptr) + (style (* :int)) + (style-length :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSetThickness" gd-image-set-thickness) + ((im gd-image-ptr) + (thickness :int)) + :returning :void + :module "gd") + +(def-function ("gdImageAlphaBlending" gd-image-alpha-blending) + ((im gd-image-ptr) + (blending :int)) + :returning :void + :module "gd") + +(def-function ("gdImageSaveAlpha" gd-image-save-alpha) + ((im gd-image-ptr) + (save-flag :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetRed" gd-image-get-red) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetGreen" gd-image-get-green) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetBlue" gd-image-get-blue) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetAlpha" gd-image-get-alpha) + ((im gd-image-ptr) + (color :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetColorsTotal" gd-image-get-colors-total) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageSetClip" gd-image-set-clip) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetClip" gd-image-get-clip) + ((im gd-image-ptr) + (x1p (* :int)) + (y1p (* :int)) + (x2p (* :int)) + (y2p (* :int))) + :returning :void + :module "gd") + +(def-function ("gdImageSetPixel" gd-image-set-pixel) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageLine" gd-image-line) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePolygon" gd-image-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledPolygon" gd-image-filled-polygon) + ((im gd-image-ptr) + (points gd-point-ptr) + (points-total :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageRectangle" gd-image-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledRectangle" gd-image-filled-rectangle) + ((im gd-image-ptr) + (x1 :int) + (y1 :int) + (x2 :int) + (y2 :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledEllipse" gd-image-filled-ellipse) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageArc" gd-image-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFilledArc" gd-image-filled-arc) + ((im gd-image-ptr) + (cx :int) + (cy :int) + (w :int) + (h :int) + (s :int) + (e :int) + (color :int) + (style :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFill" gd-image-fill) + ((im gd-image-ptr) + (x :int) + (y :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageFillToBorder" gd-image-fill-to-border) + ((im gd-image-ptr) + (x :int) + (y :int) + (border :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageChar" gd-image-char) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCharUp" gd-image-char-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (c :int) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageString" gd-image-string) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringUp" gd-image-string-up) + ((im gd-image-ptr) + (f gd-font-ptr) + (x :int) + (y :int) + (s :cstring) + (color :int)) + :returning :void + :module "gd") + +(def-function ("gdImageStringFT" gd-image-string-ft) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring)) + :returning :cstring + :module "gd") + +(def-function ("gdImageStringFTEx" gd-image-string-ft-ex) + ((im gd-image-ptr) + (brect (* :int)) + (fg :int) + (fontname :cstring) + (ptsize :double) + (angle :double) + (x :int) + (y :int) + (string :cstring) + (strex gd-ft-string-extra-ptr)) + :returning :cstring + :module "gd") + +(def-function ("gdImageGetPixel" gd-image-get-pixel) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageBoundsSafe" gd-image-bounds-safe) + ((im gd-image-ptr) + (x :int) + (y :int)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSX" gd-image-get-sx) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageGetSY" gd-image-get-sy) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageInterlace" gd-image-interlace) + ((im gd-image-ptr) + (interlace :int)) + :returning :void + :module "gd") + +(def-function ("gdImageGetGetInterlaced" gd-image-get-interlaced) + ((im gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageCopy" gd-image-copy) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMerge" gd-image-copy-merge) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyMergeGray" gd-image-copy-merge-gray) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dest-x :int) + (dest-y :int) + (src-x :int) + (src-y :int) + (w :int) + (h :int) + (percent :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResized" gd-image-copy-resized) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyResampled" gd-image-copy-resampled) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :int) + (dst-y :int) + (src-x :int) + (src-y :int) + (dest-w :int) + (dest-h :int) + (src-w :int) + (src-h :int)) + :returning :void + :module "gd") + +(def-function ("gdImageCopyRotated" gd-image-copy-rotated) + ((dst gd-image-ptr) + (src gd-image-ptr) + (dst-x :double) + (dst-y :double) + (src-x :int) + (src-y :int) + (src-w :int) + (src-h :int) + (angle :int)) + :returning :void + :module "gd") + +(def-function ("gdImagePaletteCopy" gd-image-palette-copy) + ((dst gd-image-ptr) + (src gd-image-ptr)) + :returning :void + :module "gd") + +(def-function ("gdImageCompare" gd-image-compare) + ((im1 gd-image-ptr) + (im2 gd-image-ptr)) + :returning :int + :module "gd") + +(def-function ("gdImageTrueColorToPalette" gd-image-true-color-to-palette) + ((im gd-image-ptr) + (dither :int) + (colors-wanted :int)) + :returning :void + :module "gd") + +(def-function ("gdFree" gd-free) + ((ptr :pointer-void)) + :returning :void + :module "gd") Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/images.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/images.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,411 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/images.lisp,v 1.33 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun create-image (width height &optional true-color) + "Allocates and returns a GD image structure with size WIDTH x +HEIGHT. Creates a true color image if TRUE-COLOR is true. You are +responsible for destroying the image after you're done with it. It is +advisable to use WITH-IMAGE instead." + (check-type width integer) + (check-type height integer) + (let ((image-ptr + (if true-color + (gd-image-create-true-color width height) + (gd-image-create width height)))) + (when (null-pointer-p image-ptr) + (error "Could not allocate image of size ~A x ~A" width height)) + (let ((image (make-image image-ptr))) + image))) + +(defun destroy-image (image) + "Destroys \(deallocates) IMAGE which has been created by +CREATE-IMAGE, CREATE-IMAGE-FROM-FILE, or CREATE-IMAGE-FROM-GD2-PART." + (check-type image image) + (gd-image-destroy (img image)) + nil) + +(defmacro with-default-image ((image) &body body) + "Executes BODY with *DEFAULT-IMAGE* bound to IMAGE so that you don't +have to provide the IMAGE keyword/optional argument to CL-GD +functions." + `(let ((*default-image* ,image)) + ,@body)) + +(defmacro with-image ((name width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT, and executes BODY with +the image bound to NAME. If TRUE-COLOR is true, creates a true color +image. The image is guaranteed to be destroyed before this macro +exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (width height true-color) + `(with-safe-alloc (,name + (create-image ,width ,height ,true-color) + (destroy-image ,name)) + ,@body))) + +(defmacro with-image* ((width height &optional true-color) &body body) + "Creates an image with size WIDTH x HEIGHT and executes BODY with +the image bound to *DEFAULT-IMAGE*. If TRUE-COLOR is true, creates a +true color image. The image is guaranteed to be destroyed before this +macro exits." + `(with-image (*default-image* ,width ,height ,true-color) + ,@body)) + +(defun create-image-from-file (file-name &optional type) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string). The type of the image can be provided +as TYPE or otherwise it will be guessed from the PATHNAME-TYPE of +FILE-NAME. You are responsible for destroying the image after you're +done with it. It is advisable to use WITH-IMAGE-FROM-FILE instead." + (check-type file-name (or pathname string)) + (let* ((pathname-type (pathname-type file-name)) + (%type (or type + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + ((string-equal pathname-type "xbm") + :xbm) + #-:win32 + ((string-equal pathname-type "xpm") + :xpm) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif))))) + (unless %type + (error "No type provided and it couldn't be guessed from filename")) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (ecase %type + ((:jpg :jpeg) + (gd-image-create-from-jpeg-file c-file-name err)) + ((:png) + (gd-image-create-from-png-file c-file-name err)) + ((:gd) + (gd-image-create-from-gd-file c-file-name err)) + ((:gd2) + (gd-image-create-from-gd2-file c-file-name err)) + ((:xbm) + (gd-image-create-from-xbm-file c-file-name err)) + #-:win32 + ((:xpm) + (gd-image-create-from-xpm c-file-name)) + #-:cl-gd-no-gif + ((:gif) + (gd-image-create-from-gif-file c-file-name err))))) + (cond ((null-pointer-p image) + (cond ((or (eq %type :xpm) + (zerop (deref-pointer err :int))) + (error "Could not create image from ~A file ~S" + %type file-name)) + (t + (error "Could not create image from ~A file ~S: errno was ~A" + %type file-name (deref-pointer err :int))))) + (t (let ((image (make-image image))) + image)))))))) + +(defmacro with-image-from-file ((name file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to NAME. The type of the image can be provied as TYPE or otherwise it +will be guessed from the PATHNAME-TYPE of FILE-NAME. The image is +guaranteed to be destroyed before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name type) + `(with-safe-alloc (,name + (create-image-from-file ,file-name ,type) + (destroy-image ,name)) + ,@body))) + +(defmacro with-image-from-file* ((file-name &optional type) &body body) + "Creates an image from the file specified by FILE-NAME \(which is +either a pathname or a string) and executes BODY with the image bound +to *DEFAULT-IMAGE*. The type of the image can be provied as TYPE or +otherwise it will be guessed from the PATHNAME-TYPE of FILE-NAME. The +image is guaranteed to be destroyed before this macro exits." + `(with-image-from-file (*default-image* ,file-name ,type) + ,@body)) + +(defun create-image-from-gd2-part (file-name src-x src-y width height) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified by SRC-X, SRC-Y, WIDTH, and +HEIGHT. You are responsible for destroying the image after you're done +with it. It is advisable to use WITH-IMAGE-FROM-GD2-PART instead." + (check-type file-name (or string pathname)) + (check-type src-x integer) + (check-type src-y integer) + (check-type width integer) + (check-type height integer) + (unless (probe-file file-name) + (error "File ~S could not be found" file-name)) + (when (pathnamep file-name) + (setq file-name + #+:cmu (ext:unix-namestring file-name) + #-:cmu (namestring file-name))) + (with-foreign-object (err :int) + (with-cstring (c-file-name file-name) + (let ((image (gd-image-create-from-gd2-part-file c-file-name err src-x src-y width height))) + (cond ((null-pointer-p image) + (error "Could not create GD2 image from file ~S: errno was ~A" + file-name (deref-pointer err :int))) + (t image)))))) + +(defmacro with-image-from-gd2-part ((name file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to NAME. The type of the +image can be provied as TYPE or otherwise it will be guessed from the +PATHNAME-TYPE of FILE-NAME. The image is guaranteed to be destroyed +before this macro exits." + ;; we rebind everything so we have left-to-right evaluation + (with-rebinding (file-name src-x src-y width height) + `(with-safe-alloc (,name + (create-image-from-gd2-part ,file-name ,src-x ,src-y ,width ,height) + (destroy-image ,name)) + ,@body))) + +(defmacro with-image-from-gd2-part* ((file-name src-x src-y width height) &body body) + "Creates an image from the part of the GD2 file FILE-NAME \(which is +either a pathname or a string) specified SRC-X, SRC-Y, WIDTH, and +HEIGHT and executes BODY with the image bound to *DEFAULT-IMAGE*. The +type of the image can be provied as TYPE or otherwise it will be +guessed from the PATHNAME-TYPE of FILE-NAME. The image is guaranteed +to be destroyed before this macro exits." + `(with-image-from-gd2-part (*default-image* ,file-name ,src-x ,src-y ,width ,height) + ,@body)) + +(defmacro make-stream-fn (name signature gd-call type-checks docstring) + "Internal macro used to generate WRITE-JPEG-TO-STREAM and friends." + `(defun ,name ,signature + ,docstring + ,@type-checks + (cond ((or #+(and :allegro :allegro-version>= (version>= 6 0)) + (typep stream 'excl:simple-stream) + #+:lispworks4.3 + (subtypep 'base-char (stream-element-type stream)) + (subtypep '(unsigned-byte 8) (stream-element-type stream))) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (let (#+:lispworks4.3 + (temp-array (make-array 1 :element-type + '(unsigned-byte 8)))) + (with-cast-pointer (temp memory :unsigned-byte) + (dotimes (i (deref-pointer size :int)) + ;; LispWorks workaround, WRITE-BYTE won't work - see + ;; <http://article.gmane.org/gmane.lisp.lispworks.general/1827> + #+:lispworks4.3 + (setf (aref temp-array 0) + (deref-array temp '(:array :unsigned-byte) i)) + #+:lispworks4.3 + (write-sequence temp-array stream) + #-:lispworks4.3 + (write-byte (deref-array temp '(:array :unsigned-byte) i) + stream)) + image))))) + ((subtypep 'character (stream-element-type stream)) + (with-foreign-object (size :int) + (with-safe-alloc (memory ,gd-call (gd-free memory)) + (with-cast-pointer (temp memory + #+(or :cmu :scl :sbcl) :unsigned-char + #-(or :cmu :scl :sbcl) :char) + (dotimes (i (deref-pointer size :int)) + (write-char (ensure-char-character + (deref-array temp '(:array :char) i)) + stream)) + image)))) + (t (error "Can't use a stream with element-type ~A" + (stream-element-type stream)))))) + +(make-stream-fn write-jpeg-to-stream (stream &key (quality -1) (image *default-image*)) + (gd-image-jpeg-ptr (img image) size quality) + ((check-type stream stream) + (check-type quality (integer -1 100)) + (check-type image image)) + "Writes image IMAGE to stream STREAM as JPEG. If +QUALITY is not specified, the default IJG JPEG quality value is +used. Otherwise, for practical purposes, quality should be a value in +the range 0-95. STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format is +yields faithful output of all 8-bit characters.") + +(make-stream-fn write-png-to-stream (stream &key compression-level (image *default-image*)) + (cond (compression-level + (gd-image-png-ptr-ex (img image) size compression-level)) + (t + (gd-image-png-ptr (img image) size))) + ((check-type stream stream) + (check-type compression-level (or null (integer -1 9))) + (check-type image image)) + "Writes image IMAGE to stream STREAM as PNG. If +COMPRESSION-LEVEL is not specified, the default compression level at +the time zlib was compiled on your system will be used. Otherwise, a +compression level of 0 means 'no compression', a compression level of +1 means 'compressed, but as quickly as possible', a compression level +of 9 means 'compressed as much as possible to produce the smallest +possible file.' STREAM must be a character stream or a binary stream +of element type \(UNSIGNED-BYTE 8). If STREAM is a character stream, +the user of this function has to make sure the external format yields +faithful output of all 8-bit characters.") + +#-:cl-gd-no-gif +(make-stream-fn write-gif-to-stream (stream &key (image *default-image*)) + (gd-image-gif-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GIF. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-wbmp-to-stream (stream &key foreground (image *default-image*)) + (gd-image-wbmp-ptr (img image) size foreground) + ((check-type stream stream) + (check-type foreground integer) + (check-type image image)) + "Writes image IMAGE to stream STREAM as WBMP. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters. WBMP file support is black and white +only. The color index specified by the FOREGOUND argument is the +\"foreground,\" and only pixels of this color will be set in the WBMP +file") + +(make-stream-fn write-gd-to-stream (stream &key (image *default-image*)) + (gd-image-gd-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(make-stream-fn write-gd2-to-stream (stream &key (image *default-image*)) + (gd-image-gd2-ptr (img image) size) + ((check-type stream stream) + (check-type image image)) + "Writes image IMAGE to stream STREAM as GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters.") + +(defun write-image-to-stream (stream type &rest rest &key &allow-other-keys) + "Writes image to STREAM. The type of the image is determined by TYPE +which must be one of :JPG, :JPEG, :PNG, :WBMP, :GD, or :GD2. STREAM +must be a character stream or a binary stream of element type +\(UNSIGNED-BYTE 8). If STREAM is a character stream, the user of this +function has to make sure the external format yields faithful output +of all 8-bit characters." + (apply (ecase type + ((:jpg :jpeg) + #'write-jpeg-to-stream) + ((:png) + #'write-png-to-stream) + ((:wbmp) + #'write-wbmp-to-stream) + ((:gd) + #'write-gd-to-stream) + ((:gd2) + #'write-gd2-to-stream) + #-:cl-gd-no-gif + ((:gif) + #'write-gif-to-stream)) + stream rest)) + +(defun write-image-to-file (file-name &rest rest &key type (if-exists :error) &allow-other-keys) + "Writes image to the file specified by FILE-NAME \(a pathname or a +string). The TYPE argument is interpreted as in +WRITE-IMAGE-TO-STREAM. If it is not provided it is guessed from the +PATHNAME-TYPE of FILE-NAME. The IF-EXISTS keyword argument is given to +OPEN. Other keyword argument like QUALITY or COMPRESSION-LEVEL can be +provided depending on the images's type." + (with-open-file (stream file-name :direction :output + :if-exists if-exists + :element-type '(unsigned-byte 8)) + (apply #'write-image-to-stream + stream + (or type + (let ((pathname-type (pathname-type (truename file-name)))) + (cond ((or (string-equal pathname-type "jpg") + (string-equal pathname-type "jpeg")) + :jpg) + ((string-equal pathname-type "png") + :png) + ((string-equal pathname-type "wbmp") + :wbmp) + ((string-equal pathname-type "gd") + :gd) + ((string-equal pathname-type "gd2") + :gd2) + #-:cl-gd-no-gif + ((string-equal pathname-type "gif") + :gif) + (t + (error "Can't determine the type of the image"))))) + (sans rest :type :if-exists)))) + +(defun image-width (&optional (image *default-image*)) + "Returns width of IMAGE." + (check-type image image) + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer)) + (gd-image-get-sx (img image)))) + +(defun image-height (&optional (image *default-image*)) + (check-type image image) + "Returns height of IMAGE." + (with-transformed-alternative + (((gd-image-get-sy (img image)) h-inv-transformer)) + (gd-image-get-sy (img image)))) + +(defun image-size (&optional (image *default-image*)) + (check-type image image) + "Returns width and height of IMAGE as two values." + (with-transformed-alternative + (((gd-image-get-sx (img image)) w-inv-transformer) + ((gd-image-get-sy (img image)) h-inv-transformer)) + (values (gd-image-get-sx (img image)) + (gd-image-get-sy (img image))))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/init.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/init.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,46 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/init.lisp,v 1.12 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun load-gd-glue () + "Load the little glue library we have to create for the image input +functions." + ;; try to find the library at different places + (let ((filename (find-foreign-library "cl-gd-glue" + *shared-library-directories* + :types *shared-library-types* + :drive-letters *shared-library-drive-letters*))) + (load-foreign-library filename + :module "gd" + :supporting-libraries *gd-supporting-libraries*))) + +;; invoke the function, i.e. load the library (and thus GD itself) +;; before gd-uffi.lisp is loaded/compiled +(load-gd-glue) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/misc.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,238 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/misc.lisp,v 1.15 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defun interlacedp (&optional (image *default-image*)) + "Returns whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (not (zerop (gd-image-get-interlaced (img image))))) + +(defun (setf interlacedp) (interlaced &optional (image *default-image*)) + "Sets whether IMAGE will be stored in an interlaced fashion." + (check-type image image) + (gd-image-interlace (img image) (if interlaced 1 0)) + interlaced) + +(defun differentp (image1 image2) + "Returns false if the two images won't appear different when +displayed. Otherwise the return value is a list of keywords describing +the differences between the images." + (check-type image1 image) + (check-type image2 image) + (let ((result (gd-image-compare (img image1) (img image2)))) + (cond ((zerop (logand +gd-cmp-image+ result)) + nil) + (t + (loop for (gd-flag keyword) in `((,+gd-cmp-num-colors+ + :different-number-of-colors) + (,+gd-cmp-color+ + :different-colors) + (,+gd-cmp-size-x+ + :different-widths) + (,+gd-cmp-size-y+ + :different-heights) + (,+gd-cmp-transparent+ + :different-transparent-colors) + (,+gd-cmp-background+ + :different-background-colors) + (,+gd-cmp-interlace+ + :different-interlace-settings) + (,+gd-cmp-true-color+ + :true-color-versus-palette-based)) + when (plusp (logand gd-flag result)) + collect keyword))))) + +(defun copy-image (source destination + source-x source-y + dest-x dest-y + width height + &key resample + rotate angle + resize dest-width dest-height + merge merge-gray) + "Copies \(a part of) image SOURCE into image DESTINATION. Copies the +rectangle with the upper left corner \(SOURCE-X,SOURCE-Y) and size +WIDTH x HEIGHT to the rectangle with the upper left corner +\(DEST-X,DEST-Y). + +If RESAMPLE is true pixel colors will be smoothly interpolated. If +RESIZE is true the copied rectangle will be strechted or shrinked so +that its size is DEST-WIDTH x DEST-HEIGHT. If ROTATE is true the image +will be rotated by ANGLE. In this particular case DEST-X and DEST-Y +specify the CENTER of the copied image rather than its upper left +corner! If MERGE is true it has to be an integer in the range 0-100 +and the two images will be 'merged' by the amount specified. If MERGE +is 100 then the source image will simply be copied. If instead +MERGE-GRAY is true the hue of the source image is preserved by +converting the destination area to gray pixels before merging. + +The keyword options RESAMPLE, ROTATE, RESIZE, MERGE, and MERGE-GRAY +are mutually exclusive \(with the exception of RESAMPLE and +RESIZE). ANGLE is assumed to be specified in degrees if it's an +integer, and in radians otherwise." + (check-type source image) + (check-type destination image) + (check-type source-x integer) + (check-type source-y integer) + (unless rotate + (check-type dest-x integer) + (check-type dest-y integer)) + (check-type width integer) + (check-type height integer) + (check-type angle (or null number)) + (check-type dest-width (or null integer)) + (check-type dest-height (or null integer)) + (check-type merge (or null (integer 0 100))) + (check-type merge-gray (or null (integer 0 100))) + (when (and merge merge-gray) + (error "You can't specify MERGE and MERGE-GRAY at the same time.")) + (when (and (or merge merge-gray) + (or resample rotate resize)) + (error "MERGE and MERGE-GRAY can't be combined with RESAMPLE, ROTATE, or RESIZE.")) + (when (and (or dest-width dest-height) + (not resize)) + (error "Use RESIZE if you want to specify DEST-WIDTH or DEST-HEIGHT")) + (when (and resize + (not (or dest-width dest-height))) + (error "Please specify DEST-WIDTH and DEST-HEIGHT together with RESIZE.")) + (when (and angle + (not rotate)) + (error "Use ROTATE if you want to specify ANGLE.")) + (when (and rotate + (not angle)) + (error "Please specify ANGLE together with ROTATE.")) + (when (and rotate + (or resample resize)) + (error "ROTATE can't be used together with RESAMPLE or RESIZE.")) + (cond ((and resample resize) + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (resample + (gd-image-copy-resampled (img destination) (img source) + dest-x dest-y source-x source-y + width height width height)) + ((and rotate (integerp angle)) + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height angle)) + (rotate + (gd-image-copy-rotated (img destination) (img source) + (coerce dest-x 'double-float) + (coerce dest-y 'double-float) + source-x source-y width height + (round (* angle +radians-to-degree-factor+)))) + (resize + (gd-image-copy-resized (img destination) (img source) + dest-x dest-y source-x source-y + dest-width dest-height width height)) + (merge + (gd-image-copy-merge (img destination) (img source) + dest-x dest-y source-x source-y + width height merge)) + (merge-gray + (gd-image-copy-merge-gray (img destination) (img source) + dest-x dest-y source-x source-y + width height merge-gray)) + (t + (gd-image-copy (img destination) (img source) dest-x dest-y + source-x source-y width height))) + destination) + +(defun copy-palette (source destination) + "Copies palette of image SOURCE to image DESTINATION attempting to +match the colors in the target image to the colors in the source +palette." + (check-type source image) + (check-type destination image) + (gd-image-palette-copy (img destination) (img source)) + destination) + +(defun true-color-to-palette (&key dither (colors-wanted 256) (image *default-image*)) + "Converts the true color image IMAGE to a palette-based image using +a high-quality two-pass quantization routine. If DITHER is true, the +image will be dithered to approximate colors better, at the expense of +some obvious \"speckling.\" COLORS-WANTED can be any positive integer +up to 256 \(which is the default). If the original source image +includes photographic information or anything that came out of a JPEG, +256 is strongly recommended. 100% transparency of a single transparent +color in the original true color image will be preserved. There is no +other support for preservation of alpha channel or transparency in the +destination image." + (check-type image image) + (check-type colors-wanted (integer 0 256)) + (gd-image-true-color-to-palette (img image) + (if dither 1 0) + colors-wanted) + image) + +(defmacro do-rows ((y-var &optional (image '*default-image*)) &body body) + (with-rebinding (image) + (with-unique-names (img width height true-color-p raw-pixels row x-var inner-body) + `(let* ((,img (img ,image)) + (,width (gd-image-get-sx ,img)) + (,height (gd-image-get-sy ,img)) + (,true-color-p (true-color-p ,image))) + (declare (fixnum ,width ,height)) + (cond (,true-color-p + (let ((,raw-pixels (get-slot-value ,img 'gd-image 't-pixels))) + (declare (type t-pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :int)) ,y-var))) + (declare (type t-pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :int) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + ,@body)))))) + (t + (let ((,raw-pixels (get-slot-value ,img 'gd-image 'pixels))) + (declare (type pixels-array ,raw-pixels)) + (dotimes (,y-var ,height) + (let ((,row (deref-array ,raw-pixels '(:array (* :unsigned-char)) ,y-var))) + (declare (type pixels-row ,row)) + (macrolet ((do-pixels-in-row ((,x-var) &body ,inner-body) + `(dotimes (,,x-var ,',width) + (macrolet ((raw-pixel () + `(deref-array ,',',row '(:array :unsigned-char) ,',,x-var))) + (locally + ,@,inner-body))))) + (locally + ,@body))))))))))) + +(defmacro do-pixels ((&optional (image '*default-image*)) &body body) + (with-unique-names (x y) + `(do-rows (,y ,image) + (do-pixels-in-row (,x) + ,@body)))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/packages.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/packages.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,80 @@ +(in-package #:cl-user) + +(defpackage #:cl-gd + (:use #:cl #:uffi) + (:export #:*default-image* + #:*default-color* + #:*default-font* + #:+max-colors+ + #:without-transformations + #:with-transformation + #:create-image + #:destroy-image + #:with-image + #:create-image-from-file + #:with-image-from-file + #:create-image-from-gd2-part + #:with-image-from-gd2-part + #:with-default-image + #:with-image* + #:with-image-from-file* + #:with-image-from-gd2-part* + #:write-jpeg-to-stream + #:write-png-to-stream + #:write-wbmp-to-stream + #:write-gd-to-stream + #:write-gd2-to-stream + #-:cl-gd-no-gif #:write-gif-to-stream + #:write-image-to-stream + #:write-image-to-file + #:image-width + #:image-height + #:image-size + #:make-brush + #:make-tile + #:make-anti-aliased + #:with-default-color + #:allocate-color + #:deallocate-color + #:transparent-color + #:true-color-p + #:number-of-colors + #:find-color + #:find-color-from-image + #:thickness + #:with-thickness + #:alpha-blending-p + #:save-alpha-p + #:color-component + #:color-components + #:draw-polygon + #:draw-line + #:get-pixel + #:set-pixel + #:set-pixels + #:draw-rectangle + #:draw-rectangle* + #:draw-arc + #:draw-filled-ellipse + #:draw-filled-circle + #:fill-image + #:clipping-rectangle + #:clipping-rectangle* + #:set-clipping-rectangle* + #:with-clipping-rectangle + #:with-clipping-rectangle* + #:with-default-font + #:draw-character + #:draw-string + #:draw-freetype-string + #:interlacedp + #:differentp + #:copy-image + #:copy-palette + #:true-color-to-palette + #:do-rows + #:do-pixels-in-row + #:do-pixels + #:raw-pixel)) + +(pushnew :cl-gd *features*) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/specials.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/specials.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,173 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/specials.lisp,v 1.29 2007/01/01 23:41:00 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package #:cl-gd) + +(defvar *default-image* nil + "The default image. This special variable is usually bound by +WITH-IMAGE or WITH-IMAGE-FROM-FILE.") + +(defvar *default-color* nil + "The default color. This special variable is usually bound by +WITH-COLOR.") + +(defvar *default-font* nil + "The default font. This special variable is usually bound by +WITH-FONT.") + +(defstruct (image + (:conc-name nil) + (:constructor make-image (img)) + (:copier nil)) + img) + +(defstruct (brush + (:include image) + (:constructor %make-brush (img)) + (:copier nil))) + +(defun make-brush (image) + (%make-brush (img image))) + +(defstruct (tile + (:include image) + (:constructor %make-tile (img)) + (:copier nil))) + +(defun make-tile (image) + (%make-tile (img image))) + +(defstruct (anti-aliased-color + (:conc-name nil) + (:constructor %make-anti-aliased (color do-not-blend)) + (:copier nil)) + color do-not-blend) + +(defun make-anti-aliased (color &optional do-not-blend) + (%make-anti-aliased color do-not-blend)) + +;; the following variable will be initialized in "gd-uffi.lisp" +(defvar *null-image* nil + "A 'null' image which might be useful for DRAW-FREETYPE-STRING.") + +(defconstant +max-colors+ 256 + "Maximum number of colors for palette-based images.") + +(defconstant +gd-chord+ 1 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-no-fill+ 2 + "Used internally by GD-FILLED-ARC") +(defconstant +gd-edged+ 4 + "Used internally by GD-FILLED-ARC") + +(defconstant +brushed+ -3 + "Special 'color' for lines drawn with brush.") +(defconstant +styled+ -2 + "Special 'color' for styled lines.") +(defconstant +styled-brushed+ -4 + "Special 'color' for lines drawn with styled brush.") +(defconstant +transparent+ -6 + "Special 'color' used in GD function 'gdImageSetStyle' for transparent color.") +(defconstant +tiled+ -5 + "Special fill 'color' used for tiles.") +(defconstant +anti-aliased+ -7 + "Special 'color' for anti-aliased lines.") + +(defconstant +gd-ftex-linespace+ 1 + "Indicate line-spacing for FreeType library.") + +(defconstant +gd-cmp-image+ 1 + "Images will appear different when displayed.") +(defconstant +gd-cmp-num-colors+ 2 + "Number of colors in palette differ.") +(defconstant +gd-cmp-color+ 4 + "Image colors differ.") +(defconstant +gd-cmp-size-x+ 8 + "Image widths differ.") +(defconstant +gd-cmp-size-y+ 16 + "Image heights differ.") +(defconstant +gd-cmp-transparent+ 32 + "Transparent color is different.") +(defconstant +gd-cmp-background+ 64 + "Background color is different.") +(defconstant +gd-cmp-interlace+ 128 + "Interlace settings are different.") +(defconstant +gd-cmp-true-color+ 256 + "One image is a true-color image, the other one is palette-based.") + +(defvar *shared-library-directories* + `(,(namestring (make-pathname :name nil + :type nil + :version :newest + :defaults cl-gd.system:*cl-gd-directory*)) + "/usr/local/lib/" + "/usr/lib/" + "/usr/lib/cl-gd/" + "/cygwin/usr/local/lib/" + "/cygwin/usr/lib/") + "A list of directories where UFFI tries to find cl-gd-glue.so") +(defvar *shared-library-types* '("so" "dll" "dylib") + "The list of types a shared library can have. Used when looking for +cl-gd-glue.so") +(defvar *shared-library-drive-letters* '("C" "D" "E" "F" "G") + "The list of drive letters \(used by Wintendo) used when looking for +cl-gd-glue.dll.") + +(defvar *gd-supporting-libraries* '("c" "gd" "png" "z" "jpeg" "freetype" "iconv" "m") + "The libraries which are needed by cl-gd-glues.so \(and GD +itself). Only needed for Python-based Lisps like CMUCL, SBCL, or +SCL.") + +(defconstant +radians-to-degree-factor+ (/ 360 (* 2 pi)) + "Factor to convert from radians to degrees.") + +(defvar *transformers* nil + "Stack of currently active transformer objects.") + +(defconstant +most-positive-unsigned-byte-32+ + (1- (expt 2 31)) + "Name says it all...") + +;; stuff for Nikodemus Siivola's HYPERDOC +;; see <http://common-lisp.net/project/hyperdoc/> +;; and <http://www.cliki.net/hyperdoc> + +(defvar *hyperdoc-base-uri* "http://weitz.de/cl-gd/") + +(let ((exported-symbols-alist + (loop for symbol being the external-symbols of :cl-gd + collect (cons symbol + (concatenate 'string + "#" + (string-downcase symbol)))))) + (defun hyperdoc-lookup (symbol type) + (declare (ignore type)) + (cdr (assoc symbol + exported-symbols-alist + :test #'eq)))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/strings.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/strings.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,194 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/strings.lisp,v 1.23 2007/04/24 09:01:39 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defmacro with-default-font ((font) &body body) + "Execute BODY with *DEFAULT-FONT* bound to FONT so that you +don't have to provide the FONT keyword/optional argument to +string functions. But note that the fonts used for +DRAW-STRING/DRAW-CHARACTER and DRAW-FREETYPE-STRING are +incompatible." + `(let ((*default-font* ,font)) + ,@body)) + +(defun draw-character (x y char &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the character CHAR from font FONT in color COLOR at position +\(X,Y). If UP is true the character will be drawn from bottom to top +\(rotated 90 degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, +:LARGE, :GIANT." + (check-type char character) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (if up + (gd-image-char-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color) + (gd-image-char (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y (char-code char) color)))) + char) + +(defun draw-string (x y string &key up (font *default-font*) (color *default-color*) (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y). If UP is +true the character will be drawn from bottom to top \(rotated 90 +degrees). FONT must be one of :TINY, :SMALL, :MEDIUM, :LARGE, :GIANT." + (check-type string string) + (check-type image image) + (with-color-argument + (with-transformed-alternative + ((x x-transformer) + (y y-transformer)) + (with-cstring (c-string string) + (if up + (gd-image-string-up (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color) + (gd-image-string (img image) (ecase font + ((:tiny) +gd-font-tiny+) + ((:small) +gd-font-small+) + ((:medium :medium-bold) +gd-font-medium-bold+) + ((:large) +gd-font-large+) + ((:giant) +gd-font-giant+)) + x y c-string color))))) + string) + +(defun draw-freetype-string (x y string + &key (anti-aliased t) + (point-size 12.0d0) + (angle 0.0d0) + (convert-chars t) + line-spacing + (font-name *default-font*) + do-not-draw + (color *default-color*) + (image *default-image*)) + "Draws the string STRING in color COLOR at position \(X,Y) using the +FreeType library. FONT-NAME is the full path \(a pathname or a string) +to a TrueType font file, or a font face name if the GDFONTPATH +environment variable or FreeType's DEFAULT_FONTPATH variable have been +set intelligently. The string may be arbitrarily scaled \(POINT-SIZE) +and rotated \(ANGLE in radians). The direction of rotation is +counter-clockwise, with 0 radians \(0 degrees) at 3 o'clock and PI/2 +radians \(90 degrees) at 12 o'clock. Note that the ANGLE argument is +purposefully _not_ affected by WITH-TRANSFORMATION. If ANTI-ALIASED if +false, anti-aliasing is disabled. It is enabled by default. To output +multiline text with a specific line spacing, provide a value for +LINE-SPACING, expressed as a multiple of the font height. The default +is to use 1.05. The string may contain XML character entity references +like \"À\". If CONVERT-CHARS is true \(which is the default) +characters of STRING with CHAR-CODE greater than 127 are converted +accordingly. This of course pre-supposes that your Lisp's CHAR-CODE +function returns ISO/IEC 10646 (Unicode) character codes. + +The return value is an array containing 8 elements representing the 4 +corner coordinates \(lower left, lower right, upper right, upper left) +of the bounding rectangle around the string that was drawn. The points +are relative to the text regardless of the angle, so \"upper left\" +means in the top left-hand corner seeing the text horizontally. Set +DO-NOT-DRAW to true to get the bounding rectangle without +rendering. This is a relatively cheap operation if followed by a +rendering of the same string, because of the caching of the partial +rendering during bounding rectangle calculation." + (check-type string string) + (check-type font-name (or pathname string)) + (unless do-not-draw + (check-type color integer) + (check-type image image)) + (with-transformed-alternative + ((x x-transformer) + (y y-transformer) + ((deref-array c-bounding-rectangle '(:array :int) i) x-inv-transformer) + ((deref-array c-bounding-rectangle '(:array :int) (1+ i)) y-inv-transformer)) + (when do-not-draw + (setq color 0 + image *null-image*)) + (when (pathnamep font-name) + (setq font-name (namestring font-name))) + (when convert-chars + (setq string (convert-to-char-references string))) + (with-cstring (c-font-name font-name) + (with-cstring (c-string string) + (with-safe-alloc (c-bounding-rectangle + (allocate-foreign-object :int 8) + (free-foreign-object c-bounding-rectangle)) + (let ((msg (convert-from-cstring + (cond (line-spacing + (with-foreign-object (strex 'gd-ft-string-extra) + (setf (get-slot-value strex + 'gd-ft-string-extra + 'flags) + +gd-ftex-linespace+ + (get-slot-value strex + 'gd-ft-string-extra + 'line-spacing) + (coerce line-spacing 'double-float)) + (gd-image-string-ft-ex (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string + strex))) + (t + (gd-image-string-ft (img image) + c-bounding-rectangle + (if anti-aliased color (- color)) + c-font-name + (coerce point-size 'double-float) + (coerce angle 'double-float) + x y + c-string)))))) + (when msg + (error "Error in FreeType library: ~A" msg)) + (let ((bounding-rectangle (make-array 8))) + ;; strange iteration due to WITH-TRANSFORMED-ALTERNATIVE + (loop for i below 8 by 2 do + (setf (aref bounding-rectangle i) + (deref-array c-bounding-rectangle '(:array :int) i)) + (setf (aref bounding-rectangle (1+ i)) + (deref-array c-bounding-rectangle '(:array :int) (1+ i)))) + bounding-rectangle))))))) \ No newline at end of file Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/demoin.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/anti-aliased-lines.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/brushed-arc.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/chart.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/circle.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/clipped-tangent.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-line.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/one-pixel.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/triangle.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-ellipse.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/orig/zappa-green.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/smallzappa.png ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/test/zappa.jpg ============================================================================== Binary file. No diff available. Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/transform.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/transform.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,193 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/transform.lisp,v 1.21 2007/07/29 16:37:13 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +(defclass transformer () + ((image :initarg :image + :reader image) + (w-transformer :initarg :w-transformer + :reader w-transformer + :type function) + (h-transformer :initarg :h-transformer + :reader h-transformer + :type function) + (x-transformer :initarg :x-transformer + :reader x-transformer + :type function) + (y-transformer :initarg :y-transformer + :reader y-transformer + :type function) + (w-inv-transformer :initarg :w-inv-transformer + :reader w-inv-transformer + :type function) + (h-inv-transformer :initarg :h-inv-transformer + :reader h-inv-transformer + :type function) + (x-inv-transformer :initarg :x-inv-transformer + :reader x-inv-transformer + :type function) + (y-inv-transformer :initarg :y-inv-transformer + :reader y-inv-transformer + :type function) + (angle-transformer :initarg :angle-transformer + :reader angle-transformer + :type function)) + (:documentation "Class used internally for WITH-TRANSFORMATION +macro.")) + +(defmacro without-transformations (&body body) + "Executes BODY without any transformations applied." + `(let (*transformers*) + ,@body)) + +(declaim (inline round-to-c-int)) +(defun round-to-signed-byte-32 (x) + "Like ROUND but make sure result isn't longer than 32 bits." + (mod (round x) +most-positive-unsigned-byte-32+)) + +(defmacro with-transformation ((&key x1 x2 width y1 y2 height reverse-x reverse-y (radians t) (image '*default-image*)) &body body) + "Executes BODY such that all points and width/height data are +subject to a simple affine transformation defined by the keyword +parameters. The new x-axis of IMAGE will start at X1 and end at X2 and +have length WIDTH. The new y-axis of IMAGE will start at Y1 and end at +Y2 and have length HEIGHT. In both cases it suffices to provide two of +the three values - if you provide all three they have to match. If +REVERSE-X is false the x-axis will be oriented as usual in Cartesian +coordinates, otherwise its direction will be reversed. The same +applies to REVERSE-Y, of course. If RADIANS is true angles inside of +BODY will be assumed to be provided in radians, otherwise in degrees." + (with-rebinding (x1 x2 width y1 y2 height reverse-x reverse-y radians image) + (with-unique-names (image-width image-height + stretch-x stretch-y + w-transformer h-transformer + x-transformer y-transformer + w-inv-transformer h-inv-transformer + x-inv-transformer y-inv-transformer + angle-transformer) + ;; rebind for thread safety + `(let ((*transformers* *transformers*)) + (unless (<= 2 (count-if #'identity (list ,x1 ,x2 ,width))) + (error "You must provide at least two of X1, X2, and WIDTH.")) + (unless (<= 2 (count-if #'identity (list ,y1 ,y2 ,height))) + (error "You must provide at least two of Y1, Y2, and HEIGHT.")) + (when (and ,x1 ,x2 ,width + (/= ,width (- ,x2 ,x1))) + (error "X1, X2, and WIDTH don't match. Try to provide just two of the three arguments.")) + (when (and ,y1 ,y2 ,height + (/= ,height (- ,y2 ,y1))) + (error "Y1, Y2, and HEIGHT don't match. Try to provide just two of the three arguments.")) + ;; kludgy code to keep SBCL quiet + (unless ,x1 (setq ,x1 (- ,x2 ,width))) + (unless ,x2 (setq ,x2 (+ ,x1 ,width))) + (unless ,width (setq ,width (- ,x2 ,x1))) + (unless ,y1 (setq ,y1 (- ,y2 ,height))) + (unless ,y2 (setq ,y2 (+ ,y1 ,height))) + (unless ,height (setq ,height (- ,y2 ,y1))) + (multiple-value-bind (,image-width ,image-height) + (without-transformations + (image-size ,image)) + (let* ((,stretch-x (/ ,image-width ,width)) + (,stretch-y (/ ,image-height ,height)) + (,w-transformer (lambda (w) + (round-to-signed-byte-32 + (* w ,stretch-x)))) + (,w-inv-transformer (lambda (w) + (/ w ,stretch-x))) + (,h-transformer (lambda (h) + (round-to-signed-byte-32 + (* h ,stretch-y)))) + (,h-inv-transformer (lambda (h) + (/ h ,stretch-y))) + (,x-transformer (if ,reverse-x + (lambda (x) + (round-to-signed-byte-32 + (* (- ,x2 x) ,stretch-x))) + (lambda (x) + (round-to-signed-byte-32 + (* (- x ,x1) ,stretch-x))))) + (,x-inv-transformer (if ,reverse-x + (lambda (x) + (- ,x2 (/ x ,stretch-x))) + (lambda (x) + (+ ,x1 (/ x ,stretch-x))))) + (,y-transformer (if ,reverse-y + (lambda (y) + (round-to-signed-byte-32 + (* (- y ,y1) ,stretch-y))) + (lambda (y) + (round-to-signed-byte-32 + (* (- ,y2 y) ,stretch-y))))) + (,y-inv-transformer (if ,reverse-y + (lambda (y) + (+ ,y1 (/ y ,stretch-y))) + (lambda (y) + (- ,y2 (/ y ,stretch-y))))) + (,angle-transformer (cond (,radians + (lambda (angle) + (round-to-signed-byte-32 + (* angle + +radians-to-degree-factor+)))) + (t + #'identity)))) + (push (make-instance 'transformer + :image ,image + :w-transformer ,w-transformer + :h-transformer ,h-transformer + :x-transformer ,x-transformer + :y-transformer ,y-transformer + :w-inv-transformer ,w-inv-transformer + :h-inv-transformer ,h-inv-transformer + :x-inv-transformer ,x-inv-transformer + :y-inv-transformer ,y-inv-transformer + :angle-transformer ,angle-transformer) + *transformers*) + (unwind-protect + (progn + ,@body) + (pop *transformers*)))))))) + +(defmacro with-transformed-alternative ((&rest transformations) &body body) + "Internal macro used to make functions +transformation-aware. TRANSFORMATION is a list of (EXPR +TRANSFORMATION) pairs where each EXPR will be replaced by the +transformation denoted by TRANSFORMATION." + (with-unique-names (transformer) + (let ((transformations-alist + (loop for (expr transformation) in transformations + collect `(,expr . (funcall (,transformation ,transformer) ,expr))))) + ;; note that we always use the name 'IMAGE' - no problem because + ;; this is a private macro + `(let ((,transformer (find image *transformers* :key #'image))) + (cond (,transformer + ,(sublis transformations-alist + `(progn ,@body) + :test #'equal)) + (t (progn + ,@body))))))) Added: branches/trunk-reorg/thirdparty/cl-gd-0.5.6/util.lisp ============================================================================== --- (empty file) +++ branches/trunk-reorg/thirdparty/cl-gd-0.5.6/util.lisp Thu Jan 31 05:22:39 2008 @@ -0,0 +1,136 @@ +;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-GD; Base: 10 -*- +;;; $Header: /usr/local/cvsrep/gd/util.lisp,v 1.15 2007/02/28 15:47:58 edi Exp $ + +;;; Copyright (c) 2003-2007, Dr. Edmund Weitz. All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: + +;;; * Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. + +;;; * Redistributions in binary form must reproduce the above +;;; copyright notice, this list of conditions and the following +;;; disclaimer in the documentation and/or other materials +;;; provided with the distribution. + +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED +;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY +;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(in-package :cl-gd) + +#+:lispworks +(import 'lw:with-unique-names) + +#-:lispworks +(defmacro with-unique-names ((&rest bindings) &body body) + "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form* + +Executes a series of forms with each VAR bound to a fresh, +uninterned symbol. The uninterned symbol is as if returned by a call +to GENSYM with the string denoted by X - or, if X is not supplied, the +string denoted by VAR - as argument. + +The variable bindings created are lexical unless special declarations +are specified. The scopes of the name bindings and declarations do not +include the Xs. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3bshuf30f.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + `(let ,(mapcar #'(lambda (binding) + (check-type binding (or cons symbol)) + (if (consp binding) + (destructuring-bind (var x) binding + (check-type var symbol) + `(,var (gensym ,(etypecase x + (symbol (symbol-name x)) + (character (string x)) + (string x))))) + `(,binding (gensym ,(symbol-name binding))))) + bindings) + ,@body)) + +#+:lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (macro-function 'with-rebinding) + (macro-function 'lw:rebinding))) + +#-:lispworks +(defmacro with-rebinding (bindings &body body) + "REBINDING ( { var | (var prefix) }* ) form* + +Evaluates a series of forms in the lexical environment that is +formed by adding the binding of each VAR to a fresh, uninterned +symbol, and the binding of that fresh, uninterned symbol to VAR's +original value, i.e., its value in the current lexical environment. + +The uninterned symbol is created as if by a call to GENSYM with the +string denoted by PREFIX - or, if PREFIX is not supplied, the string +denoted by VAR - as argument. + +The forms are evaluated in order, and the values of all but the last +are discarded \(that is, the body is an implicit PROGN)." + ;; reference implementation posted to comp.lang.lisp as + ;; <cy3wv0fya0p.fsf(a)ljosa.com> by Vebjorn Ljosa - see also + ;; <http://www.cliki.net/Common%20Lisp%20Utilities> + (loop for binding in bindings + for var = (if (consp binding) (car binding) binding) + for name = (gensym) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names ,bindings + `(let (,,@temps) + ,,@body)))))) + +(defun sans (plist &rest keys) + "Returns PLIST with keyword arguments from KEYS removed." + ;; stolen from Usenet posting <3247672165664225(a)naggum.no> by Erik + ;; Naggum + (let ((sans ())) + (loop + (let ((tail (nth-value 2 (get-properties plist keys)))) + ;; this is how it ends + (unless tail + (return (nreconc sans plist))) + ;; copy all the unmatched keys + (loop until (eq plist tail) do + (push (pop plist) sans) + (push (pop plist) sans)) + ;; skip the matched key + (setq plist (cddr plist)))))) + +(defun convert-to-char-references (string) + "Returns a string where all characters of STRING with CHAR-CODE +greater than 127 are converted to XML character entities." + (with-output-to-string (s) + (with-standard-io-syntax + (loop for char across string + for char-code = (char-code char) + when (<= char-code 127) do + (write-char char s) + else do + (write-char #\& s) + (write-char #\# s) + (princ char-code s) + (write-char #\; s))))) + +(defmacro with-safe-alloc ((var alloc free) &rest body) + `(let (,var) + (unwind-protect + (progn (setf ,var ,alloc) + ,@body) + (when ,var ,free)))) \ No newline at end of file

1 0

[bknr-cvs] r2427 - branches/bos/projects/bos/payment-website/templates/en
by hhubner＠common-lisp.net 31 Jan '08

31 Jan '08

Author: hhubner Date: Thu Jan 31 03:09:17 2008 New Revision: 2427 Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml Log: Rearrange a little to gain more screen space. Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Thu Jan 31 03:09:17 2008 @@ -67,23 +67,10 @@ <tr> <td class="Label">action message</td> <td class="Input"> - <button name="action" type="submit" value="save" onclick="javascript:return formcheck();">SAVE</button> - </td> - <td class="Info">Your personal profile data will be updated with the entered data.</td> - </tr> - <tr> - <td class="Label"></td> - <td class="Input"> - <button name="anonymize" type="submit" value="anonymize" onclick="javascript:return anonymizecheck();">make profile anonymous</button> - </td> - <td class="Info">Your personal data will be hidden.</td> - </tr> - <tr> - <td class="Label"></td> - <td class="Input"> + <button name="action" type="submit" value="save" onclick="javascript:return formcheck();">Save</button> <button name="action" type="reset">discard changes</button> </td> - <td class="Info">All arranged changes have been discarded.</td> + <td class="Info">Update profile or discard changes.</td> </tr> <bos:when-certificate> <tr>

1 0

[bknr-cvs] r2426 - in branches/bos/projects/bos: payment-website/templates/da payment-website/templates/de payment-website/templates/en web
by ksprotte＠common-lisp.net 31 Jan '08

31 Jan '08

Author: ksprotte Date: Thu Jan 31 02:16:47 2008 New Revision: 2426 Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml branches/bos/projects/bos/payment-website/templates/de/profil.xml branches/bos/projects/bos/payment-website/templates/en/profil.xml branches/bos/projects/bos/web/tags.lisp Log: Einbau eines Google Earth Links auf die Profilseite #15 Modified: branches/bos/projects/bos/payment-website/templates/da/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/da/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/da/profil.xml Thu Jan 31 02:16:47 2008 @@ -55,7 +55,8 @@ </tr> <tr> <td class="Label">kvardratmeter</td> - <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt UTM-kordinater: N$(sqm-x) E$(sqm-y)</td> + <td class="Input">til værdi af $(numsqm) m² er blevet opkøbt UTM-kordinater: N$(sqm-x) E$(sqm-y) + <a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/payment-website/templates/de/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/de/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/de/profil.xml Thu Jan 31 02:16:47 2008 @@ -60,7 +60,8 @@ </tr> <tr> <td class="Label">Quadratmeter</td> - <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft UTM-Koordinate: N$(sqm-x) E$(sqm-y)</td> + <td class="Input">Insgesamt $(numsqm) Quadratmeter gekauft UTM-Koordinate: N$(sqm-x) E$(sqm-y) + <a href="/contract-kml/$(contract-id)">Ihre Quadratmeter in Google Earth</a></td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/payment-website/templates/en/profil.xml ============================================================================== --- branches/bos/projects/bos/payment-website/templates/en/profil.xml (original) +++ branches/bos/projects/bos/payment-website/templates/en/profil.xml Thu Jan 31 02:16:47 2008 @@ -60,7 +60,8 @@ </tr> <tr> <td class="Label">square metres</td> - <td class="Input">a total of $(numsqm) m² has been bought UTM-coordinate: N$(sqm-x) E$(sqm-y)</td> + <td class="Input">a total of $(numsqm) m² has been bought UTM-coordinate: N$(sqm-x) E$(sqm-y) + <a href="/contract-kml/$(contract-id)">Your square metres in Google Earth</a></td> <td class="Info"></td> </tr> <tr> Modified: branches/bos/projects/bos/web/tags.lisp ============================================================================== --- branches/bos/projects/bos/web/tags.lisp (original) +++ branches/bos/projects/bos/web/tags.lisp Thu Jan 31 02:16:47 2008 @@ -147,7 +147,8 @@ (mapc #'emit-template-node children)) (define-bknr-tag save-profile (&key children) - (let ((sponsor (bknr-request-user (get-template-var :request)))) + (let* ((sponsor (bknr-request-user (get-template-var :request))) + (contract (first (sponsor-contracts sponsor)))) (with-template-vars (email name password infotext anonymize) (when anonymize (change-slot-values sponsor @@ -163,11 +164,12 @@ (when infotext (change-slot-values sponsor 'info-text infotext))) (setf (get-template-var :sponsor-id) (format nil "~D" (store-object-id sponsor))) + (setf (get-template-var :contract-id) (format nil "~D" (store-object-id contract))) (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) - (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor))))))) - (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor))))))) + (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) + (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) (setf (get-template-var :numsqm) (format nil "~D" (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))

1 0

[bknr-cvs] r2425 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 31 Jan '08

31 Jan '08

Author: ksprotte Date: Thu Jan 31 01:45:23 2008 New Revision: 2425 Modified: branches/bos/projects/bos/web/kml-handlers.lisp Log: Anzeige der Sponsor-Informationen wie in der Sat-App #17 Modified: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/kml-handlers.lisp (original) +++ branches/bos/projects/bos/web/kml-handlers.lisp Thu Jan 31 01:45:23 2008 @@ -6,12 +6,37 @@ (defun kml-format-color (color &optional (opacity 255)) (format nil "~2,'0X~{~2,'0X~}" opacity (reverse color))) -(defun utf8-text (string) - ;; cxml::utf8-string-to-rod did not - ;; what we want, so we use utf-8-string-to-bytes - ;; instead +(defun utf-8-text (string) + ;; cxml::utf8-string-to-rod did not what we want, so we use + ;; utf-8-string-to-bytes instead (cxml:text (utf-8-string-to-bytes string))) +(defun contract-description (contract language) + (declare (ignore language)) + (let* ((sponsor (contract-sponsor contract)) + (name (user-full-name sponsor))) + (map 'string #'code-char + (with-xml-output (cxml:make-octet-vector-sink) + (with-element "div" + (with-element "table" + (with-element "tr" + (with-element "td" (text "Sponsor-ID:")) + (with-element "td" (text (princ-to-string (store-object-id sponsor))))) + (with-element "tr" + (with-element "td" (text "Name:")) + (with-element "td" (utf-8-text (if name name "[anonymous]")))) + (with-element "tr" + (with-element "td" (text "Land:")) + (with-element "td" (text (sponsor-country sponsor)))) + (with-element "tr" + (with-element "td" (text "gesponsort:")) + (with-element "td" (utf-8-text (format nil "~D m²" (length (contract-m2s contract)))))) + (with-element "tr" + (with-element "td" (text "seit:")) + (with-element "td" (text (format-date-time (contract-date contract) :show-time nil))))) + (when (sponsor-info-text sponsor) + (utf-8-text (sponsor-info-text sponsor)))))))) + (defclass contract-kml-handler (object-handler) ()) @@ -24,16 +49,16 @@ (let ((polygon (m2s-polygon-lon-lat (contract-m2s c))) (name (user-full-name (contract-sponsor c)))) (with-element "Placemark" - (with-element "name" (utf8-text (format nil "~A ~Dm²" - (if name name "anonymous") - (length (contract-m2s c))))) - (with-element "description" (utf8-text "a description")) + (with-element "name" (utf-8-text (format nil "~A ~Dm²" + (if name name "anonymous") + (length (contract-m2s c))))) + (with-element "description" (utf-8-text (contract-description c :de))) (with-element "Style" (attribute "id" "#region") (with-element "LineStyle" (with-element "color" (text "ffff3500"))) (with-element "PolyStyle" - (with-element "color" (text (kml-format-color (contract-color c) 175))))) + (with-element "color" (text (kml-format-color (contract-color c) 175))))) (with-element "Polygon" (with-element "styleUrl" "#region") (with-element "tessellate" (text "1")) @@ -44,10 +69,10 @@ ;; the center contract (when (eq c contract) (with-element "Placemark" - (with-element "name" (utf8-text "YOUR m²s!")) - (with-element "description" (utf8-text (format nil "~A ~Dm2" - (if name name "anonymous") - (length (contract-m2s c))))) + (with-element "name" (utf-8-text (format nil "~A ~Dm²" + (if name name "anonymous") + (length (contract-m2s c))))) + (with-element "description" (utf-8-text (contract-description c :de))) (with-element "Point" (with-element "coordinates" (text (kml-format-points (list (contract-center-lon-lat c)))))))))))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs January 2008