Author: junrue Date: Wed Aug 2 17:37:56 2006 New Revision: 199

Added: trunk/src/external-libraries/ trunk/src/external-libraries/practicals-1.0.3/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp trunk/src/external-libraries/practicals-1.0.3/LICENSE trunk/src/external-libraries/practicals-1.0.3/readme.txt trunk/src/uitoolkit/graphics/plugins/default/ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Modified: trunk/build.lisp trunk/config.lisp trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Log: initial work on default graphics data plugin

Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Wed Aug 2 17:37:56 2006 @@ -44,14 +44,16 @@ (defvar *asdf-repo-root* (concatenate 'string *library-root* "asdf-repo/")) (defvar *project-root* "c:/projects/public/")

-(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) -(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) -(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) -(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) -(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *cells-dir* (concatenate 'string *asdf-repo-root* "cells/")) +(setf *cffi-dir* (concatenate 'string *asdf-repo-root* "cffi-060606/")) +(setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) +(setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) +(setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) +(setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/"))

-(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/"))

(defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/")

Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Wed Aug 2 17:37:56 2006 @@ -39,16 +39,20 @@

(in-package #:graphic-forms-system)

-(defvar *cells-dir* "cells/") -(defvar *cffi-dir* "cffi-060606/") -(defvar *closer-mop-dir* "closer-mop/") -(defvar *lw-compat-dir* "lw-compat/") -(defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) +(defvar *cells-dir* "cells/") +(defvar *cffi-dir* "cffi-060606/") +(defvar *closer-mop-dir* "closer-mop/") +(defvar *lw-compat-dir* "lw-compat/") +(defvar *macro-utilities-dir* "macro-utilities/") +(defvar *gf-dir* "graphic-forms/")

-(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "lisp-unit")

(defun configure-asdf () - (pushnew *cells-dir* asdf:*central-registry* :test #'equal) - (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) - (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) - (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal)) + (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) + (pushnew *cells-dir* asdf:*central-registry* :test #'equal) + (pushnew *cffi-dir* asdf:*central-registry* :test #'equal) + (pushnew *closer-mop-dir* asdf:*central-registry* :test #'equal) + (pushnew *lw-compat-dir* asdf:*central-registry* :test #'equal) + (pushnew *macro-utilities-dir* asdf:*central-registry* :test #'equal))

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 2 17:37:56 2006 @@ -42,7 +42,7 @@ :version "0.3.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cffi" "lw-compat" "closer-mop") + :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") :components ((:module "src" :components @@ -82,14 +82,16 @@ (:module "plugins" :components ((:file "graphics-plugin-packages") -#+load-imagemagick-plugin - (:module "imagemagick" - ; :depends-on ("graphics") - :components - ((:file "magick-core-types") - (:file "magick-core-api") - (:file "magick-data-plugin" - :depends-on ("magick-core-types" "magick-core-api")))))))) +#-skip-default-plugin (:module "default" + :components + ((:file "file-formats") + (:file "default-data-plugin"))) +#+load-imagemagick-plugin (:module "imagemagick" + :components + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "magick-data-plugin" + :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") :components

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/chapter-8.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-8-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-8-system) + +(defsystem chapter-8 + :name "chapter-8" + :author "Peter Seibel peter@gigamonkeys.com" + :version "1.0" + :maintainer "Peter Seibel peter@gigamonkeys.com" + :licence "BSD" + :description "Code from Chapter 8 of Practical Common Lisp" + :long-description "" + :depends-on ("macro-utilities")) + +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.macro-utilities-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.macro-utilities-system) + +(defsystem macro-utilities + :name "macro-utilities" + :author "Peter Seibel peter@gigamonkeys.com" + :version "1.0" + :maintainer "Peter Seibel peter@gigamonkeys.com" + :licence "BSD" + :description "Utilities for writing macros" + :long-description "" + :components + ((:file "packages") + (:file "macro-utilities" :depends-on ("packages"))) + :depends-on ()) + +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/macro-utilities.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,28 @@ +(in-package :com.gigamonkeys.macro-utilities) + +(defmacro with-gensyms ((&rest names) &body body) + `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym (string n))))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun spliceable (value) + (if value (list value))) + +(defmacro ppme (form &environment env) + (progn + (write (macroexpand-1 form env) + :length nil + :level nil + :circle nil + :pretty t + :gensym nil + :right-margin 83 + :case :downcase) + nil)) +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter08/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,11 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.macro-utilities + (:use :common-lisp) + (:export + :with-gensyms + :with-gensymed-defuns + :once-only + :spliceable + :ppme)) +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,17 @@ +(defpackage :com.gigamonkeys.binary-data-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.binary-data-system) + +(defsystem binary-data + :name "binary-data" + :author "Peter Seibel peter@gigamonkeys.com" + :version "1.0" + :maintainer "Peter Seibel peter@gigamonkeys.com" + :licence "BSD" + :description "Parser for binary data files. " + :long-description "" + :components + ((:file "packages") + (:file "binary-data" :depends-on ("packages"))) + :depends-on (:macro-utilities)) + +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/binary-data.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,160 @@ +(in-package :com.gigamonkeys.binary-data) + +(defvar *in-progress-objects* nil) + +(defconstant +null+ (code-char 0)) + +(defgeneric read-value (type stream &key) + (:documentation "Read a value of the given type from the stream.")) + +(defgeneric write-value (type stream value &key) + (:documentation "Write a value as the given type to the stream.")) + +(defgeneric read-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Fill in the slots of object from stream.")) + +(defgeneric write-object (object stream) + (:method-combination progn :most-specific-last) + (:documentation "Write out the slots of object to the stream.")) + +(defmethod read-value ((type symbol) stream &key) + (let ((object (make-instance type))) + (read-object object stream) + object)) + +(defmethod write-value ((type symbol) stream value &key) + (assert (typep value type)) + (write-object value stream)) + + +;;; Binary types + +(defmacro define-binary-type (name (&rest args) &body spec) + (with-gensyms (type stream value) + `(progn + (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args) + (declare (ignorable ,@args)) + ,(type-reader-body spec stream)) + (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) + (declare (ignorable ,@args)) + ,(type-writer-body spec stream value))))) + +(defun type-reader-body (spec stream) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(read-value ',type ,stream ,@args))) + (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) + `(let ((,in ,stream)) ,@body))))) + +(defun type-writer-body (spec stream value) + (ecase (length spec) + (1 (destructuring-bind (type &rest args) (mklist (first spec)) + `(write-value ',type ,stream ,value ,@args))) + (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) + `(let ((,out ,stream) (,v ,value)) ,@body))))) + + +;;; Binary classes + +(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) + (with-gensyms (objectvar streamvar) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get ',name 'slots) ',(mapcar #'first slots)) + (setf (get ',name 'superclasses) ',superclasses)) + + (defclass ,name ,superclasses + ,(mapcar #'slot->defclass-slot slots)) + + ,read-method + + (defmethod write-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) + +(defmacro define-binary-class (name (&rest superclasses) slots) + (with-gensyms (objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-object progn ((,objectvar ,name) ,streamvar) + (declare (ignorable ,streamvar)) + (with-slots ,(new-class-all-slots slots superclasses) ,objectvar + ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) + +(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) + (with-gensyms (typevar objectvar streamvar) + `(define-generic-binary-class ,name ,superclasses ,slots + (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) + (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) + (let ((,objectvar + (make-instance + ,@(or (cdr (assoc :dispatch options)) + (error "Must supply :disptach form.")) + ,@(mapcan #'slot->keyword-arg slots)))) + (read-object ,objectvar ,streamvar) + ,objectvar)))))) + +(defun as-keyword (sym) (intern (string sym) :keyword)) + +(defun normalize-slot-spec (spec) + (list (first spec) (mklist (second spec)))) + +(defun mklist (x) (if (listp x) x (list x))) + +(defun slot->defclass-slot (spec) + (let ((name (first spec))) + `(,name :initarg ,(as-keyword name) :accessor ,name))) + +(defun slot->read-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(setf ,name (read-value ',type ,stream ,@args)))) + +(defun slot->write-value (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(write-value ',type ,stream ,name ,@args))) + +(defun slot->binding (spec stream) + (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) + `(,name (read-value ',type ,stream ,@args)))) + +(defun slot->keyword-arg (spec) + (let ((name (first spec))) + `(,(as-keyword name) ,name))) + +;;; Keeping track of inherited slots + +(defun direct-slots (name) + (copy-list (get name 'slots))) + +(defun inherited-slots (name) + (loop for super in (get name 'superclasses) + nconc (direct-slots super) + nconc (inherited-slots super))) + +(defun all-slots (name) + (nconc (direct-slots name) (inherited-slots name))) + +(defun new-class-all-slots (slots superclasses) + "Like all slots but works while compiling a new class before slots +and superclasses have been saved." + (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) + +;;; In progress Object stack + +(defun current-binary-object () + (first *in-progress-objects*)) + +(defun parent-of-type (type) + (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) + +(defmethod read-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) + +(defmethod write-object :around (object stream) + (declare (ignore stream)) + (let ((*in-progress-objects* (cons object *in-progress-objects*))) + (call-next-method))) +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/chapter-24.asd Wed Aug 2 17:37:56 2006 @@ -0,0 +1,14 @@ +(defpackage :com.gigamonkeys.chapter-24-system (:use :asdf :cl)) +(in-package :com.gigamonkeys.chapter-24-system) + +(defsystem chapter-24 + :name "chapter-24" + :author "Peter Seibel peter@gigamonkeys.com" + :version "1.0" + :maintainer "Peter Seibel peter@gigamonkeys.com" + :licence "BSD" + :description "Code from Chapter 24 of Practical Common Lisp" + :long-description "" + :depends-on ("binary-data")) + +

Added: trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/Chapter24/packages.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,13 @@ +(in-package :cl-user) + +(defpackage :com.gigamonkeys.binary-data + (:use :common-lisp :com.gigamonkeys.macro-utilities) + (:export :define-binary-class + :define-tagged-binary-class + :define-binary-type + :read-value + :write-value + :*in-progress-objects* + :parent-of-type + :current-binary-object + :+null+))

Added: trunk/src/external-libraries/practicals-1.0.3/LICENSE ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/LICENSE Wed Aug 2 17:37:56 2006 @@ -0,0 +1,29 @@ +Copyright (c) 2005, Peter Seibel 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. + + * Neither the name of the Peter Seibel nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS 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 COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Added: trunk/src/external-libraries/practicals-1.0.3/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/practicals-1.0.3/readme.txt Wed Aug 2 17:37:56 2006 @@ -0,0 +1,12 @@ +This directory contains a subset of the source code for +_Practical Common Lisp_ by Peter Seibel. The subset consists +of the code from two chapters of that book: Chapter 8 defining +a set of macro utilities that is needed by the binary file +input/output library featured in Chapter 24. + +The LICENSE file contains Peter Seibel's license statement +for this code. + +The complete distribution may be downloaded from: + + http://gigamonkeys.com/book/practicals-1.0.3.zip

Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Wed Aug 2 17:37:56 2006 @@ -33,7 +33,8 @@

(in-package :graphic-forms.uitoolkit.graphics)

-(defvar *image-plugins* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *image-plugins* nil))

;; ;; list the superset of file extensions for formats that any

Added: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,53 @@ +;;;; +;;;; default-data-plugin.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. 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. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS 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 :graphic-forms.uitoolkit.graphics.default) + +(defclass default-data-plugin (gfg:image-data-plugin) () + (:documentation "Default library plugin for the graphics package.")) + +(defun accepts-file-p (path) + (cond + ((parse-namestring path)) ; syntax check + ((typep path 'pathname) + (setf path (namestring path))) + (t + (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path)))) + (let ((ext (pathname-type path))) + (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (let ((plugin (make-instance 'default-data-plugin))) + (gfg:load plugin path) + plugin) + nil))) + +(push #'accepts-file-p gfg::*image-plugins*)

Added: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Wed Aug 2 17:37:56 2006 @@ -0,0 +1,140 @@ +;;;; +;;;; file-formats.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. 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. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS 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 :graphic-forms.uitoolkit.graphics.default) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :com.gigamonkeys.binary-data)) + +;;; +;;; fundamental binary types used by image definitions +;;; + +;; This utility was copied from Peter Seibel's id3v2 package, +;; renamed to signify that it is for big-endian values. +;; +(define-binary-type unsigned-integer-be (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;; This utility is based on the same unsigned-integer binary type, +;; but this one is for little-endian types. +;; +(define-binary-type unsigned-integer-le (bytes bits-per-byte) + (:reader (in) + (loop with value = 0 + for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do + (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) + finally (return value))) + (:writer (out value) + (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte + do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) + +;;; aliases for single-byte and 32-bit types with names +;;; matching the GDI docs +;;; +(define-binary-type BYTE () (unsigned-integer-le :bytes 1 :bits-per-byte 8)) +(define-binary-type DWORD () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type FXPT2DOT30 () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type LONG () (unsigned-integer-le :bytes 4 :bits-per-byte 8)) +(define-binary-type WORD () (unsigned-integer-le :bytes 2 :bits-per-byte 8)) + +;;; +;;; Win32 GDI Bitmap Formats +;;; + +(define-binary-class BITMAPFILEHEADER () + ((bfType WORD) + (bfSize DWORD) + (bfReserved1 WORD) + (bfReserved2 WORD) + (bfOffBits DWORD))) + +(define-binary-class CIEXYZ () + ((ciexyzX FXPT2DOT30) + (ciexyzY FXPT2DOT30) + (ciexyzZ FXPT2DOT30))) + +(define-binary-class CIEXYZTRIPLE () + ((ciexyzRed CIEXYZ) + (ciexyzGreen CIEXYZ) + (ciexyzBlue CIEXYZ))) + +(define-tagged-binary-class BASE-BITMAPINFOHEADER () + ((biSize DWORD) + (biWidth LONG) + (biHeight LONG) + (biPlanes WORD) + (biBitCount WORD) + (biCompression DWORD) + (biSizeImage DWORD) + (biXPelsPerMeter LONG) + (biYPelsPerMeter LONG) + (biClrUsed DWORD) + (biClrImportant DWORD)) + (:dispatch + (ecase biSize + (40 'BITMAPINFOHEADER) + (120 'BITMAPV4HEADER) + (124 'BITMAPV5HEADER)))) + +(define-binary-class BITMAPINFOHEADER (BASE-BITMAPINFOHEADER) ()) + +(define-binary-class BITMAPV4HEADER (BASE-BITMAPINFOHEADER) + ((bv4RedMask DWORD) + (bv4GreenMask DWORD) + (bv4BlueMask DWORD) + (bv4AlphaMask DWORD) + (bv4CSType DWORD) + (bv4Endpoints CIEXYZTRIPLE) + (bv4GammaRed DWORD) + (bv4GammaGreen DWORD) + (bv4GammaBlue DWORD))) + +(define-binary-class BITMAPV5HEADER (BITMAPV4HEADER) + ((bv5Intent DWORD) + (bv5ProfileData DWORD) + (bv5ProfileSize DWORD) + (bv5Reserved DWORD))) + +(define-binary-class RGBQUAD () + ((rgbBlue BYTE) + (rgbGreen BYTE) + (rgbRed BYTE) + (rgbReserved BYTE)))

Modified: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Wed Aug 2 17:37:56 2006 @@ -34,10 +34,10 @@ (in-package #:cl-user)

;;; -;;; package for base Win32 graphics plugin +;;; package for default Win32 graphics plugin ;;; -(defpackage #:graphic-forms.uitoolkit.graphics.win32 - (:nicknames #:gfgw32) +(defpackage #:graphic-forms.uitoolkit.graphics.default + (:nicknames #:gfgd) (:shadow #:load #:type) (:use #:common-lisp) (:export