[graphic-forms-cvs] r199 - in trunk: . src/external-libraries src/external-libraries/practicals-1.0.3 src/external-libraries/practicals-1.0.3/Chapter08 src/external-libraries/practicals-1.0.3/Chapter24 src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/default
junrue at common-lisp.net
junrue at common-lisp.net
Wed Aug 2 21:37:57 UTC 2006
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 at gigamonkeys.com>"
+ :version "1.0"
+ :maintainer "Peter Seibel <peter at 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 at gigamonkeys.com>"
+ :version "1.0"
+ :maintainer "Peter Seibel <peter at 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))))
+ , at 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)))
+ , at 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 at gigamonkeys.com>"
+ :version "1.0"
+ :maintainer "Peter Seibel <peter at 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 , at args)
+ (declare (ignorable , at args))
+ ,(type-reader-body spec stream))
+ (defmethod write-value ((,type (eql ',name)) ,stream ,value &key , at args)
+ (declare (ignorable , at 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 , at args)))
+ (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec))
+ `(let ((,in ,stream)) , at 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 , at args)))
+ (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec))
+ `(let ((,out ,stream) (,v ,value)) , at 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 , at args))))
+
+(defun slot->write-value (spec stream)
+ (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
+ `(write-value ',type ,stream ,name , at args)))
+
+(defun slot->binding (spec stream)
+ (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
+ `(,name (read-value ',type ,stream , at 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 at gigamonkeys.com>"
+ :version "1.0"
+ :maintainer "Peter Seibel <peter at 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
More information about the Graphic-forms-cvs
mailing list