From junrue at common-lisp.net Wed Aug 2 21:37:57 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 2 Aug 2006 17:37:57 -0400 (EDT) Subject: [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 Message-ID: <20060802213757.EB26772100@common-lisp.net> 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 " + :version "1.0" + :maintainer "Peter Seibel " + :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 " + :version "1.0" + :maintainer "Peter Seibel " + :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 " + :version "1.0" + :maintainer "Peter Seibel " + :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 " + :version "1.0" + :maintainer "Peter Seibel " + :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 From junrue at common-lisp.net Sat Aug 5 02:50:30 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 4 Aug 2006 22:50:30 -0400 (EDT) Subject: [graphic-forms-cvs] r200 - in trunk/src: . uitoolkit/graphics uitoolkit/graphics/plugins/default uitoolkit/graphics/plugins/imagemagick uitoolkit/system Message-ID: <20060805025030.E80D31D0FE@common-lisp.net> Author: junrue Date: Fri Aug 4 22:50:30 2006 New Revision: 200 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp Log: default graphics data plugin is now working for BMPs Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 4 22:50:30 2006 @@ -193,6 +193,7 @@ #:make-color #:make-font-data #:make-image-data + #:make-palette #:matrix #:maximum-char-width #:metrics Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Aug 4 22:50:30 2006 @@ -79,7 +79,10 @@ (green-shift 0) (blue-shift 0) (direct nil) - (table nil))) ; vector of COLOR structs + (table nil)) ; vector of COLOR structs + + (defmacro color-table (data) + `(gfg::palette-table ,data))) (defclass image-data-plugin (gfs:native-object) () (:documentation "Graphics library plugin implementation objects.")) @@ -151,9 +154,6 @@ (defmacro red-shift (data) `(gfg::palette-red-shift ,data)) -(defmacro color-table (data) - `(gfg::palette-table ,data)) - (defclass pattern (gfs:native-object) () (:documentation "This class represents a pattern to be used with a brush.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Fri Aug 4 22:50:30 2006 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *image-plugins* nil)) + (defvar *image-plugins* nil) + + (cffi:defctype bmp-pointer :pointer)) ;; ;; list the superset of file extensions for formats that any @@ -193,10 +195,8 @@ (error 'gfs:toolkit-error :detail "pathname or string required")))) (let ((plugin (data-plugin-of self))) - (when plugin - (gfs:dispose plugin) - (setf (slot-value self 'data-plugin) nil)) - (setf plugin (find-image-plugin path)) + (unless plugin + (setf plugin (find-image-plugin path))) (unless plugin (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) (load plugin path) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Fri Aug 4 22:50:30 2006 @@ -33,9 +33,18 @@ (in-package :graphic-forms.uitoolkit.graphics.default) -(defclass default-data-plugin (gfg:image-data-plugin) () +(defclass default-data-plugin (gfg:image-data-plugin) + ((palette + :accessor palette-of + :initform nil) + (pixels + :accessor pixels-of + :initform nil)) (:documentation "Default library plugin for the graphics package.")) +(defmacro bitmap-pixel-row-length (width bit-count) + `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) + (defun accepts-file-p (path) (cond ((parse-namestring path)) ; syntax check @@ -44,10 +53,146 @@ (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")) +; (if (or (string-equal ext "ico") (string-equal ext "bmp")) + (if (string-equal ext "bmp") (let ((plugin (make-instance 'default-data-plugin))) (gfg:load plugin path) plugin) nil))) (push #'accepts-file-p gfg::*image-plugins*) + +(defmethod gfg:data->image ((self default-data-plugin)) + (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) + (hbmp (cffi:null-pointer))) + (unwind-protect + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + self + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + (let ((plugin-pixels (pixels-of self)) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref ptr :uint8 i) (aref plugin-pixels i))))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defmethod gfg:depth ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (biBitCount info))) + +(defmethod gfs:dispose ((self default-data-plugin)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod cffi:free-translated-object (pixels-ptr (name (eql 'gfs::bitmap-pixels-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free pixels-ptr)) + +(defmethod cffi:free-translated-object (bi-ptr (name (eql 'gfs::bitmap-info-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free bi-ptr)) + +(defmethod gfg:load ((self default-data-plugin) path) + (with-open-file (in path :element-type '(unsigned-byte 8)) + (let ((header (read-value 'BITMAPFILEHEADER in)) + (info (read-value 'BASE-BITMAPINFOHEADER in))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD in))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of self) in)) + + ;; complete load + ;; + (setf (slot-value self 'gfs:handle) info)))) + +(defmethod gfg:size ((self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (gfs:make-size :width (biWidth info) :height (biHeight info)))) + +(defmethod (setf gfg:size) (size (self default-data-plugin)) + (let ((info (gfs:handle self))) + (unless info + (error 'gfs:disposed-error)) + (setf (biWidth info) (gfs:size-width size) + (biHeight info) (gfs:size-height size))) + size) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmap-pixels-pointer))) + (let* ((plugin-pixels (pixels-of lisp-obj)) + (pixels-ptr (cffi:foreign-alloc :uint8 :count (length plugin-pixels)))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-ptr :uint8 i) (aref plugin-pixels i))) + pixels-ptr)) + +(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount + gfs::bicompression gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (gfs::zero-mem bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biplanes 1 + gfs::bibitcount (gfg:depth lisp-obj) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (gfg:size lisp-obj))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (gfs:size-height im-size))) + (let ((colors (gfg:color-table (palette-of lisp-obj))) + (ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) + (dotimes (i (length colors)) + (let ((clr (aref colors i))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr) + gfs::rgbreserved 0)))))) + bi-ptr)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Fri Aug 4 22:50:30 2006 @@ -55,7 +55,6 @@ (push #'accepts-file-p gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) - "Convert the image-data object to a bitmap and return the native handle." (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth @@ -127,7 +126,7 @@ (let ((victim (gfs:handle self))) (unless (or (null victim) (cffi:null-pointer-p victim)) (destroy-image victim))) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) + (setf (slot-value self 'gfs:handle) nil)) (defmethod gfg:load ((self magick-data-plugin) path) (let ((handle (gfs:handle self))) @@ -176,4 +175,5 @@ 'reason)))) (setf (slot-value self 'gfs:handle) new-handle) (destroy-image handle)) - (destroy-exception-info ex)))) + (destroy-exception-info ex))) + size) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Aug 4 22:50:30 2006 @@ -117,7 +117,7 @@ (hdc HANDLE) (pheader LPTR) (option DWORD) - (pinit LPTR) + (pinit bitmap-pixels-pointer) (pbmp LPTR) (usage UINT)) @@ -125,7 +125,7 @@ ("CreateDIBSection" create-dib-section) HANDLE (hdc HANDLE) - (bmi LPTR) + (bmi bitmapinfo-pointer) (usage UINT) (values LPTR) ;; VOID ** (section HANDLE) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Aug 4 22:50:30 2006 @@ -114,6 +114,9 @@ (biclrimp DWORD) (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) +(defctype bitmapinfo-pointer :pointer) +(defctype bitmap-pixels-pointer :pointer) + (defcstruct bitmapinfoheader (bisize DWORD) (biwidth LONG) From junrue at common-lisp.net Mon Aug 7 16:14:20 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 7 Aug 2006 12:14:20 -0400 (EDT) Subject: [graphic-forms-cvs] r201 - in trunk: . docs/manual src/uitoolkit/graphics src/uitoolkit/graphics/plugins/default src/uitoolkit/graphics/plugins/imagemagick Message-ID: <20060807161420.140B231033@common-lisp.net> Author: junrue Date: Mon Aug 7 12:14:19 2006 New Revision: 201 Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored plugin loading to accomodate multiple-image formats Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 7 12:14:19 2006 @@ -2261,12 +2261,24 @@ Returns a color object corresponding to the current foreground color. @end deffn - at deffn GenericFunction metrics self font -Returns a @ref{font-metrics} object describing key attributes of @code{font}. + at deffn GenericFunction load self path => list +Certain graphics objects have a persistent representation, which may +be deserialized with the appropriate implementation of this function. + at var{self} will be re-initialized with data loaded from @var{path}. +Certain serialized object formats (e.g., @sc{ico}) may actually +describe multiple instances. To facilitate such formats, @code{load} +returns @var{self} plus any additional instances in a @sc{list}, +ordered the same as they are read from @var{path}. @emph{Note:} + at sc{gfg:load} shadows @sc{cl:load}. @end deffn - at deffn GenericFunction size self -Returns a size object describing the dimensions of the object. + at deffn GenericFunction metrics self font => @ref{font-metrics} +Returns a font-metrics object describing key attributes of @var{font}, +where @var{self} is a @ref{graphics-context}. + at end deffn + + at deffn GenericFunction size self => @ref{size} +Returns a size object describing the dimensions of @var{self}. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 7 12:14:19 2006 @@ -50,7 +50,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cells") Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 7 12:14:19 2006 @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.3.0" + :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 7 12:14:19 2006 @@ -90,6 +90,7 @@ (defclass image-data () ((data-plugin :reader data-plugin-of + :initarg :data-plugin :initform nil)) (:documentation "This class maintains image attributes, color, and pixel data.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Aug 7 12:14:19 2006 @@ -78,11 +78,11 @@ ;;; helper functions ;;; -(defun find-image-plugin (path) - (loop for acceptor in *image-plugins* - for plugin = (funcall acceptor path) - until plugin - finally (return plugin))) +(defun load-image-data (path) + (loop for loader in *image-plugins* + for data = (funcall loader path) + until data + finally (return data))) (defun image->data (hbmp) (declare (ignore hbmp))) #| @@ -193,14 +193,16 @@ ((typep path 'string) (namestring (merge-pathnames path))) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - - (let ((plugin (data-plugin-of self))) - (unless plugin - (setf plugin (find-image-plugin path))) - (unless plugin + (let ((plugin (data-plugin-of self)) + (plugins nil)) + (if plugin + (setf plugins (load plugin path)) + (setf plugins (load-image-data path))) + (unless plugins (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path))) - (load plugin path) - (setf (slot-value self 'data-plugin) plugin))) + (setf (slot-value self 'data-plugin) (first plugins)) + (append (list self) (loop for p in (rest plugins) + collect (make-instance 'image-data :data-plugin p))))) (defmethod size ((self image-data)) (size (data-plugin-of self))) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Mon Aug 7 12:14:19 2006 @@ -45,22 +45,66 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(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")) - (if (string-equal ext "bmp") - (let ((plugin (make-instance 'default-data-plugin))) - (gfg:load plugin path) - plugin) - nil))) +(defun load-bmp-data (stream) + (let* ((header (read-value 'BITMAPFILEHEADER stream)) + (info (read-value 'BASE-BITMAPINFOHEADER stream)) + (data (make-instance 'default-data-plugin :handle info))) + (declare (ignore header)) + (unless (= (biCompression info) gfs::+bi-rgb+) + (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + + ;; load color table + ;; + (let ((used (biClrUsed info)) + (rgbs nil)) + (ecase (biBitCount info) + (1 + (setf rgbs (make-array 2))) + (4 + (if (or (= used 0) (= used 16)) + (setf rgbs (make-array 16)) + (setf rgbs (make-array used)))) + (8 + (if (or (= used 0) (= used 256)) + (setf rgbs (make-array 256)) + (setf rgbs (make-array used)))) + (16 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (24 + (unless (/= used 0) + (setf rgbs (make-array used)))) + (32 + (unless (/= used 0) + (setf rgbs (make-array used))))) + (dotimes (i (length rgbs)) + (let ((quad (read-value 'RGBQUAD stream))) + (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) + :green (rgbGreen quad) + :blue (rgbBlue quad))))) + (setf (palette-of data) (gfg:make-palette :direct nil :table rgbs))) + + ;; load pixel bits + ;; + (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) + (setf (pixels-of data) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) + (read-sequence (pixels-of data) stream)) + + (list data))) + +(defun load-icon-data (stream) + (declare (ignore stream))) + +(defun loader (path) + (let* ((file-type (pathname-type path)) + (helper (cond + ((string-equal file-type "bmp") #'load-bmp-data) + ((string-equal file-type "ico") #'load-icon-data) + (t (return-from loader nil))))) + (with-open-file (stream path :element-type '(unsigned-byte 8)) + (funcall helper stream)))) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self default-data-plugin)) (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) @@ -99,55 +143,6 @@ (declare (ignore param)) (cffi:foreign-free bi-ptr)) -(defmethod gfg:load ((self default-data-plugin) path) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in))) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) - - ;; load color table - ;; - (let ((used (biClrUsed info)) - (rgbs nil)) - (ecase (biBitCount info) - (1 - (setf rgbs (make-array 2))) - (4 - (if (or (= used 0) (= used 16)) - (setf rgbs (make-array 16)) - (setf rgbs (make-array used)))) - (8 - (if (or (= used 0) (= used 256)) - (setf rgbs (make-array 256)) - (setf rgbs (make-array used)))) - (16 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (24 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (32 - (unless (/= used 0) - (setf rgbs (make-array used))))) - (dotimes (i (length rgbs)) - (let ((quad (read-value 'RGBQUAD in))) - (setf (aref rgbs i) (gfg:make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (palette-of self) (gfg:make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bitmap-pixel-row-length (biWidth info) (biBitCount info)))) - (setf (pixels-of self) (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence (pixels-of self) in)) - - ;; complete load - ;; - (setf (slot-value self 'gfs:handle) info)))) - (defmethod gfg:size ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info Modified: trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/file-formats.lisp Mon Aug 7 12:14:19 2006 @@ -138,3 +138,22 @@ (rgbGreen BYTE) (rgbRed BYTE) (rgbReserved BYTE))) + +;;; +;;; Win32 GDI Icon Formats +;;; + +(define-binary-class ICONDIR () + ((idReserved WORD) + (idType WORD) + (idCount WORD))) ; ICONDIRENTRY array read separately + +(define-binary-class ICONDIRENTRY () + ((ideWidth BYTE) + (ideHeight BYTE) + (ideColorCount BYTE) + (ideReserved BYTE) + (idePlanes WORD) + (ideBitCount WORD) + (ideBytesInRes DWORD) + (ideImageOffset DWORD))) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Aug 7 12:14:19 2006 @@ -140,6 +140,20 @@ (floor quant 257)) ;;; +;;; translated from list.h +;;; + +(defcfun + ("GetFirstImageInList" get-first-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +(defcfun + ("GetNextImageInList" get-next-image-in-list) + :pointer ;; Image* + (images :pointer)) ;; Image* + +;;; ;;; translated from magick.h ;;; Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Aug 7 12:14:19 2006 @@ -36,23 +36,23 @@ (defclass magick-data-plugin (gfg:image-data-plugin) () (:documentation "ImageMagick library plugin for the graphics package.")) -(defun accepts-file-p (path) +(defun loader (path) (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (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)))) (if (gethash (pathname-type path) gfg:*image-file-types*) - (let ((plugin (make-instance 'magick-data-plugin))) - (gfg:load plugin path) - plugin) + (with-image-path (path info ex) + (let ((images-ptr (read-image info ex))) + (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) + (error 'gfs:toolkit-error :detail (format nil + "exception reason: ~s" + (cffi:foreign-slot-value ex 'exception-info 'reason)))) + (loop for ptr = (get-next-image-in-list images-ptr) + until (cffi:null-pointer-p ptr) + collect (make-instance 'magic-data-plugin :handle ptr)))) nil)) -(push #'accepts-file-p gfg::*image-plugins*) +(push #'loader gfg::*image-plugins*) (defmethod gfg:data->image ((self magick-data-plugin)) (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) @@ -128,22 +128,6 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil)) -(defmethod gfg:load ((self magick-data-plugin) path) - (let ((handle (gfs:handle self))) - (when (and handle (not (cffi:null-pointer-p handle))) - (destroy-image handle) - (setf (slot-value self 'gfs:handle) nil) - (setf handle nil)) - (with-image-path (path info ex) - (setf handle (read-image info ex)) - (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) - (error 'gfs:toolkit-error :detail (format nil - "exception reason: ~s" - (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (if (cffi:null-pointer-p handle) - (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) - (setf (slot-value self 'gfs:handle) handle)))) - (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size))) From junrue at common-lisp.net Tue Aug 8 05:47:30 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 8 Aug 2006 01:47:30 -0400 (EDT) Subject: [graphic-forms-cvs] r202 - in trunk: docs/manual src/uitoolkit/system Message-ID: <20060808054730.ABC562E1B2@common-lisp.net> Author: junrue Date: Tue Aug 8 01:47:29 2006 New Revision: 202 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: further work towards supporting icon display Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Aug 8 01:47:29 2006 @@ -2020,11 +2020,76 @@ @end deffn @end deftp + at anchor{icon-bundle} + at deftp Class icon-bundle +This class encapsulates a collection of Win32 icon handles. +Icons are used to decorate @ref{window} title bars, to represent +a file or application on the desktop, to represent an application +in the @code{} task switching dialog, and in the +Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN +documentation for further discussion of standard icon sizes, color +depths and file format. @code{icon-bundle} derives from @ref{native-object}. + at deffn Initarg :file +This initarg accepts a @sc{cl:pathname} identifying a file +with @ref{image-data} to be loaded, as described for the @ref{image} +class @code{:file} initarg. Note that the @sc{.ico} format can +store multiple icons, all of which will be loaded. Since + at code{icon-bundle} needs a transparency mask for each image in +order to create Windows icons, a value may be supplied for the + at code{:transparency-pixel} initarg of this class to select the +proper transparency @ref{color}; by default, the pixel color at + at code{(0, 0)} in each image will be used. @emph{FIXME: link to +documentation of graphics plugins here}. + at end deffn + at deffn Initarg :images +This initarg accepts a @sc{cl:list} of image objects. Since + at code{icon-bundle} needs a transparency mask for each image in +order to create Windows icons, the application may either @sc{setf} + at ref{transparency-pixel} for each image ahead of time (especially +important when the pixel location is different from one image +to the next), or provide a value for the @code{:transparency-pixel} +initarg of this class; or else by default, the pixel color at + at code{(0, 0)} in each image will be used. + at end deffn + at deffn Initarg :system +This initarg causes the @code{icon-bundle} to be loaded with a +system-provided standard icon, identified by one of the following +constants: + at table @code + at item +application-icon+ +Default application icon. + at item +error-icon+ +Icon for error notifications. + at item +information-icon+ +Icon for informational notifications. + at item +question-icon+ +Icon to be used when prompting the user for more input. + at item +warning-icon+ +Icon for warning notifications. + at end table + at end deffn + at deffn Initarg :transparency-pixel +This initarg is similar in purpose to the same initarg for +the image class, except that in this case the specified @ref{point} +applies to all images (except pre-defined system icons) +encapsulated by the @code{icon-bundle} object. + at end deffn + at end deftp + @anchor{image} - at deftp Class image -This subclass of @ref{native-object} wraps a native image object. -Instances may be drawn directly via a graphics-context (see - at ref{draw-image}) or set as the content of a @ref{label} control. + at deftp Class image transparency-pixel +This subclass of @ref{native-object} wraps a Win32 bitmap handle. +Instances may be drawn using @ref{draw-image} or displayed within +certain @ref{control}s such as a @ref{label}. Images may originate +from a variety of formats. @emph{FIXME: link to documentation +of graphics plugins here}. + at table @var + at anchor{transparency-pixel} + at item transparency-pixel +This slot holds a @ref{point} that identifies a pixel within the +image whose color will be used by @ref{transparency-mask}. + at xref{with-image-transparency}. + at end table @deffn Initarg :file Supply a path to a file containing image data to be loaded. @end deffn @@ -2036,9 +2101,28 @@ @end deftp @anchor{image-data} - at deftp Class image-data -This subclass of @ref{native-object} maintains image attributes, -color, and pixel data. @xref{image}. + at deftp Class image-data data-plugin +This class represents an image in an external format. Such formats +may be loaded (via the @ref{load} method) and then converted to an + at ref{image} object by the @ref{data-object} @sc{setf} function.@*@* + at code{image-data} serves as an integration point between Graphic-Forms +and third-party graphics libraries such as ImageMagick. @emph{FIXME: +link to documentation of graphics plugins here}. + at table @var + at item data-plugin +This slot holds a subclass of @ref{image-data-plugin} encapsulating +format and functionality from a particular third-party graphics library. +Many of the features offered by @code{image-data} are delegated to +this plugin object. + at end table + at end deftp + + at anchor{image-data-plugin} + at deftp Class image-data-plugin +This is a base class for plugin objects that encapsulate third-party +library representations of images. @emph{FIXME: +link to documentation of graphics plugins here}. It derives from + at ref{native-object}. @end deftp @node graphics functions @@ -2053,6 +2137,7 @@ Returns a color object corresponding to the current background color. @end deffn + at anchor{data-object} @deffn GenericFunction data-object self &optional gc => object Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this @@ -2261,6 +2346,7 @@ Returns a color object corresponding to the current foreground color. @end deffn + at anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may be deserialized with the appropriate implementation of this function. @@ -2296,8 +2382,16 @@ @end table @end deffn - at deffn GenericFunction transparency-mask self + at anchor{transparency-mask} + at deffn GenericFunction transparency-mask self => @ref{image} Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. @end deffn + + at anchor{with-image-transparency} + at defmac with-image-transparency (image point) &body body +This macro wraps @var{body} in an @sc{unwind-protect} form with + at var{point} set as the @ref{transparency-pixel} for @var{image}. +Any existing point set in @var{image} is restored. + at end defmac Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Aug 8 01:47:29 2006 @@ -167,6 +167,15 @@ (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc (templname :string)) +(defcstruct iconinfo + (flag BOOL) + (hotspotx DWORD) + (hotspoty DWORD) + (maskbm HANDLE) + (colorbm HANDLE)) + +(defctype iconinfo-pointer :pointer) + (defcstruct initcommoncontrolsex (size DWORD) (icc DWORD)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Aug 8 01:47:29 2006 @@ -72,6 +72,11 @@ (ch UINT)) (defcfun + ("CreateIconIndirect" create-icon-indirect) + HANDLE + (iconinfo iconinfo-pointer)) + +(defcfun ("CreateMenu" create-menu) HANDLE) @@ -124,6 +129,11 @@ (lp LPARAM)) (defcfun + ("DestroyIcon" destroy-icon) + BOOL + (hicon HANDLE)) + +(defcfun ("DestroyMenu" destroy-menu) BOOL (hwnd HANDLE)) @@ -487,6 +497,12 @@ (name LPTR)) ; LPTR to make it easier to pass constants like +obm-checkboxes+ (defcfun + ("LoadIconA" load-icon) + HANDLE + (instance HANDLE) + (name LPCTSTR)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE) From junrue at common-lisp.net Thu Aug 10 04:15:09 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 10 Aug 2006 00:15:09 -0400 (EDT) Subject: [graphic-forms-cvs] r203 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060810041509.9975B46130@common-lisp.net> Author: junrue Date: Thu Aug 10 00:15:08 2006 New Revision: 203 Added: trunk/src/tests/uitoolkit/default.ico (contents, props changed) trunk/src/uitoolkit/graphics/icon-bundle.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: implemented and documented icon-bundle class and related functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Aug 10 00:15:08 2006 @@ -2028,21 +2028,24 @@ in the @code{} task switching dialog, and in the Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color -depths and file format. @code{icon-bundle} derives from @ref{native-object}. +depths and file format.@*@* + at code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{.ico} format can -store multiple icons, all of which will be loaded. Since +class @code{:file} initarg. Note that the @sc{ico} format can +store multiple icons, all of which will be loaded. Application +code should not assume that load order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the proper transparency @ref{color}; by default, the pixel color at - at code{(0, 0)} in each image will be used. @emph{FIXME: link to -documentation of graphics plugins here}. + at code{(0, 0)} in each image will be used. @emph{FIXME: link +to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Since +This initarg accepts a @sc{cl:list} of image objects. Application +code should not assume that image order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -2346,6 +2349,30 @@ Returns a color object corresponding to the current foreground color. @end deffn + at anchor{icon-image} + at defun icon-image @ref{icon-bundle} index => @ref{image} +This function uses an integer or keyword -based @var{index} to address +the images comprising an icon-bundle, either to retrieve an image +or add/replace an image via @sc{setf}. Application code should not +assume that image load order was preserved when this function is called. + at table @var + at item icon-bundle +This is an icon-bundle containing images to be updated or retrieved. + at item index +This argument can be a zero-based, with new images added by +specifying @var{index} 0. Or @var{index} can be one of the following +keywords: + at table @code + at item :large +Specifies the largest image of the icon-bundle. + at item :small +Specifies the smallest image of the icon-bundle. + at end table + at end table +To find out how many images are stored in an icon-bundle, call + at ref{size}. + at end defun + @anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may @@ -2356,6 +2383,13 @@ returns @var{self} plus any additional instances in a @sc{list}, ordered the same as they are read from @var{path}. @emph{Note:} @sc{gfg:load} shadows @sc{cl:load}. + at table @var + at item self +The graphics object that will be populated with data. + at item path +A @sc{cl:pathname} identifying a file with graphics data appropriate +for @var{self}. + at end table @end deffn @deffn GenericFunction metrics self font => @ref{font-metrics} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 00:15:08 2006 @@ -76,6 +76,8 @@ (:file "palette") (:file "image-data") (:file "image") + (:file "icon-bundle" + :depends-on ("graphics-constants" "image")) (:file "font-data") (:file "font") (:file "graphics-context") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 00:15:08 2006 @@ -109,6 +109,7 @@ #:font-data #:font-metrics #:graphics-context + #:icon-bundle #:image #:image-data #:image-data-plugin @@ -123,6 +124,11 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+application-icon+ + #:+error-icon+ + #:+information-icon+ + #:+question-icon+ + #:+warning-icon+ ;; methods, functions, macros #:accepts-file-p @@ -182,6 +188,7 @@ #:green-mask #:green-shift #:height + #:icon-image #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Aug 10 00:15:08 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; graphics-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -127,12 +127,15 @@ :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) +(defclass icon-bundle (gfs:native-object) () + (:documentation "This class encapsulates a set of Win32 icon handles.")) + (defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel :initform nil)) - (:documentation "This class wraps a native image object.")) + (:documentation "This class encapsulates a Win32 bitmap handle.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Thu Aug 10 00:15:08 2006 @@ -57,3 +57,13 @@ (defconstant +russian-charset+ 204) (defconstant +mac-charset+ 77) (defconstant +baltic-charset+ 186) + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an icon-bundle +;;; +(defconstant +application-icon+ 32512) +(defconstant +error-icon+ 32513) +(defconstant +information-icon+ 32516) +(defconstant +question-icon+ 32514) +(defconstant +warning-icon+ 32515) Added: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Thu Aug 10 00:15:08 2006 @@ -0,0 +1,129 @@ +;;;; +;;;; icon-bundle.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) + +;;; +;;; helper functions +;;; + +(defun hicon->image (hicon) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (if (zerop (gfs::get-icon-info hicon info-ptr)) + (error 'gfs::win32-error :detail "get-icon-info failed")) + (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) + (gfs::delete-object gfs::hmask) + (make-instance 'image :handle gfs::hcolor)))) + +(defun icon-extent (hicon) + (let ((im (hicon->image hicon)) + (extent 0)) + (unwind-protect + (setf extent (gfs:size-height (gfg:size im))) + (gfs:dispose im)) + extent)) + +(defun icon-handle (bundle index) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (cond + ((typep index 'integer) + (if (zerop index) + (if (listp handles) + (elt handles index) + handles))) + ((eql index :small) + (if (listp handles) + (first (stable-sort handles #'< :key #'icon-extent)) + handles)) + ((eql index :large) + (if (listp handles) + (first (last (stable-sort handles #'< :key #'icon-extent))) + handles)) + (t + (error 'gfs:toolkit-error + :detail "an integer index, or one of :small or :large, is required"))))) + +(defun icon-image (bundle index) + (hicon->image (icon-handle bundle index))) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self icon-bundle)) + (let ((handles (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil) + ;; note: if handles is a cffi:pointer, then self was + ;; instantiated as a system icon and we don't need + ;; to destroy the handle + ;; + (if (and handles (listp handles)) + (loop for hicon in handles do (gfs::destroy-icon hicon))))) + +(defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) + (let ((image-list nil) + (resource-id (case system + (#.+application-icon+ (cffi:make-pointer system)) + (#.+error-icon+ (cffi:make-pointer system)) + (#.+information-icon+ (cffi:make-pointer system)) + (#.+question-icon+ (cffi:make-pointer system)) + (#.+warning-icon+ (cffi:make-pointer system)) + (otherwise nil)))) + (cond + (resource-id + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + (file + (let ((tmp-image (make-instance 'image))) + (setf image-list (load tmp-image file)))) + (images + (setf image-list images))) + (when image-list + (let ((handles nil) + (default-pnt (gfs:make-point))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (loop for tmp-image in image-list + do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) + (setf gfs::hcolor (gfs:handle tmp-image)) + (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (unless (gfs:null-handle-p hicon) + (push hicon handles))))))) + (setf (slot-value self 'gfs:handle) handles)))) + (unless (gfs:handle self) + (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Thu Aug 10 00:15:08 2006 @@ -83,10 +83,10 @@ (gfs:dispose self)) (setf (slot-value self 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) +(defmethod initialize-instance :after ((self image) &key file size &allow-other-keys) (cond (file - (load image file)) + (load self file)) (size (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) @@ -104,19 +104,19 @@ (cffi:with-foreign-object (buffer :pointer) (gfs::with-compatible-dcs (nptr memdc) (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp))))))) + (setf (slot-value self 'gfs:handle) hbmp))))))) -(defmethod load ((im image) path) +(defmethod load ((self image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-object im) data) + (setf (data-object self) data) data)) -(defmethod size ((image image)) - (if (gfs:disposed-p image) +(defmethod size ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((size (gfs:make-size)) - (himage (gfs:handle image))) + (himage (gfs:handle self))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -124,17 +124,17 @@ (gfs:size-height size) gfs::height))) size)) -(defmethod transparency-mask ((im image)) - (if (gfs:disposed-p im) +(defmethod transparency-mask ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfs:handle im)) + (let ((pixel-pnt (transparency-pixel-of self)) + (hbmp (gfs:handle self)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) (if pixel-pnt (progn (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle self) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) (if (gfs:null-handle-p hmask) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 00:15:08 2006 @@ -171,8 +171,8 @@ (flag BOOL) (hotspotx DWORD) (hotspoty DWORD) - (maskbm HANDLE) - (colorbm HANDLE)) + (hmask HANDLE) + (hcolor HANDLE)) (defctype iconinfo-pointer :pointer) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 00:15:08 2006 @@ -347,6 +347,12 @@ HANDLE) (defcfun + ("GetIconInfo" get-icon-info) + BOOL + (hicon HANDLE) + (iconinfo LPTR)) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) From junrue at common-lisp.net Thu Aug 10 06:08:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 10 Aug 2006 02:08:06 -0400 (EDT) Subject: [graphic-forms-cvs] r204 - in trunk: . src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060810060806.23F2F2102F@common-lisp.net> Author: junrue Date: Thu Aug 10 02:08:05 2006 New Revision: 204 Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/clib.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial phase of SBCL port completed Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 02:08:05 2006 @@ -51,6 +51,7 @@ :depends-on ("packages") :components ((:module "system" + :serial t :components ((:file "system-constants") (:file "system-classes") @@ -74,8 +75,10 @@ (:file "graphics-generics") (:file "color") (:file "palette") - (:file "image-data") - (:file "image") + (:file "image-data" + :depends-on ("graphics-classes")) + (:file "image" + :depends-on ("graphics-classes")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") @@ -85,10 +88,12 @@ :components ((:file "graphics-plugin-packages") #-skip-default-plugin (:module "default" + :serial t :components ((:file "file-formats") (:file "default-data-plugin"))) #+load-imagemagick-plugin (:module "imagemagick" + :serial t :components ((:file "magick-core-types") (:file "magick-core-api") @@ -96,6 +101,7 @@ :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") + :serial t :components ((:file "widget-constants") (:file "widget-classes") Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,9 +33,9 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +level-label+ "Level:") -(defconstant +points-needed-label+ "Points Needed:") -(defconstant +score-label+ "Score:") +(defparameter *level-label* "Level:") +(defparameter *points-needed-label* "Points Needed:") +(defparameter *score-label* "Score:") (defconstant +scoreboard-text-margin+ 2) @@ -73,7 +73,7 @@ (buffer-size (gfs:make-size))) (unwind-protect (progn - (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+) + (setf (gfs:size-width buffer-size) (* (+ (length *points-needed-label*) 2 ; space between label and value 9) ; number of value characters (gfg:average-char-width metrics))) @@ -112,9 +112,9 @@ (unwind-protect (progn (clear-buffer self gc) - (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score)) - (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level)) - (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed))) + (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score)) + (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level)) + (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 02:08:05 2006 @@ -233,6 +233,10 @@ (defpackage #:graphic-forms.uitoolkit.widgets (:nicknames #:gfw) (:use #:common-lisp) +#+sbcl + (:import-from :sb-mop :ensure-generic-function) +#-sbcl + (:import-from :clos :ensure-generic-function) (:export ;; classes and structs Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Aug 10 02:08:05 2006 @@ -33,12 +33,13 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +edit-text+ "something to edit") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defparameter *btn-text-before* "Push Me") +(defparameter *btn-text-after* "Again!") +(defparameter *edit-text* "something to edit") +(defparameter *label-text* "Label") + +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -93,10 +94,10 @@ (if (null flag) (progn (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) + (format nil "~d ~a" (id be) *btn-text-before*)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (format nil "~d ~a" (id be) *btn-text-after*)))))) (defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) @@ -119,7 +120,7 @@ ((eql subtype :single-line-edit) (setf w (make-instance widget-class :parent *layout-tester-win* - :text (format nil "~d ~a" (id be) +edit-text+)))) + :text (format nil "~d ~a" (id be) *edit-text*)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -135,7 +136,7 @@ :parent *layout-tester-win* :dispatcher be :style '(:sunken))) - (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))) + (setf (gfw:text w) (format nil "~d ~a" (id be) *label-text*))) (t (setf w (make-instance widget-class :parent *layout-tester-win* Modified: trunk/src/uitoolkit/system/clib.lisp ============================================================================== --- trunk/src/uitoolkit/system/clib.lisp (original) +++ trunk/src/uitoolkit/system/clib.lisp Thu Aug 10 02:08:05 2006 @@ -36,6 +36,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi)) +(load-foreign-library "msvcrt.dll") + (defcfun ("strncpy" strncpy) :pointer Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu Aug 10 02:08:05 2006 @@ -167,16 +167,6 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text-ex) - INT - (hdc HANDLE) - (text :string) - (count INT) - (rect LPTR) - (format UINT) - (params LPTR)) - -(defcfun ("Ellipse" ellipse) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Aug 10 02:08:05 2006 @@ -36,20 +36,20 @@ ;;; ;;; control class names ;;; -(defconstant +button-classname+ "button") -(defconstant +edit-classname+ "edit") -(defconstant +static-classname+ "static") +(defparameter *button-classname* "button") +(defparameter *edit-classname* "edit") +(defparameter *static-classname* "static") ;;; ;;; registered message names ;;; -(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify") -(defconstant +sharevistringa+ "commdlg_ShareViolation") -(defconstant +fileokstringa+ "commdlg_FileNameOK") -(defconstant +colorokstringa+ "commdlg_ColorOK") -(defconstant +setrgbstringa+ "commdlg_SetRGBColor") -(defconstant +helpmsgstringa+ "commdlg_help") -(defconstant +findmsgstringa+ "commdlg_FindReplace") +(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") +(defparameter *sharevistringa* "commdlg_ShareViolation") +(defparameter *fileokstringa* "commdlg_FileNameOK") +(defparameter *colorokstringa* "commdlg_ColorOK") +(defparameter *setrgbstringa* "commdlg_SetRGBColor") +(defparameter *helpmsgstringa* "commdlg_help") +(defparameter *findmsgstringa* "commdlg_FindReplace") (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 02:08:05 2006 @@ -154,6 +154,16 @@ (hwnd HANDLE)) (defcfun + ("DrawTextExA" draw-text-ex) + INT + (hdc HANDLE) + (text :string) + (count INT) + (rect LPTR) + (format UINT) + (params LPTR)) + +(defcfun ("EnableMenuItem" enable-menu-item) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu Aug 10 02:08:05 2006 @@ -79,7 +79,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+button-classname+ + (let ((hwnd (create-window gfs::*button-classname* (or text " ") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Aug 10 02:08:05 2006 @@ -33,17 +33,18 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-dialog-title+ " ") -(defconstant +dlgwindowextra+ 48) +(defparameter *default-dialog-title* " ") -(defvar *disabled-top-levels* nil) +(defconstant +dlgwindowextra+ 48) + +(defvar *disabled-top-levels* nil) ;;; ;;; helper functions ;;; (defun register-dialog-class () - (register-window-class +dialog-classname+ + (register-window-class *dialog-classname* (cffi:get-callback 'uit_widgets_wndproc) (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ @@ -167,7 +168,7 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-dialog-title+)) + (setf text *default-dialog-title*)) ;; NOTE: do not allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. @@ -179,7 +180,7 @@ ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners. ;; - (init-window self +dialog-classname+ #'register-dialog-class owner text)) + (init-window self *dialog-classname* #'register-dialog-class owner text)) (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Thu Aug 10 02:08:05 2006 @@ -97,7 +97,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+edit-classname+ + (let ((hwnd (create-window gfs::*edit-classname* (or text "") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) - (gfw:event-arm . (gfw:event-source)) - (gfw:event-modify . (gfw:event-source)) - (gfw:event-select . (gfw:event-source)))) +(defparameter *callback-info* '((gfw:event-activate . (gfw:event-source)) + (gfw:event-arm . (gfw:event-source)) + (gfw:event-modify . (gfw:event-source)) + (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -45,12 +45,12 @@ (defun define-dispatcher-for-callbacks (callbacks) (let ((*print-gensym* nil) - (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + (class (c2mop:ensure-class (gentemp "EDCLASS" :gfgen) :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks do (let* ((method-sym (car pair)) (fn (cdr pair)) - (arg-info (cdr (assoc method-sym +callback-info+))) + (arg-info (cdr (assoc method-sym *callback-info*))) (args nil)) `(unless (or (symbolp ,fn) (functionp ,fn)) (error 'gfs:toolkit-error @@ -61,7 +61,7 @@ method-sym))) (dotimes (i (1+ (length arg-info))) (push (gentemp "ARG" :gfgen) args)) - (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args) + (c2mop:ensure-method (ensure-generic-function method-sym :lambda-list args) `(lambda ,args (funcall ,fn , at args)) :specializers (make-specializer-list class arg-info)))) class)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu Aug 10 02:08:05 2006 @@ -152,7 +152,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) - (let ((hwnd (create-window gfs::+static-classname+ + (let ((hwnd (create-window gfs::*static-classname* (or text " ") (gfs:handle parent) (logior std-style) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Aug 10 02:08:05 2006 @@ -41,7 +41,7 @@ (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) - (if hchildmenu gfs::+miim-submenu+))) + (if hchildmenu gfs::+miim-submenu+ 0))) (info-type (if label 0 gfs::+mft-separator+)) (info-state (logior (if checked gfs::+mfs-checked+ 0) (if disabled gfs::+mfs-disabled+ 0)))) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,14 +33,14 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +panel-window-classname+ "GraphicFormsPanel") +(defparameter *panel-window-classname* "GraphicFormsPanel") ;;; ;;; helper functions ;;; (defun register-panel-window-class () - (register-window-class +panel-window-classname+ + (register-window-class *panel-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -70,4 +70,4 @@ (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (init-window self +panel-window-classname+ #'register-panel-window-class parent "")) + (init-window self *panel-window-classname* #'register-panel-window-class parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Aug 10 02:08:05 2006 @@ -59,35 +59,42 @@ ;; TODO: change this when CLISP acquires MT support ;; -#+clisp (defvar *the-thread-context* nil) +;; TODO: change this once we understand SBCL MT support +;; +#+(or clisp sbcl) +(defvar *the-thread-context* nil) -#+clisp (defun thread-context () - (when (null *the-thread-context*) - (setf *the-thread-context* (make-instance 'thread-context)) - (init-utility-hwnd *the-thread-context*)) - *the-thread-context*) - -#+clisp (defun dispose-thread-context () - (let ((hwnd (utility-hwnd *the-thread-context*))) - (unless (gfs:null-handle-p hwnd) - (gfs::destroy-window hwnd))) - (setf *the-thread-context* nil)) - -#+lispworks (defun thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (when (null tc) - (setf tc (make-instance 'thread-context)) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) - (init-utility-hwnd tc)) - tc)) - -#+lispworks (defun dispose-thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (if tc - (let ((hwnd (utility-hwnd tc))) - (unless (gfs:null-handle-p hwnd) - (gfs::destroy-window hwnd))))) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) +#+(or clisp sbcl) +(defun thread-context () + (when (null *the-thread-context*) + (setf *the-thread-context* (make-instance 'thread-context)) + (init-utility-hwnd *the-thread-context*)) + *the-thread-context*) + +#+(or clisp sbcl) +(defun dispose-thread-context () + (let ((hwnd (utility-hwnd *the-thread-context*))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))) + (setf *the-thread-context* nil)) + +#+lispworks +(defun thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) + (init-utility-hwnd tc)) + tc)) + +#+lispworks +(defun dispose-thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Aug 10 02:08:05 2006 @@ -33,20 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-window-title+ "New Window") +(defparameter *default-window-title* "New Window") ;;; ;;; helper functions ;;; (defun register-toplevel-erasebkgnd-window-class () - (register-window-class +toplevel-erasebkgnd-window-classname+ + (register-window-class *toplevel-erasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ gfs::+color-appworkspace+)) (defun register-toplevel-noerasebkgnd-window-class () - (register-window-class +toplevel-noerasebkgnd-window-classname+ + (register-window-class *toplevel-noerasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -138,11 +138,11 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-window-title+)) - (let ((classname +toplevel-noerasebkgnd-window-classname+) + (setf text *default-window-title*)) + (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) (when (find :workspace (style-of win)) - (setf classname +toplevel-erasebkgnd-window-classname+) + (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func owner text))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Aug 10 02:08:05 2006 @@ -79,20 +79,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+clisp (defun startup (thread-name start-fn) - (declare (ignore thread-name)) - (funcall start-fn) - (message-loop #'default-message-filter)) - -#+lispworks (defun startup (thread-name start-fn) - (hcl:add-special-free-action 'gfs::native-object-special-action) - (when (null (mp:list-all-processes)) - (mp:initialize-multiprocessing)) - (mp:process-run-function thread-name - nil - (lambda () - (funcall start-fn) - (message-loop #'default-message-filter)))) +#+(or clisp sbcl) +(defun startup (thread-name start-fn) + (declare (ignore thread-name)) + (funcall start-fn) + (message-loop #'default-message-filter)) + +#+lispworks +(defun startup (thread-name start-fn) + (hcl:add-special-free-action 'gfs::native-object-special-action) + (if (null (mp:list-all-processes)) + (mp:initialize-multiprocessing)) + (mp:process-run-function thread-name + nil + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +dialog-classname+ "GraphicFormsDialog") - (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) +(defparameter *dialog-classname* "GraphicFormsDialog") +(defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd") +(defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd") ;;; ;;; helper functions @@ -145,7 +144,7 @@ (color nil)) (cffi:with-foreign-pointer-as-string (str-ptr 64) (gfs::get-class-name hwnd str-ptr 64) - (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*) (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color)) From junrue at common-lisp.net Thu Aug 10 21:33:31 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 10 Aug 2006 17:33:31 -0400 (EDT) Subject: [graphic-forms-cvs] r205 - in trunk: . src/external-libraries/sbcl-callback-patch src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060810213331.01ABD304D@common-lisp.net> Author: junrue Date: Thu Aug 10 17:33:31 2006 New Revision: 205 Added: trunk/src/external-libraries/sbcl-callback-patch/ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp trunk/src/external-libraries/sbcl-callback-patch/readme.txt Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/window.lisp Log: integrated stdcall callback patch for SBCL and implemented various enum procs for SBCL Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 17:33:31 2006 @@ -47,8 +47,13 @@ ((:module "src" :components ((:file "packages") +#+sbcl (:module "external-libraries" + :components + ((:module "sbcl-callback-patch" + :components + ((:file "callback-hacking"))))) (:module "uitoolkit" - :depends-on ("packages") + :depends-on ("packages" #+sbcl "external-libraries") :components ((:module "system" :serial t Added: trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp Thu Aug 10 17:33:31 2006 @@ -0,0 +1,125 @@ +;;;; +;;;; hacking.lisp +;;;; +;;;; Compiler and runtime damage for callbacks +;;;; +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-VM") + +(sb-ext:without-package-locks + (defun alien-callback-assembler-wrapper (index return-type arg-types &optional (stack-offset 0)) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (declare (ignore arg-types)) + (let* ((segment (make-segment)) + (eax eax-tn) + (edx edx-tn) + (ebp ebp-tn) + (esp esp-tn) + ([ebp-8] (make-ea :dword :base ebp :disp -8)) + ([ebp-4] (make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax) + ;; now put the result into the right register + (cond + ((and (alien-integer-type-p return-type) + (eql (alien-type-bits return-type) 64)) + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or (alien-integer-type-p return-type) + (alien-pointer-type-p return-type) + (alien-type-= #.(parse-alien-type 'system-area-pointer nil) + return-type)) + (inst mov eax [ebp-8])) + ((alien-single-float-type-p return-type) + (inst fld [ebp-8])) + ((alien-double-float-type-p return-type) + (inst fldd [ebp-8])) + ((alien-void-type-p return-type)) + (t + (error "unrecognized alien type: ~A" return-type))) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret stack-offset)) + (finalize-segment segment) + ;; Now that the segment is done, convert it to a static + ;; vector we can point foreign code to. + (let ((buffer (sb-assem::segment-buffer segment))) + (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer))))) + +(in-package "SB-ALIEN") + +(defun %alien-callback-sap (specifier result-type argument-types function wrapper &optional (call-type :cdecl)) + (let ((key (list specifier function call-type))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types + (if (eq call-type :stdcall) + (* 4 (length argument-types)) + 0)))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) + +(sb-ext:without-package-locks + (defmacro alien-callback (specifier function &optional (call-type :cdecl) &environment env) + "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to +an alien function as a pointer to the FUNCTION. If a callback for the given +SPECIFIER and FUNCTION already exists, it is returned instead of consing a new +one." + ;; Pull out as much work as is convenient to macro-expansion time, specifically + ;; everything that can be done given just the SPECIFIER and ENV. + (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) + `(%sap-alien + (%alien-callback-sap ',specifier ',result-type ',argument-types + ,function + (or (gethash ',specifier *alien-callback-wrappers*) + (setf (gethash ',specifier *alien-callback-wrappers*) + ,(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env))) ,call-type) + ',(parse-alien-type specifier env))))) + +#| +(sb-alien::alien-callback (function int int int) #'+ :stdcall) + => # +(alien-funcall-stdcall * 3 4) => 9 +"Hey everybody, callbacks work!" +|# + +;;; EOF Added: trunk/src/external-libraries/sbcl-callback-patch/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/readme.txt Thu Aug 10 17:33:31 2006 @@ -0,0 +1,8 @@ +This directory contains callback-hacking.lisp, authored by +Alastair Bridgewater. This code updates an SBCL image such +that stdcall callbacks are supported. + +The full distribution including sample code is available from: + + http://www.lisphacker.com/files/lisp-winapi.tgz + http://www.lisphacker.com/files/hello-win32.tgz Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 17:33:31 2006 @@ -45,9 +45,9 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in defpackage +(defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in defpackage +(defctype BOOLEAN :char) ; shadowed in gfs: package (defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) @@ -73,6 +73,26 @@ (defctype WORD :short) (defctype WPARAM :unsigned-int) +#+sbcl +(sb-alien:define-alien-type enumchildproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type enumthreadwndproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type monitorsenumproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long))) + (defcstruct actctx (cbsize ULONG) (flags DWORD) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 17:33:31 2006 @@ -223,6 +223,12 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int + (hwnd sb-alien:system-area-pointer) + (func enumchildproc) + (lparam sb-alien:long)) + ;;; FIXME: uncomment this when CFFI callbacks can ;;; be tagged as stdcall or cdecl (only the latter ;;; is supported as of 0.9.0) @@ -264,6 +270,13 @@ (data ffi:c-pointer)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int + (hdc sb-alien:system-area-pointer) + (rect sb-alien:system-area-pointer) + (func monitorsenumproc) + (lparam sb-alien:long)) + ;;; FIXME: uncomment this when CFFI callbacks can ;;; be tagged as stdcall or cdecl (only the latter ;;; is supported as of 0.9.0) @@ -300,6 +313,12 @@ (lparam ffi:long)) (:return-type ffi:int)) +#+sbcl +(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int + (id sb-alien:unsigned-long) + (func enumthreadwndproc) + (lparam sb-alien:unsigned-long)) + (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu Aug 10 17:33:31 2006 @@ -48,12 +48,22 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -#+clisp -(defun display_visitor (hmonitor hdc monitorrect data) +(defun display-visitor (hmonitor hdc monitorrect data) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) +#+sbcl +(defvar *monitors-enum-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long) + #'display-visitor + :stdcall)) + (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) @@ -87,9 +97,14 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+lispworks (let ((ptr (fli:make-pointer :address 0))) +#+sbcl + (let ((ptr (cffi:null-pointer))) + (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) +#+lispworks + (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil) +#+clisp + (gfs::enum-display-monitors nil nil #'display-visitor nil) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -104,26 +119,31 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) +(defun top-level-window-visitor (hwnd lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) (unless (null win) (call-top-level-visitor-func tc win))) 1) -#+clisp -(defun top_level_window_visitor (hwnd lparam) - (declare (ignore lparam)) - (let* ((tc (thread-context)) - (win (get-widget tc hwnd))) - (unless (null win) - (call-top-level-visitor-func tc win))) +#+lispworks +(fli:define-foreign-callable + ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) + ((hwnd :pointer) + (lparam :long)) + (top-level-window-visitor hwnd lparam) 1) +#+sbcl +(defvar *enum-thread-wnd-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long) + #'top-level-window-visitor + :stdcall)) + (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -132,12 +152,18 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") - 0) -#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'top_level_window_visitor - 0) +#+sbcl + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (sb-alien:alien-sap *enum-thread-wnd-proc*) + 0) +#+lispworks + (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (fli:make-pointer :symbol-name "top_level_window_visitor") + 0) +#+clisp + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + #'top-level-window-visitor + 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 17:33:31 2006 @@ -60,34 +60,31 @@ (put-kbdnav-widget tc win)) (put-widget tc win)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro child-visitor-proper (hwnd lparam) - (let ((tc (gensym)) - (tmp-list (gensym)) - (child (gensym)) - (parent (gensym)) - (ancestor-hwnd (gensym))) - `(let* ((,tc (thread-context)) - (,child (get-widget ,tc ,hwnd)) - (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) - (unless (or (null ,parent) (null ,child)) - (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) - (,tmp-list (child-visitor-results ,tc))) - (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) - (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) +(defun child-window-visitor (hwnd lparam) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child)) + (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) + (tmp-list (child-visitor-results tc))) + (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd) + (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) + 1) #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) ((hwnd :pointer) (lparam :long)) - (child-visitor-proper hwnd lparam) + (child-window-visitor hwnd lparam) 1) -#+clisp -(defun child_window_visitor (hwnd lparam) - (child-visitor-proper hwnd lparam) - 1) +#+sbcl +(defvar *enum-child-proc* + (sb-alien::alien-callback + (sb-alien:function sb-alien:int sb-alien:system-area-pointer sb-alien:long) + #'child-window-visitor + :stdcall)) (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) @@ -213,22 +210,22 @@ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) (defmethod mapchildren ((self window) func) - (let ((tc (thread-context))) + (let ((tc (thread-context)) + (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect +#+sbcl + (gfs::enum-child-windows hwnd + (sb-alien:alien-sap *enum-child-proc*) + (cffi:pointer-address hwnd)) #+lispworks - (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle self))) + (cffi:pointer-address hwnd)) #+clisp - (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle self))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle self)))) + (gfs::enum-child-windows hwnd + #'child_window_visitor + (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil) From junrue at common-lisp.net Thu Aug 10 22:06:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 10 Aug 2006 18:06:32 -0400 (EDT) Subject: [graphic-forms-cvs] r206 - trunk/src/uitoolkit/widgets Message-ID: <20060810220632.BC16413002@common-lisp.net> Author: junrue Date: Thu Aug 10 18:06:32 2006 New Revision: 206 Modified: trunk/src/uitoolkit/widgets/window.lisp Log: fixed a regression for clisp caused by renaming the child window visitor callback Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 18:06:32 2006 @@ -224,7 +224,7 @@ (cffi:pointer-address hwnd)) #+clisp (gfs::enum-child-windows hwnd - #'child_window_visitor + #'child-window-visitor (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) From junrue at common-lisp.net Fri Aug 11 02:28:29 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 10 Aug 2006 22:28:29 -0400 (EDT) Subject: [graphic-forms-cvs] r207 - in trunk/src: demos/textedit demos/unblocked uitoolkit/widgets Message-ID: <20060811022829.C25A73600B@common-lisp.net> Author: junrue Date: Thu Aug 10 22:28:29 2006 New Revision: 207 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: last of the tweaks for SBCL Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Aug 10 22:28:29 2006 @@ -223,6 +223,8 @@ (setf *textedit-startup-dir* (ext:cd)) #+lispworks (setf *textedit-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Aug 10 22:28:29 2006 @@ -166,6 +166,8 @@ (setf *unblocked-startup-dir* (ext:cd)) #+lispworks (setf *unblocked-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Aug 10 22:28:29 2006 @@ -307,7 +307,7 @@ (defmethod redraw ((self widget)) (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) - (gfs::invalidate-rect hwnd nil 1)))) + (gfs::invalidate-rect hwnd (cffi:null-pointer) 1)))) (defmethod resizable-p :before ((self widget)) (if (gfs:disposed-p self) From junrue at common-lisp.net Fri Aug 11 19:47:54 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 11 Aug 2006 15:47:54 -0400 (EDT) Subject: [graphic-forms-cvs] r209 - in trunk: . docs/manual Message-ID: <20060811194754.AF44477002@common-lisp.net> Author: junrue Date: Fri Aug 11 15:47:54 2006 New Revision: 209 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo Log: added note about SBCL support Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Fri Aug 11 15:47:54 2006 @@ -1,4 +1,12 @@ + +. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms + includes a small patch to enable the stdcall calling convention for alien + callbacks, located in src/external-libraries/sbcl-callback-patch + + +============================================================================== + Release 0.4.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Fri Aug 11 15:47:54 2006 @@ -37,7 +37,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38 and LispWorks 4.4.6. +Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 +(the latter with a small patch). Known Problems Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Fri Aug 11 15:47:54 2006 @@ -52,8 +52,11 @@ Graphic-Forms is currently developed and tested with: @itemize @bullet - at item CLISP 2.38 + at item CLISP 2.38 or later @item LispWorks 4.4.6 + at item SBCL 0.9.15 or later at footnote{a small patch to enable the + at sc{stdcall} calling convention for callbacks is temporarily +bundled with Graphic-Forms, see @code{src/external-libraries/sbcl-callback-patch/}} @end itemize @@ -61,7 +64,7 @@ @itemize @bullet @item XP SP2 - at item Vista (testing on Beta 2 is in-progress as of this release) + at item Vista at footnote{testing on Beta 2 is in-progress as of this release} @end itemize From junrue at common-lisp.net Sat Aug 12 05:44:14 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 12 Aug 2006 01:44:14 -0400 (EDT) Subject: [graphic-forms-cvs] r210 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics Message-ID: <20060812054414.03A6E30049@common-lisp.net> Author: junrue Date: Sat Aug 12 01:44:13 2006 New Revision: 210 Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/system-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: icon-bundle testing and bug fixing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Aug 12 01:44:13 2006 @@ -14,9 +14,9 @@ of the package names are prefixed with @code{graphic-forms.uitoolkit}. @menu -* graphics package:: -* system package:: -* widgets package:: +* GFS package:: +* GFG package:: +* GFW package:: @end menu @include graphics-api.texinfo Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,15 @@ @c Copyright (c) 2006, Jack D. Unrue - at node graphics package, widgets package, system package, API - at section graphics package - at cindex graphics package - -Nickname: GFG - -This package represents graphical functionality, particularly drawing -operations. Support for the ImageMagick library is defined here. This -package and GFW together constitute the bulk of the public API. + at node GFG package + at section GFG package + at cindex GFG package + +Full package name: @emph{graphic-forms.uitoolkit.graphics} + +This package contains the symbols corresponding to graphics-related +classes, drawing operations, and meta-data. This package and + at sc{gfw} together comprise the bulk of the library API. @menu * graphics types:: @@ -205,23 +205,26 @@ Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color depths and file format.@*@* +The implementation of @code{icon-bundle} includes the concept of +there being large and small versions. The actual size to be used +depends on the context in which the icon is needed. To retrieve +or set an individual image, call @ref{icon-image-ref}. To find +out how many @ref{image}s are stored, call @ref{icon-bundle-length}.@*@* @code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file -with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{ico} format can -store multiple icons, all of which will be loaded. Application -code should not assume that load order is preserved. Since +with in a supported format to be loaded, as described for the +image class @code{:file} initarg. Note that the @sc{ico} format +can store multiple images, all of which will be loaded. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the -proper transparency @ref{color}; by default, the pixel color at - at code{(0, 0)} in each image will be used. @emph{FIXME: link -to documentation of graphics plugins here}. +proper transparency @ref{color}; or else by default, the pixel +color at @code{(0, 0)} in each image will be used. @emph{FIXME: +link to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Application -code should not assume that image order is preserved. Since +This initarg accepts a @sc{cl:list} of image objects. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -527,28 +530,38 @@ Returns a color object corresponding to the current foreground color. @end deffn - at anchor{icon-image} - at defun icon-image @ref{icon-bundle} index => @ref{image} -This function uses an integer or keyword -based @var{index} to address -the images comprising an icon-bundle, either to retrieve an image -or add/replace an image via @sc{setf}. Application code should not -assume that image load order was preserved when this function is called. + at anchor{icon-bundle-length} + at defun icon-bundle-length @ref{icon-bundle} => integer +Returns a count of the number of icon handles held by @var{icon-bundle}. + at end defun + + at anchor{icon-image-ref} + at defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} +(setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* +This function uses an integer or keyword -based @var{subscript} to address +the images comprising @var{icon-bundle}, either to retrieve an image +or add/replace an image via @sc{setf}. @table @var @item icon-bundle -This is an icon-bundle containing images to be updated or retrieved. - at item index -This argument can be a zero-based, with new images added by -specifying @var{index} 0. Or @var{index} can be one of the following -keywords: +Contains images to be used for frame decorations. + at item subscript +This argument can be zero-based, in which case @var{icon-bundle} +is treated as though it were an array of images. Add a new image +by specifying @var{subscript} 0.@*@* +Alternatively, @var{subscript} +can be one of the following keywords:@*@* @table @code @item :large -Specifies the largest image of the icon-bundle. +Identifies the largest image of the @var{icon-bundle}. @item :small -Specifies the smallest image of the icon-bundle. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +Note that adding an image addressed by one of these +keywords will succeed, but the result may be counter-intuitive. @end table -To find out how many images are stored in an icon-bundle, call - at ref{size}. +To find out how many images are stored in @var{icon-bundle}, and hence +what constitutes a valid range of subscripts for this function, +call @ref{icon-bundle-length}. @end defun @anchor{load} Modified: trunk/docs/manual/system-api.texinfo ============================================================================== --- trunk/docs/manual/system-api.texinfo (original) +++ trunk/docs/manual/system-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,16 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue - at node system package, graphics package, , API - at section system package - at cindex system package + at node GFS package + at section GFS package + at cindex GFS package -Nickname: GFS +Full package name: @emph{graphic-forms.uitoolkit.system} The symbols in this package correspond to system-level functionality, -examples of which include bindings for Win32 API functions and associated -constants. The majority of the symbols herein are not exported, except for -a few fundamental types and methods +such as foreign function declarations for the Win32 @sc{api}. The +majority of the symbols herein are not exported, except +for a few fundamental types, conditions, and methods. @menu * system types:: Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue - at node widgets package, , graphics package, API - at section widgets package - at cindex widgets package - -Nickname: GFW - -This package contains symbols for all of the widgets, event methods, -and other UI objects defined by Graphic-Forms. This package and GFG -together constitute the bulk of the public API. + at node GFW package + at section GFW package + at cindex GFW package + +Full package name: @emph{graphic-forms.uitoolkit.widgets} + +This package contains symbols for user interface widget +classes, event-handling methods, and management functions. This +package and @sc{gfg} together constitute the bulk of the library +API. @menu * event functions:: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Aug 12 01:44:13 2006 @@ -65,6 +65,7 @@ ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" + :serial t :components ((:file "tiles") (:file "unblocked-model") @@ -75,11 +76,14 @@ (:module "tests" :components ((:module "uitoolkit" + :serial t :components - ((:file "mock-objects") + ((:file "test-utils") + (:file "mock-objects") (:file "color-unit-tests") (:file "graphics-context-unit-tests") (:file "image-unit-tests") + (:file "icon-bundle-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") (:file "misc-unit-tests") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 01:44:13 2006 @@ -188,7 +188,8 @@ #:green-mask #:green-shift #:height - #:icon-image + #:icon-bundle-length + #:icon-image-ref #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; icon-bundle-unit-tests.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.tests) + + + + Added: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; test-utils.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.tests) + +#| +(defun validate-image (image expected-size expected-depth) + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) + (assert-equal expected-depth (gfg:depth image))) +|# Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 01:44:13 2006 @@ -41,11 +41,28 @@ (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) (gfs::zero-mem info-ptr gfs::iconinfo) (if (zerop (gfs::get-icon-info hicon info-ptr)) - (error 'gfs::win32-error :detail "get-icon-info failed")) + (error 'gfs:win32-error :detail "get-icon-info failed")) (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) (gfs::delete-object gfs::hmask) (make-instance 'image :handle gfs::hcolor)))) +(defun image->hicon (image &optional point) + (unless (typep point 'gfs:point) + (setf point (transparency-pixel-of image)) + (unless point + (setf point (gfs:make-point)))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (with-image-transparency (image point) + (setf gfs::hcolor (gfs:handle image)) + (setf gfs::hmask (gfs:handle (transparency-mask image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (if (gfs:null-handle-p hicon) + (error 'gfs:win32-error :detail "create-icon-indirect failed")) + hicon))))) + (defun icon-extent (hicon) (let ((im (hicon->image hicon)) (extent 0)) @@ -54,30 +71,63 @@ (gfs:dispose im)) extent)) -(defun icon-handle (bundle index) +;;; Note: this function needs to return a place not +;;; just a handle, to facilitate a defsetf further +;;; on below +;;; +(defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles (error 'gfs:disposed-error)) (cond ((typep index 'integer) - (if (zerop index) - (if (listp handles) + (if (listp handles) + (if (< index (length handles)) (elt handles index) - handles))) + (error 'gfs:toolkit-error :detail "invalid image index")) + (if (zerop index) + (gfs:handle bundle) + (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) (first (stable-sort handles #'< :key #'icon-extent)) - handles)) + (gfs:handle bundle))) ((eql index :large) (if (listp handles) (first (last (stable-sort handles #'< :key #'icon-extent))) - handles)) + (gfs:handle bundle))) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) -(defun icon-image (bundle index) - (hicon->image (icon-handle bundle index))) +(defsetf icon-handle-ref (bundle index) (hicon) + `(progn + (if (gfs:null-handle-p ,hicon) + (error 'gfs:disposed-error)) + (cond + ((listp (gfs:handle ,bundle)) + (replace (gfs:handle ,bundle) (list ,hicon) :start1 ,index)) + ((and (zerop ,index) (not (null (gfs:handle ,bundle)))) + (setf (slot-value ,bundle 'gfs:handle) ,hicon)) + (t + (error 'gfs:toolkit-error :detail "illegal arguments for (setf icon-handle-ref)"))) + ,hicon)) + +(defun icon-image-ref (bundle index) + (hicon->image (icon-handle-ref bundle index))) + +(defun set-icon-image (bundle index image) + (setf (icon-handle-ref bundle index) (image->hicon image))) + +(defsetf icon-image-ref set-icon-image) + +(defun icon-bundle-length (bundle) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (if (listp handles) + (length handles) + 1))) ;;; ;;; methods @@ -104,26 +154,14 @@ (otherwise nil)))) (cond (resource-id - (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) - (file - (let ((tmp-image (make-instance 'image))) - (setf image-list (load tmp-image file)))) - (images - (setf image-list images))) + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + ((typep file 'pathname) + (setf image-list (list (make-instance 'image :file file)))) + ((listp images) + (setf image-list images))) (when image-list - (let ((handles nil) - (default-pnt (gfs:make-point))) - (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) - (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) - (gfs::zero-mem info-ptr gfs::iconinfo) - (setf gfs::flag 1) - (loop for tmp-image in image-list - do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) - (setf gfs::hcolor (gfs:handle tmp-image)) - (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) - (let ((hicon (gfs::create-icon-indirect info-ptr))) - (unless (gfs:null-handle-p hicon) - (push hicon handles))))))) - (setf (slot-value self 'gfs:handle) handles)))) + (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) + (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list + collect (image->hicon tmp-image tr-pnt)))))) (unless (gfs:handle self) (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) From junrue at common-lisp.net Sun Aug 13 03:55:38 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 12 Aug 2006 23:55:38 -0400 (EDT) Subject: [graphic-forms-cvs] r211 - in trunk: docs/manual src src/uitoolkit/graphics Message-ID: <20060813035538.797DF6C20A@common-lisp.net> Author: junrue Date: Sat Aug 12 23:55:37 2006 New Revision: 211 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: fixed icon-handle-ref to not re-order handles, removed doc language about load order preservation, implemented and documented push-icon-image Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 23:55:37 2006 @@ -539,25 +539,20 @@ @defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} (setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* This function uses an integer or keyword -based @var{subscript} to address -the images comprising @var{icon-bundle}, either to retrieve an image -or add/replace an image via @sc{setf}. +the images comprising @var{icon-bundle}. @table @var @item icon-bundle Contains images to be used for frame decorations. @item subscript This argument can be zero-based, in which case @var{icon-bundle} -is treated as though it were an array of images. Add a new image -by specifying @var{subscript} 0.@*@* -Alternatively, @var{subscript} -can be one of the following keywords:@*@* +is treated as though it were an array of images. Alternatively, + at var{subscript} can be one of the following keywords:@*@* @table @code @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}.@*@* +Identifies the smallest image of the @var{icon-bundle}. @end table -Note that adding an image addressed by one of these -keywords will succeed, but the result may be counter-intuitive. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, @@ -588,6 +583,21 @@ where @var{self} is a @ref{graphics-context}. @end deffn + at defun push-icon-image @ref{image} @ref{icon-bundle} &optional transparency-pixel => icon-bundle +Use this function to prepend a new image to an existing icon-bundle. +Note that @var{icon-bundle} takes ownership of @var{image}. + at table @var + at item image +The new image to be prepended. + at item icon-bundle +The icon-bundle to receive @var{image}. + at item transparency-pixel +A @ref{point} object identifying a pixel in @var{image} with the color to +be used for transparency. If not specified, the pixel at @code{(0, 0)} will +be used. + at end table + at end defun + @deffn GenericFunction size self => @ref{size} Returns a size object describing the dimensions of @var{self}. @end deffn Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 23:55:37 2006 @@ -265,7 +265,7 @@ This is the base class for user interface objects that generate events at footnote{Actually, events are generated by underlying native window objects, which are represented in the class hierarchy by -the event-source class}. It derives from @ref{native-object}. +the event-source class.}. It derives from @ref{native-object}. @table @var @item callback-event-name This is an (@code{:allocation :class}) slot that holds a symbol @@ -792,10 +792,10 @@ Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and -border) was highlighted to indicate that it is now the active -window. For a @ref{menu}, it means that the user has clicked on the - at ref{item} invoking @ref{widget} and it is about to be shown; this is -an opportunity to update the menu's contents. @xref{event-deactivate}. +border) became highlighted. For a @ref{menu}, it means that the user +has clicked on the @ref{item} invoking @ref{widget} and it is about +to be shown; this is an opportunity to update the menu's contents. + at xref{event-deactivate}. @table @var @event-dispatcher-arg @item widget @@ -841,8 +841,8 @@ @deffn GenericFunction event-dispose dispatcher widget Implement this method to respond to @var{widget} being disposed (explicitly -via @ref{dispose}, not collected via the garbage collector). This -event function is called while the contents of @var{widget} are still +via @ref{dispose}; this event is not associated with garbage collection). +This event function is called while the contents of @var{widget} are still valid. @table @var @event-dispatcher-arg Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 23:55:37 2006 @@ -208,6 +208,7 @@ #:multiply #:pen-style #:pen-width + #:push-icon-image #:rgb->color #:red-mask #:red-shift Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 23:55:37 2006 @@ -71,10 +71,6 @@ (gfs:dispose im)) extent)) -;;; Note: this function needs to return a place not -;;; just a handle, to facilitate a defsetf further -;;; on below -;;; (defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles @@ -86,16 +82,16 @@ (elt handles index) (error 'gfs:toolkit-error :detail "invalid image index")) (if (zerop index) - (gfs:handle bundle) + handles (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) - (first (stable-sort handles #'< :key #'icon-extent)) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'< :key #'icon-extent)) + handles)) ((eql index :large) (if (listp handles) - (first (last (stable-sort handles #'< :key #'icon-extent))) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'> :key #'icon-extent)) + handles)) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) @@ -129,6 +125,13 @@ (length handles) 1))) +(defun push-icon-image (image bundle &optional transparency-pixel) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((tmp (gfs:handle bundle))) + (push (image->hicon image transparency-pixel) tmp) + (setf (slot-value bundle 'gfs:handle) tmp))) + ;;; ;;; methods ;;; From junrue at common-lisp.net Sun Aug 13 05:52:02 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 13 Aug 2006 01:52:02 -0400 (EDT) Subject: [graphic-forms-cvs] r212 - in trunk: . src/external-libraries/lisp-unit src/tests/uitoolkit Message-ID: <20060813055202.6542D16033@common-lisp.net> Author: junrue Date: Sun Aug 13 01:52:01 2006 New Revision: 212 Added: trunk/src/external-libraries/lisp-unit/ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp trunk/src/external-libraries/lisp-unit/readme.txt Modified: trunk/README.txt trunk/build.lisp trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/tests.lisp Log: upgraded to latest lisp-unit, now bundling lisp-unit under external-libraries Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 01:52:01 2006 @@ -14,6 +14,7 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + *note: ASDF is bundled with SBCL* - Cells (latest from CVS) http://www.common-lisp.net/project/cells/ @@ -27,12 +28,20 @@ - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - ImageMagick 6.2.6.5-Q16 - http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe +The following libraries are bundled with Graphic-Forms, thus do not need +to be downloaded separately: + + - Practical Common Lisp Chapter08 and Chapter24 + http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz - lisp-unit http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +The following libraries are optional: + + - ImageMagick 6.2.6.5-Q16 + http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe + Supported Common Lisp Implementations ------------------------------------- Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 01:52:01 2006 @@ -49,7 +49,7 @@ (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 *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/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/")) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 01:52:01 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(load gfsys::*lisp-unit-file*) + (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit) @@ -78,16 +80,7 @@ ((:module "uitoolkit" :serial t :components - ((:file "test-utils") - (:file "mock-objects") - (:file "color-unit-tests") - (:file "graphics-context-unit-tests") - (:file "image-unit-tests") - (:file "icon-bundle-unit-tests") - (:file "layout-unit-tests") - (:file "widget-unit-tests") - (:file "misc-unit-tests") - (:file "hello-world") + ((:file "hello-world") (:file "event-tester") (:file "layout-tester") (:file "image-tester") Added: trunk/src/external-libraries/lisp-unit/lisp-unit.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp Sun Aug 13 01:52:01 2006 @@ -0,0 +1,429 @@ +;;;-*- Mode: Lisp; Package: LISP-UNIT -*- + +#| +Copyright (c) 2004-2005 Christopher K. Riesbeck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +|# + + +;;; A test suite package, modelled after JUnit. +;;; Author: Chris Riesbeck +;;; +;;; Update history: +;;; +;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] +;;; 04/06/06 added ~<...~> to compact error output better [CKR] +;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported +;;; by Daniel Edward Burke) [CKR] +;;; 02/08/06 added newlines to error output [CKR] +;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] +;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] +;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, +;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] +;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] +;;; 08/30/05 added license notice [CKR] +;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] +;;; 02/21/05 removed length check from SET-EQUAL [CKR] +;;; 02/17/05 added RUN-ALL-TESTS [CKR] +;;; 01/18/05 added ASSERT-EQUAL back in [CKR] +;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] +;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] +;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] +;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] +;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] +;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] +;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] +;;; 12/02/04 changed to group tests under packages [CKR] +;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] +;;; 11/30/04 improved error handling and summarization [CKR] +;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] +;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] +;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] +;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] +;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] +;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] +;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] +;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] + + +#| +How to use +---------- + +1. Read the documentation in lisp-unit.html. + +2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many +examples. If you want, start your test file with (REMOVE-TESTS) to +clear any previously defined tests. + +2. Load this file. + +2. (use-package :lisp-unit) + +3. Load your code file and your file of tests. + +4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- +or simply (RUN-TESTS) to run all defined tests. + +A summary of how many tests passed and failed will be printed, +with details on the failures. + +Note: Nothing is compiled until RUN-TESTS is expanded. Redefining +functions or even macros does not require reloading any tests. + +For more information, see lisp-unit.html. + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Packages +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl:defpackage #:lisp-unit + (:use #:common-lisp) + (:export #:define-test #:run-all-tests #:run-tests + #:assert-eq #:assert-eql #:assert-equal #:assert-equalp + #:assert-error #:assert-expands #:assert-false + #:assert-equality #:assert-prints #:assert-true + #:get-test-code #:get-tests + #:remove-all-tests #:remove-tests + #:logically-equal #:set-equal + #:use-debugger + #:with-test-listener) + ) + +(in-package #:lisp-unit) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Globals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *test-listener* nil) + +(defparameter *tests* (make-hash-table)) + +;;; Used by RUN-TESTS to collect summary statistics +(defvar *test-count* 0) +(defvar *pass-count* 0) + +;;; Set by RUN-TESTS for use by SHOW-FAILURE +(defvar *test-name* nil) + +;;; If nil, errors in tests are caught and counted. +;;; If :ask, user is given option of entering debugger or not. +;;; If true and not :ask, debugger is entered. +(defparameter *use-debugger* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DEFINE-TEST + +(defmacro define-test (name &body body) + `(progn + (store-test-code ',name ',body) + ',name)) + +;;; ASSERT macros + +(defmacro assert-eq (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eq)) + +(defmacro assert-eql (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eql)) + +(defmacro assert-equal (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equal)) + +(defmacro assert-equalp (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equalp)) + +(defmacro assert-error (condition form &rest extras) + (expand-assert :error form (expand-error-form form) + condition extras)) + +(defmacro assert-expands (&environment env expansion form &rest extras) + (expand-assert :macro form + (expand-macro-form form #+lispworks nil #-lispworks env) + expansion extras)) + +(defmacro assert-false (form &rest extras) + (expand-assert :result form form nil extras)) + +(defmacro assert-equality (test expected form &rest extras) + (expand-assert :equal form form expected extras :test test)) + +(defmacro assert-prints (output form &rest extras) + (expand-assert :output form (expand-output-form form) + output extras)) + +(defmacro assert-true (form &rest extras) + (expand-assert :result form form t extras)) + + +(defun expand-assert (type form body expected extras &key (test #'eql)) + `(internal-assert + ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) + +(defun expand-error-form (form) + `(handler-case ,form + (condition (error) error))) + +(defun expand-output-form (form) + (let ((out (gensym))) + `(let* ((,out (make-string-output-stream)) + (*standard-output* (make-broadcast-stream *standard-output* ,out))) + ,form + (get-output-stream-string ,out)))) + +(defun expand-macro-form (form env) + `(macroexpand-1 ',form ,env)) + +(defun expand-extras (extras) + `#'(lambda () + (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) + + +;;; RUN-TESTS + +(defmacro run-all-tests (package &rest tests) + `(let ((*package* (find-package ',package))) + (run-tests + ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) + tests)))) + +(defmacro run-tests (&rest names) + `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) + +(defun get-test-thunks (names &optional (package *package*)) + (mapcar #'(lambda (name) (get-test-thunk name package)) + names)) + +(defun get-test-thunk (name package) + (assert (get-test-code name package) (name package) + "No test defined for ~S in package ~S" name package) + (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) + +(defun use-debugger (&optional (flag t)) + (setq *use-debugger* flag)) + +;;; WITH-TEST-LISTENER +(defmacro with-test-listener (listener &body body) + `(let ((*test-listener* #',listener)) , at body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Public functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-test-code (name &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (gethash name table)))) + +(defun get-tests (&optional (package *package*)) + (let ((l nil) + (table (get-package-table package))) + (cond ((null table) nil) + (t + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key l)) + table) + (sort l #'string< :key #'string))))) + + +(defun remove-tests (names &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (if (null names) + (clrhash table) + (dolist (name names) + (remhash name table)))))) + +(defun remove-all-tests (&optional (package *package*)) + (if (null package) + (clrhash *tests*) + (remhash (find-package package) *tests*))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Private functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; DEFINE-TEST support + +(defun get-package-table (package &key create) + (let ((table (gethash (find-package package) *tests*))) + (or table + (and create + (setf (gethash package *tests*) + (make-hash-table)))))) + +(defun get-test-name (form) + (if (atom form) form (cadr form))) + +(defun store-test-code (name code &optional (package *package*)) + (setf (gethash name + (get-package-table package :create t)) + code)) + + +;;; ASSERTION support + +(defun internal-assert (type form code-thunk expected-thunk extras test) + (let* ((expected (multiple-value-list (funcall expected-thunk))) + (actual (multiple-value-list (funcall code-thunk))) + (passed (test-passed-p type expected actual test))) + + (incf *test-count*) + (when passed + (incf *pass-count*)) + + (record-result passed type form expected actual extras) + + passed)) + +(defun record-result (passed type form expected actual extras) + (funcall (or *test-listener* 'default-listener) + passed type *test-name* form expected actual + (and extras (funcall extras)) + *test-count* *pass-count*)) + +(defun default-listener + (passed type name form expected actual extras test-count pass-count) + (declare (ignore test-count pass-count)) + (unless passed + (show-failure type (get-failure-message type) + name form expected actual extras))) + +(defun test-passed-p (type expected actual test) + (ecase type + (:error + (or (eql (car actual) (car expected)) + (typep (car actual) (car expected)))) + (:equal + (and (<= (length expected) (length actual)) + (every test expected actual))) + (:macro + (equal (car actual) (car expected))) + (:output + (string= (string-trim '(#\newline #\return #\space) + (car actual)) + (car expected))) + (:result + (logically-equal (car actual) (car expected))) + )) + + +;;; RUN-TESTS support + +(defun run-test-thunks (test-thunks) + (unless (null test-thunks) + (let ((total-test-count 0) + (total-pass-count 0) + (total-error-count 0)) + (dolist (test-thunk test-thunks) + (multiple-value-bind (test-count pass-count error-count) + (run-test-thunk (car test-thunk) (cadr test-thunk)) + (incf total-test-count test-count) + (incf total-pass-count pass-count) + (incf total-error-count error-count))) + (unless (null (cdr test-thunks)) + (show-summary 'total total-test-count total-pass-count total-error-count)) + (values)))) + +(defun run-test-thunk (*test-name* thunk) + (if (null thunk) + (format t "~& Test ~S not found" *test-name*) + (prog ((*test-count* 0) + (*pass-count* 0) + (error-count 0)) + (handler-bind + ((error #'(lambda (e) + (let ((*print-escape* nil)) + (setq error-count 1) + (format t "~& ~S: ~W" *test-name* e)) + (if (use-debugger-p e) e (go exit))))) + (funcall thunk) + (show-summary *test-name* *test-count* *pass-count*)) + exit + (return (values *test-count* *pass-count* error-count))))) + +(defun use-debugger-p (e) + (and *use-debugger* + (or (not (eql *use-debugger* :ask)) + (y-or-n-p "~A -- debug?" e)))) + +;;; OUTPUT support + +(defun get-failure-message (type) + (case type + (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") + (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + )) + +(defun show-failure (type msg name form expected actual extras) + (format t "~&~@[~S: ~]~S failed: " name form) + (format t msg expected actual) + (format t "~{~& ~S => ~S~}~%" extras) + type) + +(defun show-summary (name test-count pass-count &optional error-count) + (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." + name pass-count (- test-count pass-count) error-count)) + +(defun collect-form-values (form values) + (mapcan #'(lambda (form-arg value) + (if (constantp form-arg) + nil + (list form-arg value))) + (cdr form) + values)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Useful equality predicates for tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; (LOGICALLY-EQUAL x y) => true or false +;;; Return true if x and y both false or both true + +(defun logically-equal (x y) + (eql (not x) (not y))) + +;;; (SET-EQUAL l1 l2 :test) => true or false +;;; Return true if every element of l1 is an element of l2 +;;; and vice versa. + +(defun set-equal (l1 l2 &key (test #'equal)) + (and (listp l1) + (listp l2) + (subsetp l1 l2 :test test) + (subsetp l2 l1 :test test))) + + +(provide "lisp-unit") Added: trunk/src/external-libraries/lisp-unit/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/readme.txt Sun Aug 13 01:52:01 2006 @@ -0,0 +1,7 @@ + +This directory contains the source file implementing the lisp-unit +unit-test library. Copyright (c) 2004-2005 Christopher K. Riesbeck + +The website for this library is: + + http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 01:52:01 2006 @@ -32,7 +32,3 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) - - - - Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 01:52:01 2006 @@ -33,8 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -#| (defun validate-image (image expected-size expected-depth) (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) (assert-equal expected-depth (gfg:depth image))) -|# Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 01:52:01 2006 @@ -33,9 +33,16 @@ (in-package #:graphic-forms-system) -(load (compile-file *lisp-unit-file*)) - (defun load-tests () #+lispworks (hcl:change-directory *gf-dir*) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load (concatenate 'string *gf-tests-dir* "test-utils")) + (load (concatenate 'string *gf-tests-dir* "mock-objects")) + (load (concatenate 'string *gf-tests-dir* "color-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "misc-unit-tests"))) From junrue at common-lisp.net Sun Aug 13 21:13:55 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 13 Aug 2006 17:13:55 -0400 (EDT) Subject: [graphic-forms-cvs] r213 - in trunk: . src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics Message-ID: <20060813211355.BF60C55338@common-lisp.net> Author: junrue Date: Sun Aug 13 17:13:54 2006 New Revision: 213 Modified: trunk/build.lisp trunk/config.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/tests.lisp Log: implemented icon-bundle unit-tests and fixed a few more bugs found as a result Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 17:13:54 2006 @@ -52,8 +52,9 @@ (setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/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/")) +(setf *textedit-dir* (concatenate 'string *gf-dir* "src/demos/textedit/")) +(setf *unblocked-dir* (concatenate 'string *gf-dir* "src/demos/unblocked/")) +(setf *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 Sun Aug 13 17:13:54 2006 @@ -39,15 +39,18 @@ (in-package #:graphic-forms-system) -(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 *binary-data-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/binary-data/") +(defvar *macro-utilities-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/macro-utilities/") +(defvar *textedit-dir* "graphic-forms/src/demos/textedit/") +(defvar *unblocked-dir* "graphic-forms/src/demos/unblocked/") +(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 13 17:13:54 2006 @@ -35,7 +35,6 @@ (defvar *textedit-control* nil) (defvar *textedit-win* nil) -(defvar *textedit-startup-dir* nil) (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) @@ -152,7 +151,8 @@ (defun about-textedit (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -219,12 +219,6 @@ (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) (defun textedit-startup () -#+clisp - (setf *textedit-startup-dir* (ext:cd)) -#+lispworks - (setf *textedit-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Aug 13 17:13:54 2006 @@ -82,15 +82,13 @@ (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) (declare (ignorable buffer-size)) - (let ((table (tile-image-table-of self)) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) - (gfg:load image (merge-pathnames (concatenate 'string - "src/demos/unblocked/" - filename) - (unblocked-startup-dir))) + (gfg:load image (merge-pathnames filename)) (setf (gethash kind table) image) (incf kind))))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 13 17:13:54 2006 @@ -39,13 +39,9 @@ (defconstant +revealed-duration+ 2000) ; millis (defvar *scoreboard-panel* nil) -(defvar *unblocked-startup-dir* nil) (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) -(defun unblocked-startup-dir () - *unblocked-startup-dir*) - (defun get-tiles-panel () *tiles-panel*) @@ -106,7 +102,8 @@ (defun about-unblocked (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -162,12 +159,6 @@ (gfw:show dlg t))) (defun unblocked-startup () -#+clisp - (setf *unblocked-startup-dir* (ext:cd)) -#+lispworks - (setf *unblocked-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:13:54 2006 @@ -32,3 +32,70 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) + +(define-test bmp-file-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle :file (merge-pathnames "happy.bmp"))) + (size (gfs:make-size :width 32 :height 32))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16))) + (unwind-protect + (progn + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) bw-size 8) + (validate-image (gfg:icon-image-ref bundle 2) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test push-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle)) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (tc-image (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16)) + (bw-point (gfs:make-point :x 0 :y 15))) + (unwind-protect + (progn + (gfg:push-icon-image bw-image bundle bw-point) + (gfg:push-icon-image tc-image bundle) + (gfg:push-icon-image happy-image bundle) + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle 2) bw-size 8) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test system-icon-bundle-test + (let ((size (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxicon+) + :height (gfs::get-system-metrics gfs::+sm-cyicon+))) + (bundle (make-instance 'gfg:icon-bundle :system gfg:+warning-icon+))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 17:13:54 2006 @@ -34,5 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (defun validate-image (image expected-size expected-depth) - (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) - (assert-equal expected-depth (gfg:depth image))) + (declare (ignore expected-depth)) + (assert-false (null image)) + (assert-false (gfs:disposed-p image)) + ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:13:54 2006 @@ -67,7 +67,8 @@ (let ((im (hicon->image hicon)) (extent 0)) (unwind-protect - (setf extent (gfs:size-height (gfg:size im))) + (let ((size (gfg:size im))) + (setf extent (* (gfs:size-height size) (gfs:size-width size)))) (gfs:dispose im)) extent)) @@ -130,7 +131,8 @@ (error 'gfs:disposed-error)) (let ((tmp (gfs:handle bundle))) (push (image->hicon image transparency-pixel) tmp) - (setf (slot-value bundle 'gfs:handle) tmp))) + (setf (slot-value bundle 'gfs:handle) tmp)) + bundle) ;;; ;;; methods @@ -165,6 +167,4 @@ (when image-list (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list - collect (image->hicon tmp-image tr-pnt)))))) - (unless (gfs:handle self) - (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) + collect (image->hicon tmp-image tr-pnt))))))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 17:13:54 2006 @@ -34,8 +34,7 @@ (in-package #:graphic-forms-system) (defun load-tests () -#+lispworks - (hcl:change-directory *gf-dir*) + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (load (concatenate 'string *gf-tests-dir* "test-utils")) (load (concatenate 'string *gf-tests-dir* "mock-objects")) From junrue at common-lisp.net Sun Aug 13 21:28:31 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 13 Aug 2006 17:28:31 -0400 (EDT) Subject: [graphic-forms-cvs] r214 - in trunk/src: tests/uitoolkit uitoolkit/graphics Message-ID: <20060813212831.3F5FE74163@common-lisp.net> Author: junrue Date: Sun Aug 13 17:28:31 2006 New Revision: 214 Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: implemented setf icon-image-ref unit-test, fixed bug Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:28:31 2006 @@ -99,3 +99,22 @@ (validate-image (gfg:icon-image-ref bundle :large) size 8)) (gfs:dispose bundle)) (assert-true (gfs:disposed-p bundle)))) + +(define-test setf-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16))) + (unwind-protect + (progn + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (setf (gfg:icon-image-ref bundle 0) bw-image) + (setf (gfg:icon-image-ref bundle 1) happy-image) + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) bw-size 16000000) + (validate-image (gfg:icon-image-ref bundle 1) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:28:31 2006 @@ -114,6 +114,9 @@ (hicon->image (icon-handle-ref bundle index))) (defun set-icon-image (bundle index image) + (let ((hicon (icon-handle-ref bundle index))) + (if (and (not (gfs:null-handle-p hicon)) (listp (gfs:handle bundle))) + (gfs::destroy-icon hicon))) (setf (icon-handle-ref bundle index) (image->hicon image))) (defsetf icon-image-ref set-icon-image) From junrue at common-lisp.net Mon Aug 14 02:04:19 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 13 Aug 2006 22:04:19 -0400 (EDT) Subject: [graphic-forms-cvs] r215 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060814020419.B7CA3108A@common-lisp.net> Author: junrue Date: Sun Aug 13 22:04:18 2006 New Revision: 215 Modified: trunk/README.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/default.ico trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed problems in multiple-image icon bundles and in the ImageMagick plugin Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 22:04:18 2006 @@ -157,21 +157,26 @@ (asdf:operate 'asdf:load-op :graphic-forms-tests) - ;; execute one or more of the following: + ;; execute demos and test programs ;; + (gft:unblocked) - (in-package :gft) - (run-tests) ;; runs the unit tests (many more to be added) + (gft:textedit) + + (gft:drawing-tester) - (gft::run-drawing-tester) + (gft:event-tester) - (gft::run-event-tester) + (gft:image-tester) - (gft::run-image-tester) + (gft:layout-tester) - (gft::run-windlg) + (gft:windlg) - (gft::run-layout-tester) + ;; execute the unit-tests + ;; + (in-package :gft) + (run-tests) Support and Feedback Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sun Aug 13 22:04:18 2006 @@ -1333,6 +1333,16 @@ scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn + at deffn GenericFunction image self => @ref{image} + +(setf (@strong{image} @var{self}) @var{image})@* + +Returns the image currently associated with @var{self}. The @sc{setf} function +changes the image. If @var{self} is a @ref{window}, then this function returns +an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either +an image or an icon-bundle. + at end deffn + @deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 22:04:18 2006 @@ -37,14 +37,14 @@ (:nicknames #:gft) (:use :common-lisp :lisp-unit) (:export - #:run-drawing-tester - #:run-event-tester - #:run-hello-world - #:run-image-tester - #:run-layout-tester - #:run-windlg + #:drawing-tester + #:event-tester + #:hello-world + #:image-tester + #:layout-tester #:textedit - #:unblocked)) + #:unblocked + #:windlg)) (print "Graphic-Forms UI Toolkit Tests") (print "Copyright (c) 2006 by Jack D. Unrue") Modified: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 22:04:18 2006 @@ -342,7 +342,7 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) (gfw:redraw *drawing-win*)) -(defun run-drawing-tester-internal () +(defun drawing-tester-internal () (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) @@ -362,7 +362,9 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") +#+load-imagemagick-plugin + (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t))) -(defun run-drawing-tester () - (gfw:startup "Drawing Tester" #'run-drawing-tester-internal)) +(defun drawing-tester () + (gfw:startup "Drawing Tester" #'drawing-tester-internal)) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 22:04:18 2006 @@ -233,7 +233,7 @@ (gfw:delay-of *timer*))))) (gfw:redraw *event-tester-window*)) -(defun run-event-tester-internal () +(defun event-tester-internal () (setf *event-tester-text* "Hello!") (setf *event-counter* 0) (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) @@ -255,5 +255,5 @@ (setf (gfw:menu-bar *event-tester-window*) menubar) (gfw:show *event-tester-window* t))) -(defun run-event-tester () - (gfw:startup "Event Tester" #'run-event-tester-internal)) +(defun event-tester () + (gfw:startup "Event Tester" #'event-tester-internal)) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Aug 13 22:04:18 2006 @@ -56,7 +56,7 @@ (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) -(defun run-hello-world-internal () +(defun hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) :style '(:frame))) @@ -65,5 +65,5 @@ (setf (gfw:menu-bar *hello-win*) menubar) (gfw:show *hello-win* t))) -(defun run-hello-world () - (gfw:startup "Hello World" #'run-hello-world-internal)) +(defun hello-world () + (gfw:startup "Hello World" #'hello-world-internal)) Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 22:04:18 2006 @@ -93,7 +93,7 @@ (setf *image-win* nil) (gfw:shutdown 0)) -(defun run-image-tester-internal () +(defun image-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((menubar nil)) (setf *happy-image* (make-instance 'gfg:image)) @@ -111,5 +111,5 @@ (setf (gfw:menu-bar *image-win*) menubar) (gfw:show *image-win* t))) -(defun run-image-tester () - (gfw:startup "Image Tester" #'run-image-tester-internal)) +(defun image-tester () + (gfw:startup "Image Tester" #'image-tester-internal)) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 22:04:18 2006 @@ -387,7 +387,7 @@ (declare (ignorable disp item)) (exit-layout-tester)) -(defun run-layout-tester-internal () +(defun layout-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (setf *widget-counter* 0) (let ((menubar nil) @@ -444,5 +444,5 @@ (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) -(defun run-layout-tester () - (gfw:startup "Layout Tester" #'run-layout-tester-internal)) +(defun layout-tester () + (gfw:startup "Layout Tester" #'layout-tester-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 22:04:18 2006 @@ -228,7 +228,7 @@ (declare (ignore disp item)) (open-dlg "Modeless" '(:modeless))) -(defun run-windlg-internal () +(defun windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:workspace))) @@ -248,5 +248,5 @@ (setf (gfw:menu-bar *main-win*) menubar) (gfw:show *main-win* t))) -(defun run-windlg () - (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) +(defun windlg () + (gfw:startup "Window/Dialog Tester" #'windlg-internal)) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 22:04:18 2006 @@ -164,7 +164,9 @@ (resource-id (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) ((typep file 'pathname) - (setf image-list (list (make-instance 'image :file file)))) + (let ((data (load-image-data file))) + (setf image-list (loop for entry in data + collect (make-instance 'gfg:image :handle (data->image entry)))))) ((listp images) (setf image-list images))) (when image-list Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Sun Aug 13 22:04:18 2006 @@ -149,6 +149,11 @@ (images :pointer)) ;; Image* (defcfun + ("GetImageListLength" get-image-list-length) + :unsigned-long + (images :pointer)) ;; Image* + +(defcfun ("GetNextImageInList" get-next-image-in-list) :pointer ;; Image* (images :pointer)) ;; Image* Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 22:04:18 2006 @@ -41,15 +41,15 @@ (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) (if (gethash (pathname-type path) gfg:*image-file-types*) - (with-image-path (path info ex) + (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" (cffi:foreign-slot-value ex 'exception-info 'reason)))) - (loop for ptr = (get-next-image-in-list images-ptr) - until (cffi:null-pointer-p ptr) - collect (make-instance 'magic-data-plugin :handle ptr)))) + (loop for ptr = images-ptr then (get-next-image-in-list ptr) + while (and ptr (not (gfs:null-handle-p ptr))) + collect (make-instance 'magick-data-plugin :handle ptr)))) nil)) (push #'loader gfg::*image-plugins*) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Aug 13 22:04:18 2006 @@ -480,6 +480,10 @@ (defconstant +icc-standard-classes+ #x00004000) (defconstant +icc-link-class+ #x00008000) +(defconstant +icon-small+ 0) +(defconstant +icon-big+ 1) +(defconstant +icon-small2+ 2) + (defconstant +idok+ 1) (defconstant +idcancel+ 2) (defconstant +idabort+ 3) @@ -1004,6 +1008,12 @@ (defconstant +wm-chartoitem+ #x002F) (defconstant +wm-setfont+ #x0030) (defconstant +wm-getfont+ #x0031) +(defconstant +wm-contextmenu+ #x007B) +(defconstant +wm-stylechanging+ #x007C) +(defconstant +wm-stylechanged+ #x007D) +(defconstant +wm-displaychange+ #x007E) +(defconstant +wm-geticon+ #x007F) +(defconstant +wm-seticon+ #x0080) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun Aug 13 22:04:18 2006 @@ -210,6 +210,15 @@ (defmethod enabled-p ((w widget)) (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod image :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod (setf image) :before (image (self widget)) + (declare (ignore image)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) (setf (slot-value w 'style) (if (listp style) style (list style)))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Aug 13 22:04:18 2006 @@ -165,43 +165,65 @@ (delete-kbdnav-widget (thread-context) self) (call-next-method)) -(defmethod enable-layout :before ((win window) flag) +(defmethod enable-layout :before ((self window) flag) (declare (ignore flag)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enable-layout ((win window) flag) - (setf (slot-value win 'layout-p) flag) - (if (and flag (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) +(defmethod enable-layout ((self window) flag) + (setf (slot-value self 'layout-p) flag) + (if (and flag (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (win window) size type) +(defmethod event-resize ((d event-dispatcher) (self window) size type) (declare (ignore size type)) - (unless (null (layout-of win)) - (let ((sz (client-size win))) - (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod focus-p :before ((win window)) - (if (gfs:disposed-p win) +(defmethod focus-p :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod focus-p ((win window)) +(defmethod focus-p ((self window)) (let ((focus-hwnd (gfs::get-focus))) - (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle win))))) + (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle self))))) -(defmethod give-focus :before ((win window)) - (if (gfs:disposed-p win) +(defmethod give-focus :before ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod give-focus ((win window)) - (gfs::set-focus (gfs:handle win))) +(defmethod give-focus ((self window)) + (gfs::set-focus (gfs:handle self))) -(defmethod location ((win window)) - (if (gfs:disposed-p win) +(defmethod image ((self window)) + (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) + (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) + (handles nil)) + (unless (zerop small) + (push (cffi:make-pointer small) handles)) + (unless (zerop large) + (push (cffi:make-pointer large) handles)) + (make-instance 'gfg:icon-bundle :handle handles))) + +(defmethod (setf image) ((image gfg:image) (self window)) + (setf (image self) (make-instance 'gfg:icon-bundle :images (list image)))) + +(defmethod (setf image) ((bundle gfg:icon-bundle) (self window)) + (let ((hwnd (gfs:handle self)) + (small (gfg::icon-handle-ref bundle :small)) + (large (gfg::icon-handle-ref bundle :large))) + (unless (gfs:null-handle-p small) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-small+ (cffi:pointer-address small))) + (unless (gfs:null-handle-p large) + (gfs::send-message hwnd gfs::+wm-seticon+ gfs::+icon-big+ (cffi:pointer-address large))))) + +(defmethod location ((self window)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((pnt (gfs:make-point))) - (outer-location win pnt) + (outer-location self pnt) pnt)) (defmethod layout ((self window)) From junrue at common-lisp.net Mon Aug 14 03:07:35 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 13 Aug 2006 23:07:35 -0400 (EDT) Subject: [graphic-forms-cvs] r216 - in trunk/src: tests/uitoolkit uitoolkit/graphics/plugins/default Message-ID: <20060814030735.F1E0422004@common-lisp.net> Author: junrue Date: Sun Aug 13 23:07:35 2006 New Revision: 216 Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Log: implemented icon file loading in default graphics plugin Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Aug 13 23:07:35 2006 @@ -362,7 +362,6 @@ (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (setf (gfw:text *drawing-win*) "Drawing Tester") -#+load-imagemagick-plugin (setf (gfw:image *drawing-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *drawing-win* t))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sun Aug 13 23:07:35 2006 @@ -253,6 +253,7 @@ (:item "&Help" :dispatcher echo-md :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar) + (setf (gfw:image *event-tester-window*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *event-tester-window* t))) (defun event-tester () Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Aug 13 23:07:35 2006 @@ -109,6 +109,7 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) + (setf (gfw:image *image-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *image-win* t))) (defun image-tester () Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Aug 13 23:07:35 2006 @@ -441,6 +441,7 @@ (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) (setf (gfw:text *layout-tester-win*) "Layout Tester") + (setf (gfw:image *layout-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:pack *layout-tester-win*) (gfw:show *layout-tester-win* t))) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun Aug 13 23:07:35 2006 @@ -246,6 +246,7 @@ (:item "&Mini Frame" :callback #'create-miniframe-win) (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) + (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) (defun windlg () Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:07:35 2006 @@ -45,13 +45,15 @@ (defmacro bitmap-pixel-row-length (width bit-count) `(ash (logand (+ (* ,width ,bit-count) 31) (lognot 31)) -3)) -(defun load-bmp-data (stream) - (let* ((header (read-value 'BITMAPFILEHEADER stream)) - (info (read-value 'BASE-BITMAPINFOHEADER stream)) +(defun load-bmp-data (stream &optional no-header-p half-height-p) + (unless no-header-p + (read-value 'BITMAPFILEHEADER stream)) + (let* ((info (read-value 'BASE-BITMAPINFOHEADER stream)) (data (make-instance 'default-data-plugin :handle info))) - (declare (ignore header)) (unless (= (biCompression info) gfs::+bi-rgb+) (error 'gfs:toolkit-error :detail "FIXME: non-RGB not yet implemented")) + (if half-height-p + (setf (biHeight info) (/ (biHeight info) 2))) ;; load color table ;; @@ -93,7 +95,13 @@ (list data))) (defun load-icon-data (stream) - (declare (ignore stream))) + (let ((offsets (loop for i upto (1- (idCount (read-value 'ICONDIR stream))) + for entry = (read-value 'ICONDIRENTRY stream) + collect (ideImageOffset entry)))) + (loop for offset in offsets + append (progn + (file-position stream offset) + (load-bmp-data stream t t))))) (defun loader (path) (let* ((file-type (pathname-type path)) From junrue at common-lisp.net Mon Aug 14 03:15:27 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 13 Aug 2006 23:15:27 -0400 (EDT) Subject: [graphic-forms-cvs] r217 - in trunk/src/uitoolkit/graphics/plugins: default imagemagick Message-ID: <20060814031527.52F832200B@common-lisp.net> Author: junrue Date: Sun Aug 13 23:15:27 2006 New Revision: 217 Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: fixed graphics plugin lookup by extension to be case-insensitive Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (pathname-type path)) + (let* ((file-type (string-downcase (pathname-type path))) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Sun Aug 13 23:15:27 2006 @@ -40,7 +40,7 @@ (unless *magick-initialized* (initialize-magick (cffi:null-pointer)) (setf *magick-initialized* t)) - (if (gethash (pathname-type path) gfg:*image-file-types*) + (if (gethash (string-downcase (pathname-type path)) gfg:*image-file-types*) (with-image-path ((if (typep path 'pathname) (namestring path) path) info ex) (let ((images-ptr (read-image info ex))) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) From junrue at common-lisp.net Thu Aug 17 21:55:52 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 17 Aug 2006 17:55:52 -0400 (EDT) Subject: [graphic-forms-cvs] r218 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics/plugins/default src/uitoolkit/widgets Message-ID: <20060817215552.13E4224004@common-lisp.net> Author: junrue Date: Thu Aug 17 17:55:50 2006 New Revision: 218 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: implemented and documented gfw:layout-attribute function Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Thu Aug 17 17:55:50 2006 @@ -551,8 +551,12 @@ @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table + at strong{Note:} there are actually four icon sizes that Windows +defines for various contexts. A future release will add keywords to +better distinguish amongst all four, and to help ensure the correct +sizes are chosen when an icon-bundle is passed to @sc{(setf gfw:image)}. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 17:55:50 2006 @@ -735,12 +735,28 @@ @end deftp @anchor{layout-manager} - at deftp Class layout-manager style left-margin top-margin right-margin bottom-margin -Subclasses implement layout strategies on behalf of window -objects. Every layout manager allows optional margins (specified in -pixels) within the perimeter of the container being managed.@*@* The -values accepted by the @code{:style} initarg vary depending on the -actual @code{layout-manager} subclass being used. + at deftp Class layout-manager bottom-margin data left-margin right-margin top-margin style +Subclasses implement layout strategies to manage space within containers. + at table @var + at item bottom-margin +This slot holds a margin value in pixels for the bottom side of +the container. + at item data +This slot holds a @sc{alist} of pairs, each one associating a + at sc{plist} of layout-specific attributes with an item from a +container. + at item left-margin +This slot holds a margin value in pixels for the left side of +the container. + at item right-margin +This slot holds a margin value in pixels for the right side of +the container. + at item style +The values appropriate for this slot are subclass-specific. + at item top-margin +This slot holds a margin value in pixels for the top side of +the container. + at end table @deffn Initarg :horizontal-margins This initarg accepts a horizontal margin value that is applied to both the left and right sides of the container. @@ -1665,40 +1681,104 @@ @node layout functions @subsection layout functions -These functions comprise the protocol for @ref{layout-manager}s. As -such, they are not normally called by application code, but instead -are the concern of layout-manager implementers. - -The @code{width-hint} and @code{height-hint} parameters are a -mechanism to express the @emph{what-if} scenario where the total width -or height of the container is fixed; the proper response is to -calculate the container's desired dimension on the opposite -axis. While this behavior is primarily the concern of child windows -and/or controls, layout manager implementations should look for -non-negative values for either @code{width-hint} or - at code{height-hint}, indicating that the container's size is -constrained. +The functions @ref{compute-layout}, @ref{compute-size}, and + at ref{perform} comprise the internal protocol for + at ref{layout-manager}s. As such, they are not normally called by +application code, being instead the concern of layout-manager +implementations. The @var{width-hint} and @var{height-hint} parameters +passed to the following functions are a mechanism to express the + at emph{what-if} scenario where the total width or height of the +container is fixed; the proper response is to calculate the +container's desired dimension on the opposite axis. While this +behavior is primarily the concern of child windows and/or controls, +layout manager implementations should look for non-negative values for +either @var{width-hint} or @var{height-hint}, indicating that the +container's size is constrained. @anchor{compute-layout} - at deffn GenericFunction compute-layout layout container width-hint height-hint -Returns a list of conses @code{(child . rectangle)} describing the -new bounds of each child window or control. A @ref{layout-manager} subclass + at deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint +Returns a list of pairs @code{(item rectangle)} describing the +new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. Certain +Graphic-Forms functions call this method to accomplish layout within a container. + at table @var + at item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. + at item container +The @var{layout-manager} arranges the elements of @var{container}. + at item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. + at item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. + at end table @end deffn - at deffn GenericFunction compute-size layout container width-hint height-hint + at anchor{compute-size} + at deffn GenericFunction compute-size @ref{layout-manager} container width-hint height-hint Computes and returns the new @ref{size} of the @code{container}'s -client area. A @ref{layout-manager} subclass implements this method +client area. A layout-manager subclass implements this method based on its particular layout strategy, taking into account -attributes set by the user. The @ref{pack} function ultimately calls -this method. +attributes set by the user via @ref{layout-attribute}. + at table @var + at item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. + at item container +The @var{layout-manager} arranges the elements of @var{container}. + at item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. + at item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. + at end table @end deffn - at deffn GenericFunction perform layout container width-hint height-hint + at anchor{layout-attribute} + at defun layout-attribute @ref{layout-manager} thing symbol => value +(setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* +This function returns @var{value} if the attribute named by @var{symbol} +is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding + at sc{setf} function allows the attribute to be set. Each layout-manager +subclass supports 0 or more attributes that apply to each @var{thing}. +This function does not restrict application code +from querying or setting attributes that are not supported by the +layout manager. + at table @var + at item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. + at item thing +The object being managed by @var{layout-manager}. + at item symbol +A @sc{symbol} identifying an item-specific attribute supported +by @var{layout-manager}. + at item value +The data of an attribute which configures the behavior of @var{layout-manager}. + at end table + at end defun + + at anchor{perform} + at deffn GenericFunction perform @var{layout-manager} container width-hint height-hint Calls @ref{compute-layout} for @code{container} and then moves and resizes @code{container}'s children. Layout subclasses may override -this method -- most derivations should call @sc{CALL-NEXT-METHOD} to -allow the base implementation to execute. +this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} +to allow the base implementation to execute. + at table @var + at item layout-manager +The layout object dictating how children of @var{container} +are to be arranged. + at item container +The @var{layout-manager} arranges the elements of @var{container}. + at item width-hint +A hypothetical width value, or negative if @var{container}'s width is +not constrained. + at item height-hint +A hypothetical height value, or negative if @var{container}'s height is +not constrained. + at end table @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 17 17:55:50 2006 @@ -440,6 +440,7 @@ #:key-toggled-p #:label #:layout + #:layout-attribute #:layout-of #:layout-p #:left-margin-of Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Thu Aug 17 17:55:50 2006 @@ -54,6 +54,25 @@ expected-rects actual-rects))) +(define-test layout-attributes-test + (let ((widget1 (make-instance 'mock-widget :handle 1234)) + (widget2 (make-instance 'mock-widget :handle 5678))) + (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) + (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (layout (make-instance 'gfw:layout-manager))) + (setf (slot-value layout 'gfw::data) (list data1 data2)) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (setf (gfw:layout-attribute layout widget1 'b) 66 + (gfw:layout-attribute layout widget2 'd) 100) + (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) + (assert-equal 66 (gfw:layout-attribute layout widget1 'b)) + (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) + (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) + (define-test flow-layout-test1 ;; orient: horizontal ;; normalize: disabled Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Thu Aug 17 17:55:50 2006 @@ -57,8 +57,8 @@ :initarg :min-size :initform (gfs:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key) - (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) +(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys) + (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF)))) (defmethod gfw:location ((widget mock-widget)) (gfs:make-point)) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Thu Aug 17 17:55:50 2006 @@ -104,7 +104,7 @@ (load-bmp-data stream t t))))) (defun loader (path) - (let* ((file-type (string-downcase (pathname-type path))) + (let* ((file-type (pathname-type path)) (helper (cond ((string-equal file-type "bmp") #'load-bmp-data) ((string-equal file-type "ico") #'load-icon-data) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Thu Aug 17 17:55:50 2006 @@ -53,8 +53,11 @@ (bottom-margin :accessor bottom-margin-of :initarg :bottom-margin - :initform 0)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + :initform 0) + (data + :accessor data-of + :initform nil)) + (:documentation "Subclasses implement layout strategies to manage space within windows.")) (defclass flow-layout (layout-manager) ((spacing Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Thu Aug 17 17:55:50 2006 @@ -33,11 +33,16 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric compute-size (layout win width-hint height-hint) +(defgeneric compute-size (self win width-hint height-hint) (:documentation "Computes and returns the size of the window's client area based on the layout's strategy.")) -(defgeneric compute-layout (layout win width-hint height-hint) +(defgeneric compute-layout (self win width-hint height-hint) (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) -(defgeneric perform (layout window widget-hint height-hint) +(defgeneric obtain-default (self) + (:documentation "Returns an instance representing default values to be used when none is supplied by the application.") + (:method (self) + (declare (ignorable self)))) + +(defgeneric perform (self window widget-hint height-hint) (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 17:55:50 2006 @@ -40,6 +40,30 @@ gfs::+swp-nocopybits+))) ;;; +;;; helper functions +;;; + +(defun layout-attribute (layout widget name) + "Return the value associated with name for widget; or NIL if no value is set." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (getf (first (rest attrs)) name))) + +(defun set-layout-attribute (layout widget name value) + "Sets a value associated with name for widget in the specified layout." + (if (gfs:disposed-p widget) + (error 'gfs:disposed-error)) + (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) + (unless attrs + (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) + (setf (getf (first (rest attrs)) name) value))) + +(defsetf layout-attribute set-layout-attribute) + +;;; ;;; methods ;;; @@ -48,16 +72,16 @@ &allow-other-keys) (setf (style-of layout) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) + (setf (left-margin-of layout) margins + (right-margin-of layout) margins + (top-margin-of layout) margins + (bottom-margin-of layout) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins) - (setf (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of layout) horizontal-margins + (right-margin-of layout) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins) - (setf (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of layout) vertical-margins + (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) "Calls compute-layout for a container and then handles the actual moving and resizing of its children." From junrue at common-lisp.net Thu Aug 17 22:53:33 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 17 Aug 2006 18:53:33 -0400 (EDT) Subject: [graphic-forms-cvs] r219 - in trunk: docs/manual src/uitoolkit/widgets Message-ID: <20060817225333.0221A5F004@common-lisp.net> Author: junrue Date: Thu Aug 17 18:53:32 2006 New Revision: 219 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp Log: refactored gfw:perform implementations Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Thu Aug 17 18:53:32 2006 @@ -694,14 +694,16 @@ @node layout types @subsection layout types - at strong{NOTE:} A future release will provide additional layout -manager classes. - @anchor{flow-layout} @deftp Class flow-layout spacing -This @ref{layout-manager} subclass arranges dialog or window children -in a row or column, with optional spacing (specified in pixels) -between children. +This @ref{layout-manager} subclass arranges container children +in a row or column. There are no child-specific layout attributes +defined for this class. + at table @var + at item spacing +A pixel value specifying how far apart each child should be from +the next. + at end table @deffn Initarg :style This initarg accepts a list containing one of the following style keywords: @@ -725,13 +727,15 @@ @anchor{heap-layout} @deftp Class heap-layout top-child This @ref{layout-manager} subclass resizes all children to the same -size and stacks them on top of each other. - at deffn Initarg :top-child +size and stacks them on top of each other. There are no child-specific +layout attributes defined for this class. + at table @var + at item top-child Use this initarg to specify the child widget that should be visible. The corresponding accessor @code{top-child-of} can be set subsequently, followed by calling @ref{layout} on the container, in order to make a different child visible. - at end deffn + at end table @end deftp @anchor{layout-manager} @@ -1741,11 +1745,12 @@ @anchor{layout-attribute} @defun layout-attribute @ref{layout-manager} thing symbol => value (setf (@strong{layout-attribute} @var{layout-manager} @var{thing} @var{symbol}) @var{value})@*@* -This function returns @var{value} if the attribute named by @var{symbol} -is set in @var{layout-manager}; @sc{nil} otherwise. The corresponding - at sc{setf} function allows the attribute to be set. Each layout-manager -subclass supports 0 or more attributes that apply to each @var{thing}. -This function does not restrict application code +Each layout-manager subclass supports 0 or more attributes that apply +to each @var{thing}. This function returns @var{value} if the attribute +named by @var{symbol} is set for @var{thing} in @var{layout-manager}; +it returns @sc{nil} otherwise. The corresponding @sc{setf} function +allows the attribute to be set (note: call @ref{layout} on @var{container} +after doing so). This function does not restrict application code from querying or setting attributes that are not supported by the layout manager. @table @var @@ -1763,22 +1768,22 @@ @end defun @anchor{perform} - at deffn GenericFunction perform @var{layout-manager} container width-hint height-hint -Calls @ref{compute-layout} for @code{container} and then moves and -resizes @code{container}'s children. Layout subclasses may override + at deffn GenericFunction perform @ref{layout-manager} @ref{layout-managed} width-hint height-hint +Calls @ref{compute-layout} for @var{layout-managed} and then moves and +resizes @var{layout-managed}'s children. Subclasses may override this method -- however, most derivations should call @sc{CALL-NEXT-METHOD} to allow the base implementation to execute. @table @var @item layout-manager -The layout object dictating how children of @var{container} +The layout object dictating how children of @var{layout-managed} are to be arranged. @item container -The @var{layout-manager} arranges the elements of @var{container}. +The @var{layout-manager} arranges the elements of @var{layout-managed}. @item width-hint -A hypothetical width value, or negative if @var{container}'s width is +A hypothetical width value, or negative if @var{layout-managed}'s width is not constrained. @item height-hint -A hypothetical height value, or negative if @var{container}'s height is +A hypothetical height value, or negative if @var{layout-managed}'s height is not constrained. @end table @end deffn Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Aug 17 18:53:32 2006 @@ -69,38 +69,11 @@ (cons kid bounds))))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((kids nil) - (hdwp (cffi:null-pointer)) - (top (top-child-of self))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (unless top - (setf top (car (first kids)))) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect)) - (kid-win (car k)) - (hwnd-after (cffi:null-pointer)) - (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) - (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) - (setf flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle kid-win) - hwnd-after - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - flags))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-children kid-specs (lambda (item) + (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Thu Aug 17 18:53:32 2006 @@ -63,6 +63,32 @@ (defsetf layout-attribute set-layout-attribute) +(defun arrange-children (kid-specs flags-func) + (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) + (loop for k in kid-specs + for rect = (cdr k) + for size = (gfs:size rect) + for pnt = (gfs:location rect) + do (progn + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k)))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp)))) + ;;; ;;; methods ;;; @@ -84,31 +110,8 @@ (bottom-margin-of layout) vertical-margins))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - "Calls compute-layout for a container and then handles the actual moving and resizing of its children." - (let ((kids nil) - (hdwp (cffi:null-pointer))) - (when (layout-p container) - (setf kids (compute-layout self container width-hint height-hint)) - (setf hdwp (gfs::begin-defer-window-pos (length kids))) - (loop for k in kids - do (let* ((rect (cdr k)) - (sz (gfs:size rect)) - (pnt (gfs:location rect))) - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+) - (setf hdwp (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width sz) - (gfs:size-height sz) - +window-pos-flags+))))) - (unless (gfs:null-handle-p hdwp) - (gfs::end-defer-window-pos hdwp))))) + (when (layout-p container) + (arrange-children (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+)))) From junrue at common-lisp.net Fri Aug 18 17:18:50 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 18 Aug 2006 13:18:50 -0400 (EDT) Subject: [graphic-forms-cvs] r220 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060818171850.63D5F1C014@common-lisp.net> Author: junrue Date: Fri Aug 18 13:18:48 2006 New Revision: 220 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented layout item registration, no longer directly using mapchildren to layout children Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Fri Aug 18 13:18:48 2006 @@ -539,8 +539,10 @@ Instances of this class employ a @ref{layout-manager} to maintain the positions and sizes of their children. @deffn Accessor layout-of -Accepts or returns the @ref{layout-manager} associated with this -container. +Accepts or returns the layout-manager associated with this +container. Note that children currently registered with the previous +layout-manager are copied to the new one, but existing layout +attributes that were set for each child are not copied. @end deffn @deffn Initarg :layout Accepts a @ref{layout-manager} object whose responsibility is to manage @@ -1701,11 +1703,10 @@ @anchor{compute-layout} @deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint -Returns a list of pairs @code{(item rectangle)} describing the +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user via @ref{layout-attribute}. Certain -Graphic-Forms functions call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. @table @var @item layout-manager The layout object dictating how children of @var{container} Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 13:18:48 2006 @@ -57,8 +57,8 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) - (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) - (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (let ((data1 `(,widget1 (a 1 b 2))) + (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Aug 18 13:18:48 2006 @@ -1014,6 +1014,14 @@ (defconstant +wm-displaychange+ #x007E) (defconstant +wm-geticon+ #x007F) (defconstant +wm-seticon+ #x0080) +(defconstant +wm-nccreate+ #x0081) +(defconstant +wm-ncdestroy+ #x0082) +(defconstant +wm-nccalcsize+ #x0083) +(defconstant +wm-nchittest+ #x0084) +(defconstant +wm-ncpaint+ #x0085) +(defconstant +wm-ncactivate+ #x0086) +(defconstant +wm-getdlgcode+ #x0087) +(defconstant +wm-syncpaint+ #x0088) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Aug 18 13:18:48 2006 @@ -43,7 +43,13 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent ctrl))) + (when (and parent (layout-of parent)) + (append-layout-item (layout-of parent) ctrl))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri Aug 18 13:18:48 2006 @@ -169,7 +169,7 @@ (error 'gfs:disposed-error))) (if (null text) (setf text *default-dialog-title*)) - ;; NOTE: do not allow apps to specify the desktop window as the + ;; Don't allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 13:18:48 2006 @@ -33,10 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ - gfs::+pm-noyield+ - gfs::+pm-qs-input+ - gfs::+pm-qs-postmessage+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +wm-gf-init-msg+ #xABCD) + (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ + gfs::+pm-noyield+ + gfs::+pm-qs-input+ + gfs::+pm-qs-postmessage+))) ;;; ;;; window procedures @@ -139,6 +141,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +;;; FIXME: replace event-time slot with call to GetMessageTime +;;; (defun obtain-event-time () (event-time (thread-context))) @@ -216,13 +220,30 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot - (if (typep w 'dialog) - (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) + (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep widget 'dialog) + (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget + (return-from process-message tmp)) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget + 0) + +(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) + (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless widget + (return-from process-message 0))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (event-dispose (dispatcher widget) widget))) + ;; If widget is registered with a layout manager, that reference + ;; is not cleared until the next time the layout manager is invoked. + ;; This alleviates the need for slow messy code here. + ;; (delete-widget (thread-context) hwnd) 0) @@ -242,10 +263,10 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) + (widget (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) - (when w - (event-key-down (dispatcher w) w (virtual-key tc) ch))) + (when widget + (event-key-down (dispatcher widget) widget (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 13:18:48 2006 @@ -170,18 +170,16 @@ ;;; methods ;;; -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-size layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-size self (visible-p container) kids width-hint height-hint))) -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-layout layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-layout self (visible-p container) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key) - (unless (intersection (style-of layout) '(:horizontal :vertical)) - (setf (style-of layout) (list :horizontal)))) +(defmethod initialize-instance :after ((self flow-layout) &key) + (unless (intersection (style-of self) '(:horizontal :vertical)) + (setf (style-of self) (list :horizontal)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Aug 18 13:18:48 2006 @@ -37,21 +37,23 @@ ;;; methods ;;; -(defmethod compute-size ((self heap-layout) win width-hint height-hint) +(defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((size (gfs:make-size))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (let ((kid-size (preferred-size kid width-hint height-hint))) - (setf (gfs:size-width size) (max (gfs:size-width size) - (gfs:size-width kid-size)) - (gfs:size-height size) (max (gfs:size-height size) - (gfs:size-height kid-size)))))) + (mapc (lambda (item) + (let ((kid-size (preferred-size (first item) width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size))))) + (data-of self)) (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) size)) -(defmethod compute-layout ((self heap-layout) win width-hint height-hint) - (let* ((size (client-size win)) +(defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) @@ -64,16 +66,19 @@ vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) (bounds (gfs:make-rectangle :size new-size :location new-pnt))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (cons kid bounds))))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((top (top-child-of self)) - (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) - (arrange-children kid-specs (lambda (item) - (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) - (logior +window-pos-flags+ gfs::+swp-showwindow+) - (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) + (if (layout-p container) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-hwnds kid-specs (lambda (item) + (if (eql top item) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+))))))) + +(defmethod (setf top-child-of) :after (child (self heap-layout)) + (unless (typep child 'widget) + (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass"))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 13:18:48 2006 @@ -43,27 +43,34 @@ ;;; helper functions ;;; -(defun layout-attribute (layout widget name) - "Return the value associated with name for widget; or NIL if no value is set." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (getf (first (rest attrs)) name))) - -(defun set-layout-attribute (layout widget name value) - "Sets a value associated with name for widget in the specified layout." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (setf (getf (first (rest attrs)) name) value))) +(defun layout-attribute (layout thing name) + "Return the value associated with name for thing; or NIL if no value is set." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (getf (first (rest items)) name))) + +(defun set-layout-attribute (layout thing name value) + "Sets a value associated with name for thing in the specified layout." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (setf (getf (first (rest items)) name) value))) (defsetf layout-attribute set-layout-attribute) -(defun arrange-children (kid-specs flags-func) +(defun append-layout-item (layout thing) + "Adds thing to layout unless it is already registered." + (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) + +(defun delete-layout-item (layout thing) + "Removes thing from layout." + (delete thing (data-of layout) :key #'first)) + +(defun cleanup-disposed-items (layout) + (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + +(defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) @@ -93,25 +100,37 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((layout layout-manager) +(defmethod initialize-instance :after ((self layout-manager) &key style margins horizontal-margins vertical-margins &allow-other-keys) - (setf (style-of layout) (if (listp style) style (list style))) + (setf (style-of self) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins - (right-margin-of layout) margins - (top-margin-of layout) margins - (bottom-margin-of layout) margins)) + (setf (left-margin-of self) margins + (right-margin-of self) margins + (top-margin-of self) margins + (bottom-margin-of self) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins - (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of self) horizontal-margins + (right-margin-of self) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins - (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of self) vertical-margins + (bottom-margin-of self) vertical-margins))) + +(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) + (let ((orig-layout (layout-of container))) + (if orig-layout + (setf (data-of self) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) + (data-of orig-layout) nil) + (if (typep container 'window) + (setf (data-of self) (mapchildren container (lambda (parent child) + (declare (ignore parent)) + (list child nil)))))))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - (when (layout-p container) - (arrange-children (compute-layout self container width-hint height-hint) - (lambda (item) - (declare (ignore item)) - +window-pos-flags+)))) + (if (layout-p container) + (arrange-hwnds (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Aug 18 13:18:48 2006 @@ -40,7 +40,7 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) + (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Aug 18 13:18:48 2006 @@ -50,11 +50,7 @@ (:documentation "Instances of this class employ a layout manager to organize their children.")) (defclass group (layout-managed) - ((children - :accessor children-of - :initarg :children - :initform nil) - (location + ((location :accessor location-of :initarg :location :initform nil) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Aug 18 13:18:48 2006 @@ -219,37 +219,37 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) - (setf (slot-value w 'style) (if (listp style) style (list style)))) +(defmethod initialize-instance :after ((self widget) &key style &allow-other-keys) + (setf (slot-value self 'style) (if (listp style) style (list style)))) -(defmethod location :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod location :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod location ((w widget)) +(defmethod location ((self widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::clientleft gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs::screen-to-client (gfs:handle self) pnt-ptr) (gfs:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) :before ((pnt gfs:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (self widget)) (declare (ignore pnt)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf location) ((pnt gfs:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfs:handle w) +(defmethod (setf location) ((pnt gfs:point) (self widget)) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) @@ -272,12 +272,12 @@ nil (get-widget (thread-context) hwnd)))) -(defmethod pack :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod pack :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod pack ((w widget)) - (setf (size w) (preferred-size w -1 -1))) +(defmethod pack ((self widget)) + (setf (size self) (preferred-size self -1 -1))) (defmethod parent ((self widget)) ;; Unlike the owner method, this method should Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Aug 18 13:18:48 2006 @@ -58,7 +58,13 @@ (error 'gfs:win32-error :detail "create-window failed")) (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) - (put-widget tc win)))) + (put-widget tc win)) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent win))) + (if (and parent (layout-of parent)) + (append-layout-item (layout-of parent) win))))) (defun child-window-visitor (hwnd lparam) (let* ((tc (thread-context)) From junrue at common-lisp.net Fri Aug 18 22:31:01 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 18 Aug 2006 18:31:01 -0400 (EDT) Subject: [graphic-forms-cvs] r221 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060818223101.4B5FE751B0@common-lisp.net> Author: junrue Date: Fri Aug 18 18:30:58 2006 New Revision: 221 Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: refactored flow-layout implementation, updated associated unit-tests Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Aug 18 18:30:58 2006 @@ -255,6 +255,7 @@ #:flow-layout #:heap-layout #:item + #:layout-managed #:layout-manager #:menu #:menu-item Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -0,0 +1,266 @@ +;;;; +;;;; flow-layout-unit-tests.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.tests) + +(defvar *large-size* (gfs:make-size :width 25 :height 5)) +(defvar *small-size* (gfs:make-size :width 20 :height 10)) + +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *large-size*) + (make-instance 'mock-widget :min-size *small-size*))) + +(defvar *flow-container* (make-instance 'mock-container)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) + (assert-equal 60 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test3 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width, unrestricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 -1)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test4 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width, restricted height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* -1 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test5 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test6 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test7 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) + (assert-equal 68 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test8 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) + (assert-equal 20 (gfs:size-width size)) + (assert-equal 38 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test9 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 45 18)) + (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test10 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: enabled + ;; spacing: 4 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: restricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) + (data (gfw::compute-layout layout *flow-container* 30 25)) + (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) + (validate-rects data expected-rects))) + +(define-test flow-layout-test11 + ;; orient: horizontal + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) + (assert-equal 63 (gfs:size-width size)) + (assert-equal 13 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test12 + ;; orient: vertical + ;; normalize: disabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 + ;; container: unrestricted width and height + ;; kids: uniform + ;; + (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3)) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) + (assert-equal 23 (gfs:size-width size)) + (assert-equal 33 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test13 + ;; orient: horizontal + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test flow-layout-test14 + ;; orient: vertical + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize))) + (size (gfw::compute-size layout *flow-container* -1 -1)) + (data (gfw::compute-layout layout *flow-container* -1 -1)) + (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 18:30:58 2006 @@ -33,27 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *large-size* (gfs:make-size :width 25 :height 5)) -(defvar *small-size* (gfs:make-size :width 20 :height 10)) -(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *small-size*))) -(defvar *flow-layout-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) - (make-instance 'mock-widget :min-size *large-size*) - (make-instance 'mock-widget :min-size *small-size*))) - -(defun validate-layout-rects (entries expected-rects) - (let ((actual-rects (loop for entry in entries collect (cdr entry)))) - (mapc #'(lambda (expected actual) - (let ((pnt-a (gfs:location actual)) - (sz-a (gfs:size actual))) - (assert-equal (first expected) (gfs:point-x pnt-a)) - (assert-equal (second expected) (gfs:point-y pnt-a)) - (assert-equal (third expected) (gfs:size-width sz-a)) - (assert-equal (fourth expected) (gfs:size-height sz-a)))) - expected-rects - actual-rects))) - (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) @@ -72,229 +51,3 @@ (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) (assert-equal 100 (gfw:layout-attribute layout widget2 'd))))) - -(define-test flow-layout-test1 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10)))) - (assert-equal 60 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test2 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test3 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width, unrestricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test4 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width, restricted height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test5 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test6 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test7 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10)))) - (assert-equal 68 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test8 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical))) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10)))) - (assert-equal 20 (gfs:size-width size)) - (assert-equal 38 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test9 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18)) - (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test10 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: enabled - ;; spacing: 4 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: restricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap))) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25)) - (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test11 - ;; orient: horizontal - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:horizontal) - :left-margin 3 - :top-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10)))) - (assert-equal 63 (gfs:size-width size)) - (assert-equal 13 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test12 - ;; orient: vertical - ;; normalize: disabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 - ;; container: unrestricted width and height - ;; kids: uniform - ;; - (let* ((layout (make-instance 'gfw:flow-layout - :style '(:vertical) - :right-margin 3 - :bottom-margin 3)) - (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1)) - (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10)))) - (assert-equal 23 (gfs:size-width size)) - (assert-equal 33 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test13 - ;; orient: horizontal - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) - (assert-equal 75 (gfs:size-width size)) - (assert-equal 10 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) - -(define-test flow-layout-test14 - ;; orient: vertical - ;; normalize: enabled - ;; wrap: disabled - ;; spacing: 0 - ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 - ;; container: unrestricted width and height - ;; kids: mixed - ;; - (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize))) - (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) - (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) - (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) - (assert-equal 25 (gfs:size-width size)) - (assert-equal 30 (gfs:size-height size)) - (validate-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Aug 18 18:30:58 2006 @@ -33,10 +33,33 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +max-widget-size+ 5000) +(defconstant +max-widget-size+ 5000) +(defconstant +default-container-width+ 300) +(defconstant +default-container-height+ 200) ;;; -;;; stand-ins for widgets that would be children of windows, to be organized +;;; stand-in for a window, used as parent of mock-widget +;;; + +(defclass mock-container (gfw:layout-managed) + ((location + :accessor location-of + :initarg :location + :initform (gfs:make-point)) + (size + :accessor size-of + :initarg :size + :initform (gfs:make-size :width +default-container-width+ :height +default-container-height+)) + (visibility + :accessor visibility-of + :initarg :visibility + :initform t))) + +(defmethod gfw:visible-p ((self mock-container)) + (visibility-of self)) + +;;; +;;; stand-in for widgets that would be children of windows, to be organized ;;; via layout managers ;;; Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Aug 18 18:30:58 2006 @@ -33,9 +33,32 @@ (in-package :graphic-forms.uitoolkit.tests) +(defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:flow-layout + :style style + :spacing (or spacing 0) + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0)))) + (loop for kid in kids do (gfw::append-layout-item layout kid)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) (assert-false (gfs:disposed-p image)) ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) + +(defun validate-rects (entries expected-rects) + (let ((actual-rects (loop for entry in entries collect (cdr entry)))) + (mapc #'(lambda (expected actual) + (let ((pnt-a (gfs:location actual)) + (sz-a (gfs:size actual))) + (assert-equal (first expected) (gfs:point-x pnt-a)) + (assert-equal (second expected) (gfs:point-y pnt-a)) + (assert-equal (third expected) (gfs:size-width sz-a)) + (assert-equal (fourth expected) (gfs:size-height sz-a)))) + expected-rects + actual-rects))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 18:30:58 2006 @@ -34,7 +34,6 @@ (in-package :graphic-forms.uitoolkit.widgets) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +wm-gf-init-msg+ #xABCD) (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ gfs::+pm-noyield+ gfs::+pm-qs-input+ @@ -222,18 +221,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot (if (typep widget 'dialog) - (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget - (return-from process-message tmp)) - (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget - 0) - -(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) - (declare (ignore wparam lparam)) - (let ((widget (get-widget (thread-context) hwnd))) - (unless widget - (return-from process-message 0))) - 0) + (gfs::def-dlg-proc hwnd msg wparam lparam) + 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 18:30:58 2006 @@ -53,7 +53,7 @@ (start-margin-fn nil) (current nil)) -(defun init-flow-data (layout visible kids width-hint height-hint) +(defun init-flow-data (layout visible items width-hint height-hint) (let ((state (if (find :vertical (style-of layout)) (make-flow-data :hint height-hint :next-coord (top-margin-of layout) @@ -71,7 +71,8 @@ :extent-fn #'gfs:size-height :limit-margin-fn #'right-margin-of :start-margin-fn #'left-margin-of)))) - (loop for kid in kids + (loop for item in items + for kid = (first item) when (or (visible-p kid) (not visible)) do (let* ((size (preferred-size kid -1 -1)) (dist (funcall (flow-data-distance-fn state) size)) @@ -86,37 +87,6 @@ (setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state))) state)) -(defun flow-container-size (layout visible kids width-hint height-hint) - (let ((kid-count (length kids)) - (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) - (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout))) - (vertical (find :vertical (style-of layout))) - (horizontal (find :horizontal (style-of layout)))) - (let ((spacing-total (* (spacing-of layout) (1- kid-count))) - (state (init-flow-data layout - visible - kids - (if vertical width-hint -1) - (if vertical -1 height-hint)))) - (if (find :normalize (style-of layout)) - (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) - (cond - (horizontal - (gfs:make-size :width (+ (flow-data-distance-total state) - horz-margin-total - spacing-total) - :height (+ (flow-data-max-extent state) - vert-margin-total))) - (vertical - (gfs:make-size :width (+ (flow-data-max-extent state) - horz-margin-total) - :height (+ (flow-data-distance-total state) - vert-margin-total - spacing-total))) - (t - (error 'gfs:toolkit-error - :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) - (defun wrap-needed-p (state layout kid-size) (and (>= (flow-data-hint state) 0) (> (+ (flow-data-next-coord state) @@ -143,12 +113,49 @@ (flow-data-spacing state))) (cons kid (gfs:make-rectangle :size kid-size :location pnt)))) -(defun flow-container-layout (layout visible kids width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kid-count (length (data-of self))) + (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) + (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) + (vertical (find :vertical (style-of self))) + (horizontal (find :horizontal (style-of self)))) + (let ((spacing-total (* (spacing-of self) (1- kid-count))) + (state (init-flow-data self + (visible-p container) + (data-of self) + (if vertical width-hint -1) + (if vertical -1 height-hint)))) + (if (find :normalize (style-of self)) + (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count))) + (cond + (horizontal + (gfs:make-size :width (+ (flow-data-distance-total state) + horz-margin-total + spacing-total) + :height (+ (flow-data-max-extent state) + vert-margin-total))) + (vertical + (gfs:make-size :width (+ (flow-data-max-extent state) + horz-margin-total) + :height (+ (flow-data-distance-total state) + vert-margin-total + spacing-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of self)))))))) + +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((flows nil) - (normal (find :normalize (style-of layout))) - (vertical (find :vertical (style-of layout))) - (state (init-flow-data layout visible kids width-hint height-hint))) - (loop with wrap = (find :wrap (style-of layout)) + (normal (find :normalize (style-of self))) + (vertical (find :vertical (style-of self))) + (state (init-flow-data self (visible-p container) (data-of self) width-hint height-hint))) + (loop with wrap = (find :wrap (style-of self)) for (kid kid-size) in (flow-data-kid-sizes state) do (cond ((and normal vertical) @@ -159,26 +166,13 @@ (gfs:size-height kid-size) (flow-data-max-extent state)))) (if (and wrap (flow-data-current state) - (wrap-needed-p state layout kid-size)) - (setf flows (append flows (wrap-flow state layout)))) - (push (new-flow-element state layout kid kid-size) (flow-data-current state))) + (wrap-needed-p state self kid-size)) + (setf flows (append flows (wrap-flow state self)))) + (push (new-flow-element state self kid kid-size) (flow-data-current state))) (if (flow-data-current state) - (setf flows (append flows (wrap-flow state layout)))) + (setf flows (append flows (wrap-flow state self)))) flows)) -;;; -;;; methods -;;; - -(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-size self (visible-p container) kids width-hint height-hint))) - -(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) - (cleanup-disposed-items self) - (let ((kids (loop for item in (data-of self) collect (first item)))) - (flow-container-layout self (visible-p container) kids width-hint height-hint))) (defmethod initialize-instance :after ((self flow-layout) &key) (unless (intersection (style-of self) '(:horizontal :vertical)) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 18:30:58 2006 @@ -60,7 +60,7 @@ (defsetf layout-attribute set-layout-attribute) (defun append-layout-item (layout thing) - "Adds thing to layout unless it is already registered." + "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) (defun delete-layout-item (layout thing) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Fri Aug 18 18:30:58 2006 @@ -43,5 +43,6 @@ (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests")) (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) (load (concatenate 'string *gf-tests-dir* "misc-unit-tests"))) From junrue at common-lisp.net Sat Aug 19 22:56:22 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 19 Aug 2006 18:56:22 -0400 (EDT) Subject: [graphic-forms-cvs] r222 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060819225622.BF1016912C@common-lisp.net> Author: junrue Date: Sat Aug 19 18:56:20 2006 New Revision: 222 Added: trunk/src/uitoolkit/widgets/color-dialog.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/comdlg32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp trunk/src/uitoolkit/widgets/font-dialog.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented and documented system color dialog Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 18:56:20 2006 @@ -1,8 +1,8 @@ -. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms - includes a small patch to enable the stdcall calling convention for alien - callbacks, located in src/external-libraries/sbcl-callback-patch +. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch +to enable the stdcall calling convention for alien callbacks, located +in src/external-libraries/sbcl-callback-patch ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 18:56:20 2006 @@ -28,7 +28,7 @@ @node widget types @subsection widget types - at strong{NOTE:} A future release will provide additional widget + at strong{Note:} A future release will provide additional widget classes. @anchor{button} @@ -90,6 +90,46 @@ @end deffn @end deftp + at anchor{color-dialog} + at deftp Class color-dialog +This class provides a standard dialog for choosing (or defining new) + at ref{color}s. The @ref{with-color-dialog} macro wraps the creation of +this dialog type and subsequent retrieval of the user's color choice. +However, applications may choose to implement these steps manually, in +which case the @ref{obtain-chosen-color} function can be used.@*@* +Like other system dialogs in Graphic-Forms, @code{color-dialog} is +derived from @ref{widget} rather than @ref{dialog} since the majority +of its functionality is implemented by the system. @strong{Note:} A +future release will provide a customization mechanism. + at deffn Initarg :initial-color +This initarg causes the dialog to show the specified color as +initially selected. + at end deffn + at deffn Initarg :initial-custom-colors +This initarg accepts a list of color objects which are used to +populate the custom color editing portion of the dialog. A +maximum of 16 colors are used, with any extras supplied in the +list being ignored. Fewer than 16 may be supplied, in which case +black is displayed as a default color for the remaining entries. + at end deffn + at deffn Initarg :owner +A value is required for this initarg, and it may be either a + at ref{window} or a dialog. + at end deffn + at deffn Initarg :style +This initarg accepts a list of keyword symbols: + at table @code + at item :allow-custom-colors +This configures the dialog to enable the Define Custom Color +button, which when clicked reveals additional controls for +creating custom colors. + at item :display-solid-only +This configures the dialog to only display solid colors in the +set of basic colors. + at end table + at end deffn + at end deftp + @anchor{control} @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @@ -314,7 +354,7 @@ must be followed by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{file-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority -of its functionality is implemented by the system. @strong{NOTE:} A +of its functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@*@* @deffn Initarg :default-extension Specifies a default extension to be appended to a file name if @@ -354,7 +394,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :add-to-recent This enables the system to add a link to the selected file @@ -374,7 +414,7 @@ for data to be saved. @item :show-hidden This keyword enables the dialog to display files marked @sc{hidden} by -the system. @strong{NOTE:} files marked both @sc{hidden} and +the system. @strong{Note:} files marked both @sc{hidden} and @sc{system} will not be displayed in any case. Also, be aware that using this keyword effectively overrides the user's preference settings. @@ -402,7 +442,7 @@ by an explicit call to @ref{dispose}.@*@* Like other system dialogs in Graphic-Forms, @code{font-dialog} is derived from @ref{widget} rather than @ref{dialog} since the majority of its -functionality is implemented by the system. @strong{NOTE:} A future release +functionality is implemented by the system. @strong{Note:} A future release will provide a customization mechanism.@* @deffn Initarg :gc This required initarg accepts a @ref{graphics-context} object providing @@ -424,7 +464,7 @@ @ref{window} or a @ref{dialog}. @end deffn @deffn Initarg :style -This initarg accepts a list of keyword symbols, as follows: +This initarg accepts a list of keyword symbols: @table @code @item :all-fonts This is a convenience style, used by default if no other font @@ -453,7 +493,7 @@ @anchor{group} @deftp Class group children location size style - at strong{NOTE:} this class is not yet fully implemented + at strong{Note:} this class is not yet fully implemented and does not yet participate in the layout protocol.@*@* A @code{group} represents a logical rectangular aggregation of @ref{window} children which has the following properties @@ -748,7 +788,7 @@ This slot holds a margin value in pixels for the bottom side of the container. @item data -This slot holds a @sc{alist} of pairs, each one associating a +This slot holds an @sc{alist} of pairs, each one associating a @sc{plist} of layout-specific attributes with an item from a container. @item left-margin @@ -1171,7 +1211,7 @@ @end deffn @anchor{capture-mouse} - at deffn Function capture-mouse self + at defun capture-mouse self Enables the @ref{window} identified by @code{self} to receive mouse input events even when the mouse pointer is outside of the bounds of @code{self}. Only one window at a time can capture the mouse. This @@ -1179,7 +1219,7 @@ background windows may still capture the mouse, but only mouse move events will be received and those only when the mouse hotspot is within the visible portions of such a window. @xref{release-mouse}. - at end deffn + at end defun @anchor{center-on-owner} @deffn GenericFunction center-on-owner self @@ -1319,13 +1359,13 @@ @end deffn @anchor{file-dialog-paths} - at deffn Function file-dialog-paths dlg => @sc{list} + at defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @ref{file-dialog} to obtain the paths for selected files. This return value is either @sc{nil} if the user cancelled the dialog, or a list of file @sc{namestring}s. Use this function when manually constructing a file dialog. @xref{with-file-dialog}. - at end deffn + at end defun @deffn GenericFunction focus-p self Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil} @@ -1333,7 +1373,7 @@ @end deffn @anchor{font-dialog-results} - at deffn Function font-dialog-results dlg gc => @ref{font}, @ref{color} + at defun font-dialog-results dlg gc => @ref{font}, @ref{color} Interrogates the data structure associated with an instance of @ref{font-dialog} to obtain the @ref{font} and @ref{color} corresponding to selections made by the user, and returns @@ -1343,7 +1383,7 @@ Also, the color value will be @sc{nil} if the dialog was created with the @code{:no-effects} style keyword. Use this function when manually constructing a font dialog. @xref{with-font-dialog}. - at end deffn + at end defun @deffn GenericFunction give-focus self Places keyboard focus on @code{self}. @@ -1420,23 +1460,28 @@ the new minimum. @xref{maximum-size}. @end deffn - at deffn GenericFunction object-to-display self pnt -Return a point that is the result of transforming the specified point -from this object's coordinate system to display-relative coordinates. - at end deffn + at anchor{obtain-chosen-color} + at defun obtain-chosen-color @ref{color-dialog} => @ref{color}, list +Interrogates the data structure associated with @var{color-dialog} +to retrieve @var{color}. The secondary value is a list of color +objects corresponding to custom colors displayed by the dialog. +If the user cancelled the dialog, @sc{nil} is returned for both +values. Use this function when manually constructing a color dialog. + at xref{with-color-dialog}. + at end defun @anchor{obtain-displays} - at deffn Function obtain-displays + at defun obtain-displays => list Returns a list of @ref{display} objects, each of which describes a monitor attached to the system. The system specifies that one of these is the primary @ref{display}. - at end deffn + at end defun @anchor{obtain-primary-display} - at deffn Function obtain-primary-display -Return a @ref{display} object that is regarded by the system as + at defun obtain-primary-display => @ref{display} +Return a display object that is regarded by the system as being the primary. - at end deffn + at end defun @anchor{owner} @deffn GenericFunction owner self @@ -1461,11 +1506,12 @@ @anchor{pack} @deffn GenericFunction pack self -Causes @code{self} to be resized to its preferred @ref{size}. +Causes @var{self} to be resized to the dimensions returned +by @ref{preferred-size}. @end deffn @anchor{parent} - at deffn GenericFunction parent self + at deffn GenericFunction parent self => @ref{window} Returns the @code{parent} of @code{self}. In the case of @ref{panel}s and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or @ref{top-level} window. In the case of a dialog or @ref{top-level}, @@ -1508,10 +1554,10 @@ must determine how tall it would be given that width. @end deffn - at deffn Function primary-p display + at defun primary-p display Returns T if the system regards the specified display as the primary display; nil otherwise. - at end deffn + at end defun @deffn GenericFunction redo-available-p self => boolean Returns T if @code{self} has @sc{redo} capability and has an @@ -1523,10 +1569,10 @@ @end deffn @anchor{release-mouse} - at deffn Function release-mouse + at defun release-mouse Clears the mouse capture state to restore normal mouse input processing. @xref{capture-mouse}. - at end deffn + at end defun @anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean @@ -1651,6 +1697,16 @@ @end deffn @end html + at anchor{with-color-dialog} + at defmac with-color-dialog (owner style color custom-colors &key initial-color initial-custom-colors) &body body +This macro wraps the instantiation of a standard color dialog and +the subsequent retrieval of the user's color selection (supplied to @var{body} +via @var{color}). The @var{custom-colors} argument is bound to a list containing +colors that the user has modified in the extended portion of the dialog. + at xref{color-dialog}. + at end defmac + + at anchor{with-drawing-disabled} @defmac with-drawing-disabled (widget) &body body This macro executes @var{body} while updates of @var{widget} are disabled. Drawing operations attempted while @var{body} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 18:56:20 2006 @@ -122,6 +122,9 @@ (:file "timer") (:file "item") (:file "widget") + (:file "color-dialog") + (:file "file-dialog") + (:file "font-dialog") (:file "control") (:file "edit") (:file "label") @@ -136,8 +139,6 @@ (:file "top-level") (:file "panel") (:file "dialog") - (:file "file-dialog") - (:file "font-dialog") (:file "layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 19 18:56:20 2006 @@ -244,6 +244,7 @@ ;; classes and structs #:button #:caret + #:color-dialog #:control #:dialog #:display @@ -462,7 +463,7 @@ #:move-above #:move-below #:moveable-p - #:object-to-display + #:obtain-chosen-color #:obtain-displays #:obtain-event-time #:obtain-primary-display @@ -523,6 +524,7 @@ #:vertical-scrollbar #:visible-item-count #:visible-p + #:with-color-dialog #:with-drawing-disabled #:with-file-dialog #:with-font-dialog Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sat Aug 19 18:56:20 2006 @@ -117,6 +117,14 @@ :initial-directory #P"c:/") (print paths))) +(defun choose-color-dlg (disp item) + (declare (ignore disp item)) + (gfw:with-color-dialog (*main-win* '(:allow-custom-colors) color custom-colors :initial-custom-colors (list gfg:*color-red* gfg:*color-blue*)) + (if color + (print color)) + (if custom-colors + (print custom-colors)))) + (defun choose-font-dlg (disp item) (declare (ignore disp item)) (gfw:with-graphics-context (gc *main-win*) @@ -235,16 +243,17 @@ (setf menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Custom Dialogs" - :submenu ((:item "&Modal" :callback #'open-modal-dlg) - (:item "&Modeless" :callback #'open-modeless-dlg))) + :submenu ((:item "&Modal" :callback #'open-modal-dlg) + (:item "&Modeless" :callback #'open-modeless-dlg))) (:item "&System Dialogs" - :submenu ((:item "&Choose Font" :callback #'choose-font-dlg) - (:item "&Open File" :callback #'open-file-dlg) - (:item "&Save File" :callback #'save-file-dlg))) + :submenu ((:item "Choose &Color" :callback #'choose-color-dlg) + (:item "Choose &Font" :callback #'choose-font-dlg) + (:item "&Open File" :callback #'open-file-dlg) + (:item "&Save File" :callback #'save-file-dlg))) (:item "&Windows" - :submenu ((:item "&Borderless" :callback #'create-borderless-win) - (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Palette" :callback #'create-palette-win)))))) + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Palette" :callback #'create-palette-win)))))) (setf (gfw:menu-bar *main-win*) menubar) (setf (gfw:image *main-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (gfw:show *main-win* t))) Modified: trunk/src/uitoolkit/system/comdlg32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comdlg32.lisp (original) +++ trunk/src/uitoolkit/system/comdlg32.lisp Sat Aug 19 18:56:20 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comdlg32.dll") (defcfun + ("ChooseColorA" choose-color) + BOOL + (struct LPTR)) ; choosecolor struct + +(defcfun ("ChooseFontA" choose-font) BOOL (struct LPTR)) ; choosefont struct Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Aug 19 18:56:20 2006 @@ -137,10 +137,20 @@ (defconstant +cbm-init+ #x04) -(defconstant +cchdevicename+ 32) +(defconstant +cc-rgbinit+ #x00000001) +(defconstant +cc-fullopen+ #x00000002) +(defconstant +cc-preventfullopen+ #x00000004) +(defconstant +cc-showhelp+ #x00000008) +(defconstant +cc-enablehook+ #x00000010) +(defconstant +cc-enabletemplate+ #x00000020) +(defconstant +cc-enabletemplatehandle+ #x00000040) +(defconstant +cc-solidcolor+ #x00000080) +(defconstant +cc-anycolor+ #x00000100) (defconstant +ccerr-choosecolorcodes+ #x5000) +(defconstant +cchdevicename+ 32) + (defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Aug 19 18:56:20 2006 @@ -150,6 +150,17 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct choosecolor + (ccsize DWORD) + (howner HANDLE) + (hinst HANDLE) + (result COLORREF) + (ccolors LPTR) + (flags DWORD) + (cdata LPARAM) + (hookfn LPTR) ; CCHookProc + (templname :string)) + (defcstruct choosefont (structsize DWORD) (howner HANDLE) @@ -159,7 +170,7 @@ (flags DWORD) (color COLORREF) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be CFHookProc + (hookfn LPTR) ; CFHookProc (templname :string) (hinstance HANDLE) (style :string) @@ -184,7 +195,7 @@ (whatlen WORD) (withlen WORD) (data LPARAM) - (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc + (hookfn LPTR) ; FRHookProc (templname :string)) (defcstruct iconinfo Added: trunk/src/uitoolkit/widgets/color-dialog.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/color-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -0,0 +1,130 @@ +;;;; +;;;; color-dialog.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.widgets) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +custom-color-array-size+ 16)) + +;;; +;;; helper functions +;;; + +(defun obtain-chosen-color (dlg) + (let ((cc-ptr (gfs:handle dlg))) + (if (cffi:null-pointer-p cc-ptr) + (error 'gfs:disposed-error)) + (cffi:with-foreign-slots ((gfs::result gfs::ccolors) cc-ptr gfs::choosecolor) + (values (gfg:rgb->color gfs::result) + (loop for index to (1- +custom-color-array-size+) + collect (gfg:rgb->color (cffi:mem-aref gfs::ccolors 'gfs::colorref index))))))) + +(defmacro with-color-dialog ((owner style color custom-colors &key initial-color initial-custom-colors) &body body) + (let ((dlg (gensym))) + `(let ((,color nil) + (,custom-colors nil) + (,dlg (make-instance 'color-dialog + :initial-custom-colors ,initial-custom-colors + :initial-color ,initial-color + :owner ,owner + :style ,style))) + (unwind-protect + (unless (zerop (show ,dlg t)) + (multiple-value-bind (tmp-color tmp-custom) + (obtain-chosen-color ,dlg) + (setf ,color tmp-color + ,custom-colors tmp-custom) + , at body)) + (gfs:dispose ,dlg))))) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self color-dialog) &rest extra-data) + (let ((std-flags (logior gfs::+cc-anycolor+ gfs::+cc-preventfullopen+ (if extra-data gfs::+cc-rgbinit+ 0)))) + (loop for sym in (style-of self) + do (ecase sym + (:allow-custom-colors + (setf std-flags (logand std-flags (lognot gfs::+cc-preventfullopen+)))) + (:display-solid-only) + (setf std-flags (logior std-flags gfs::+cc-solidcolor+)))) + (values std-flags 0))) + +(defmethod gfs:dispose ((self color-dialog)) + (let ((cc-ptr (gfs:handle self))) + (unless (cffi:null-pointer-p cc-ptr) + (cffi:with-foreign-slots ((gfs::ccolors) cc-ptr gfs::choosecolor) + (unless (cffi:null-pointer-p gfs::ccolors) + (cffi:foreign-free gfs::ccolors))) + (cffi:foreign-free cc-ptr) + (setf (slot-value self 'gfs:handle) nil)))) + +(defmethod initialize-instance :after ((self color-dialog) &key initial-color initial-custom-colors owner &allow-other-keys) + (if (null owner) + (error 'gfs:toolkit-error :detail ":owner initarg is required")) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let ((cc-ptr (cffi:foreign-alloc 'gfs::choosecolor)) + (colors-ptr (cffi:foreign-alloc 'gfs::colorref :count +custom-color-array-size+)) + (index 0) + (default-rgb (gfg:color->rgb gfg:*color-black*))) + (loop for color in initial-custom-colors + when (< index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) (gfg:color->rgb color)) + (incf index))) + (loop until (>= index +custom-color-array-size+) + do (progn + (setf (cffi:mem-aref colors-ptr 'gfs::colorref index) default-rgb) + (incf index))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self initial-color) + (declare (ignore ex-style)) + (cffi:with-foreign-slots ((gfs::ccsize gfs::howner gfs::hinst gfs::result + gfs::ccolors gfs::flags gfs::cdata gfs::hookfn gfs::templname) + cc-ptr gfs::choosecolor) + (setf gfs::ccsize (cffi:foreign-type-size 'gfs::choosecolor) + gfs::howner (gfs:handle owner) + gfs::hinst (cffi:null-pointer) + gfs::result (gfg:color->rgb (or initial-color (gfg:make-color))) + gfs::ccolors colors-ptr + gfs::flags std-style + gfs::cdata 0 + gfs::hookfn (cffi:null-pointer) + gfs::templname (cffi:null-pointer)))) + (setf (slot-value self 'gfs:handle) cc-ptr))) + +(defmethod show ((self color-dialog) flag) + (declare (ignore flag)) + (show-common-dialog self #'gfs::choose-color)) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -38,19 +38,18 @@ ;;; (defun file-dialog-paths (dlg) - (let ((paths nil) - (ofn-ptr (gfs:handle dlg))) + (let ((ofn-ptr (gfs:handle dlg))) (if (cffi:null-pointer-p ofn-ptr) (error 'gfs:disposed-error)) (cffi:with-foreign-slots ((gfs::ofnfile) ofn-ptr gfs::openfilename) - (unless (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + (if (or (cffi:null-pointer-p gfs::ofnfile) (= (cffi:mem-ref gfs::ofnfile :char) 0)) + nil (let* ((raw-list (extract-foreign-strings gfs::ofnfile)) (dir-str (first raw-list))) - (if (cdr raw-list) - (setf paths (loop for filename in (cdr raw-list) - collect (parse-namestring (concatenate 'string dir-str "\\" filename)))) - (setf paths (list (parse-namestring dir-str))))))) - paths)) + (if (rest raw-list) + (loop for filename in (rest raw-list) + collect (parse-namestring (concatenate 'string dir-str "\\" filename))) + (list (parse-namestring dir-str)))))))) (defmacro with-file-dialog ((owner style paths &key default-extension filters initial-directory initial-filename text) &body body) (let ((dlg (gensym))) @@ -106,7 +105,7 @@ (unless (cffi:null-pointer-p gfs::ofndefext) (cffi:foreign-free gfs::ofndefext))) (cffi:foreign-free ofn-ptr) - (setf (slot-value self 'gfs:handle) (cffi:null-pointer))))) + (setf (slot-value self 'gfs:handle) nil)))) (defmethod initialize-instance :after ((self file-dialog) &key default-extension filters initial-directory initial-filename owner style text) ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE Modified: trunk/src/uitoolkit/widgets/font-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/font-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/font-dialog.lisp Sat Aug 19 18:56:20 2006 @@ -65,12 +65,11 @@ :owner ,owner :style ,style))) (unwind-protect - (progn - (unless (zerop (show ,dlg t)) - (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) - (setf ,font f) - (setf ,color c)) - , at body)) + (unless (zerop (show ,dlg t)) + (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc) + (setf ,font f) + (setf ,color c)) + , at body) (gfs:dispose ,dlg))))) ;;; Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sat Aug 19 18:56:20 2006 @@ -116,15 +116,15 @@ (setf (top-margin-of self) vertical-margins (bottom-margin-of self) vertical-margins))) -(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) - (let ((orig-layout (layout-of container))) +(defmethod (setf layout-of) :after ((layout layout-manager) (self layout-managed)) + (let ((orig-layout (layout-of self))) (if orig-layout - (setf (data-of self) (loop for item in (data-of orig-layout) - when (not (gfs:disposed-p (first item))) - collect item) + (setf (data-of layout) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) (data-of orig-layout) nil) - (if (typep container 'window) - (setf (data-of self) (mapchildren container (lambda (parent child) + (if (typep self 'window) + (setf (data-of layout) (mapchildren self (lambda (parent child) (declare (ignore parent)) (list child nil)))))))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 18:56:20 2006 @@ -142,6 +142,9 @@ (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) +(defclass color-dialog (widget) () + (:documentation "This class represents the standard color chooser dialog.")) + (defclass file-dialog (widget) ((open-mode :reader open-mode Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 18:56:20 2006 @@ -249,9 +249,6 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (self pnt) - (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) - (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent).")) From junrue at common-lisp.net Sun Aug 20 00:37:14 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 19 Aug 2006 20:37:14 -0400 (EDT) Subject: [graphic-forms-cvs] r223 - in trunk: . docs/manual src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060820003714.9436218008@common-lisp.net> Author: junrue Date: Sat Aug 19 20:37:13 2006 New Revision: 223 Modified: trunk/NEWS.txt trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp Log: changed obtain-event-time to call native GetMessageTime, and removed obsolete slot from thread-context Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Aug 19 20:37:13 2006 @@ -4,6 +4,8 @@ to enable the stdcall calling convention for alien callbacks, located in src/external-libraries/sbcl-callback-patch +. Implemented the standard color chooser dialog. + ============================================================================== Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 20:37:13 2006 @@ -1162,8 +1162,7 @@ @anchor{obtain-event-time} @defun obtain-event-time => milliseconds -Returns the timestamp for the event currently being processed, or -zero if called prior to delivery of any events. +Returns the timestamp for the event currently being processed. @end defun Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sat Aug 19 20:37:13 2006 @@ -414,6 +414,10 @@ (filter-max UINT)) (defcfun + ("GetMessageTime" get-message-time) + LONG) + +(defcfun ("GetMonitorInfoA" get-monitor-info) BOOL (hmonitor HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Aug 19 20:37:13 2006 @@ -78,7 +78,6 @@ gfs::time gfs::pnt) msg-ptr gfs::msg) - (setf (event-time (thread-context)) gfs::time) (when (funcall msg-filter gm msg-ptr) (return-from message-loop gfs::wparam))))))) @@ -140,10 +139,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -;;; FIXME: replace event-time slot with call to GetMessageTime -;;; (defun obtain-event-time () - (event-time (thread-context))) + (gfs::get-message-time)) (defun option->reason (lparam) ;; MSDN says the value is a bitmask, so must be tested bit-wise. Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 20:37:13 2006 @@ -40,7 +40,6 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) From junrue at common-lisp.net Sun Aug 20 02:13:37 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 19 Aug 2006 22:13:37 -0400 (EDT) Subject: [graphic-forms-cvs] r224 - in trunk: . docs/manual src/uitoolkit/graphics src/uitoolkit/widgets Message-ID: <20060820021337.46D3922004@common-lisp.net> Author: junrue Date: Sat Aug 19 22:13:35 2006 New Revision: 224 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: cleaned up some SBCL style warnings Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 19 22:13:35 2006 @@ -317,19 +317,23 @@ this time. @anchor{background-color} - at deffn GenericFunction background-color self + at deffn GenericFunction background-color self => @ref{color} +(setf (@strong{background-color} @var{self}) @var{color})@*@* Returns a color object corresponding to the current background color. +The corresponding @sc{setf} function allows the background color to +be set. @end deffn @anchor{data-object} @deffn GenericFunction data-object self &optional gc => object +(setf (@strong{data-object} @var{self}) @var{object})@*@* Returns the data structure representing the raw data form of the object. The @code{gc} argument must be supplied when calling this -function on a @ref{font}, and the value must be a - at ref{graphics-context}. +function on a @ref{font}, and the value must be a @ref{graphics-context}. +The corresponding @sc{setf} function updates this representation. @end deffn - at deffn GenericFunction depth self + at deffn GenericFunction depth self => integer Returns the bits-per-pixel depth of the object. @end deffn @@ -521,13 +525,18 @@ @end table @end deffn - at deffn GenericFunction font self -Returns the current font. + at deffn GenericFunction font self => @ref{font} +(setf (@strong{font} @var{self}) @var{font})@*@* +Returns the current font. The corresponding @sc{setf} function +allows the font to be set. @end deffn @anchor{foreground-color} - at deffn GenericFunction foreground-color self + at deffn GenericFunction foreground-color self => @ref{color} +(setf (@strong{foreground-color} @var{self}) @var{color})@*@* Returns a color object corresponding to the current foreground color. +The corresponding @sc{setf} function allows the foreground color +to be set. @end deffn @anchor{icon-bundle-length} @@ -603,7 +612,10 @@ @end defun @deffn GenericFunction size self => @ref{size} +(setf (@strong{size} @var{self}) @var{size})@*@* Returns a size object describing the dimensions of @var{self}. +The corresponding @sc{setf} function allows the size to be +set. @end deffn @deffn GenericFunction text-extent self text &optional style tab-width @@ -632,5 +644,6 @@ @defmac with-image-transparency (image point) &body body This macro wraps @var{body} in an @sc{unwind-protect} form with @var{point} set as the @ref{transparency-pixel} for @var{image}. -Any existing point set in @var{image} is restored. +The original point set in @var{image}, if any, is restored after + at var{body} completes. @end defmac Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 19 22:13:35 2006 @@ -1395,9 +1395,7 @@ @end deffn @deffn GenericFunction image self => @ref{image} - -(setf (@strong{image} @var{self}) @var{image})@* - +(setf (@strong{image} @var{self}) @var{image})@*@* Returns the image currently associated with @var{self}. The @sc{setf} function changes the image. If @var{self} is a @ref{window}, then this function returns an @ref{icon-bundle}. And in that case, the @sc{setf} function accepts either @@ -1419,6 +1417,7 @@ @end deffn @deffn GenericFunction location self => @ref{point} +(setf (@strong{location} @var{self}) @var{point})@*@* Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. @xref{parent}. @@ -1433,6 +1432,7 @@ @anchor{maximum-size} @deffn GenericFunction maximum-size self => size +(setf (@strong{maximum-size} @var{self}) @var{size})@*@* Returns a @ref{size} object describing the largest dimensions to which the user may resize this widget. By default, @ref{window}s and @ref{control}s return @sc{nil} indicating that there is effectively no @@ -1442,12 +1442,14 @@ is resized to the new maximum. @xref{minimum-size}. @end deffn - at deffn GenericFunction menu-bar self + at deffn GenericFunction menu-bar self => @ref{menu} +(setf (@strong{menu-bar} @var{self}) @var{menu})@*@* Returns the menu object serving as the menubar for this object. @end deffn @anchor{minimum-size} @deffn GenericFunction minimum-size self => size +(setf (@strong{minimum-size} @var{self}) @var{size})@*@* Returns a @ref{size} object describing the smallest dimensions to which the user may resize this widget. By default, @ref{window} objects return @sc{nil} indicating that the minimum constraint is @@ -1625,7 +1627,8 @@ necessarily top-most in the display z-order. @end deffn - at deffn GenericFunction size self + at deffn GenericFunction size self => @ref{size} +(setf (@strong{size} @var{self}) @var{size})@*@* Returns a size object describing the size of the object in its parent's coordinate system. @end deffn @@ -1659,7 +1662,8 @@ @end deffn @anchor{text-modified-p} - at deffn GenericFunction text-modified-p self + at deffn GenericFunction text-modified-p self => boolean +(setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@* Returns T if the text component of @code{self} has been modified by the user; @sc{nil} otherwise. The corresponding @sc{setf} function updates the dirty state flag. This function is not implemented for all Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sat Aug 19 22:13:35 2006 @@ -78,12 +78,14 @@ ((:file "graphics-constants") (:file "graphics-classes") (:file "graphics-generics") - (:file "color") - (:file "palette") + (:file "color" + :depends-on ("graphics-classes")) + (:file "palette" + :depends-on ("graphics-classes")) (:file "image-data" :depends-on ("graphics-classes")) (:file "image" - :depends-on ("graphics-classes")) + :depends-on ("graphics-classes" "graphics-generics")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sat Aug 19 22:13:35 2006 @@ -36,11 +36,17 @@ (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) +(defgeneric (setf background-color) (color self) + (:documentation "Sets the current background color.")) + (defgeneric data->image (self) (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) (defgeneric data-object (self &optional gc) - (:documentation "Returns the data structure representing the raw form of the object.")) + (:documentation "Returns the data structure representing the raw form of self.")) + +(defgeneric (setf data-object) (data self) + (:documentation "Sets a data structure representing the raw form of self.")) (defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) @@ -111,9 +117,15 @@ (defgeneric font (self) (:documentation "Returns the current font.")) +(defgeneric (setf font) (font self) + (:documentation "Sets the current font.")) + (defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) +(defgeneric (setf foreground-color) (color self) + (:documentation "Sets the current foreground color.")) + (defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) @@ -121,7 +133,10 @@ (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) (defgeneric size (self) - (:documentation "Returns a size object describing the size of the object.")) + (:documentation "Returns a size object describing the dimensions of self.")) + +(defgeneric (setf size) (size self) + (:documentation "Sets the dimensions of self.")) (defgeneric text-extent (self str &optional style tab-width) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sat Aug 19 22:13:35 2006 @@ -117,7 +117,6 @@ font)) (defmethod (setf gfg:font) :before (font (self control)) - (declare (ignore color)) (if (or (gfs:disposed-p self) (gfs:disposed-p font)) (error 'gfs:disposed-error))) @@ -161,19 +160,24 @@ (let ((class (define-dispatcher (class-name (class-of self)) callback))) (setf (dispatcher self) (make-instance (class-name class)))))) -(defmethod (setf maximum-size) :after (max-size (self control)) +(defmethod maximum-size ((self control)) + (max-size-of self)) + +(defmethod (setf maximum-size) (max-size (self control)) (unless (gfs:disposed-p self) + (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) -(defmethod minimum-size :after ((self control)) - (let ((size (slot-value self 'minimum-size))) +(defmethod minimum-size ((self control)) + (let ((size (min-size-of self))) (if (null size) (preferred-size self -1 -1) size))) -(defmethod (setf minimum-size) :after (min-size (self control)) +(defmethod (setf minimum-size) (min-size (self control)) (unless (gfs:disposed-p self) + (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Sat Aug 19 22:13:35 2006 @@ -42,6 +42,5 @@ (error 'gfs:toolkit-error :detail "null owner handle"))) (defmethod checked-p :before ((self item)) - (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat Aug 19 22:13:35 2006 @@ -95,6 +95,28 @@ (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) +(defgeneric init-utility-hwnd (self)) +(defgeneric call-child-visitor-func (self parent child)) +(defgeneric call-display-visitor-func (self hmonitor data)) +(defgeneric call-top-level-visitor-func (self window)) +(defgeneric get-widget (self hwnd)) +(defgeneric put-widget (self widget)) +(defgeneric delete-widget (self hwnd)) +(defgeneric widget-in-progress (self)) +(defgeneric (setf widget-in-progress) (widget self)) +(defgeneric clear-widget-in-progress (self)) +(defgeneric put-kbdnav-widget (self widget)) +(defgeneric delete-kbdnav-widget (self widget)) +(defgeneric intercept-kbdnav-message (self msg-ptr)) +(defgeneric get-menuitem (self id)) +(defgeneric put-menuitem (self item)) +(defgeneric delete-menuitem (self item)) +(defgeneric increment-menuitem-id (self)) +(defgeneric get-timer (self id)) +(defgeneric put-timer (self timer)) +(defgeneric delete-timer (self timer)) +(defgeneric increment-widget-id (self)) + (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Aug 19 22:13:35 2006 @@ -115,12 +115,12 @@ (pixel-point :accessor pixel-point-of :initform nil) - (maximum-size - :accessor maximum-size + (max-size + :accessor max-size-of :initarg :maximum-size :initform nil) - (minimum-size - :accessor minimum-size + (min-size + :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) @@ -169,12 +169,12 @@ (:documentation "The menu class represents a container for menu items (and submenus).")) (defclass window (widget layout-managed) - ((maximum-size - :accessor maximum-size + ((max-size + :accessor max-size-of :initarg :maximum-size :initform nil) - (minimum-size - :accessor minimum-size + (min-size + :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Aug 19 22:13:35 2006 @@ -193,7 +193,10 @@ (:documentation "Returns T if the object is in its iconified state.")) (defgeneric image (self) - (:documentation "Returns the object's image object if it has one, or nil otherwise.")) + (:documentation "Returns self's image object if it has one, or nil otherwise.")) + +(defgeneric (setf image) (image self) + (:documentation "Sets self's image object.")) (defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) @@ -211,7 +214,10 @@ (:documentation "Returns T if the object's lines are visible; nil otherwise.")) (defgeneric location (self) - (:documentation "Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system.")) + (:documentation "Returns a point object describing the coordinates of the top-left corner of self in its parent's coordinate system.")) + +(defgeneric (setf location) (point self) + (:documentation "Sets a point describing the coordinates of self in its parent's coordinate system.")) (defgeneric lock (self flag) (:documentation "Prevents or enables modification of the object's contents.")) @@ -229,13 +235,19 @@ (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) (defgeneric maximum-size (self) - (:documentation "Returns a size object describing the largest dimensions to which the user may resize the widget.")) + (:documentation "Returns a size object describing the largest dimensions to which the user may resize self.")) + +(defgeneric (setf maximum-size) (size self) + (:documentation "Sets the largest dimensions to which the user may resize self.")) (defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) (defgeneric minimum-size (self) - (:documentation "Returns a size object describing the smallest size this object can exist.")) + (:documentation "Returns a size object describing the smallest supported dimensions of self.")) + +(defgeneric (setf minimum-size) (size self) + (:documentation "Sets the smallest supported dimensions of self.")) (defgeneric mouse-over-image (self) (:documentation "Returns the image displayed when the mouse is hovering over this object.")) @@ -340,7 +352,10 @@ (:documentation "This object's items are scrolled until the selection is visible.")) (defgeneric size (self) - (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) + (:documentation "Returns the size of self in its parent's coordinate system.")) + +(defgeneric (setf size) (size self) + (:documentation "Sets the size of self in its parent's coordinate system.")) (defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) @@ -363,6 +378,9 @@ (defgeneric text-modified-p (self) (:documentation "Returns true if the text component has been modified; nil otherwise.")) +(defgeneric (setf text-modified-p) (modified self) + (:documentation "Sets self's modified flag.")) + (defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sat Aug 19 22:13:35 2006 @@ -259,15 +259,23 @@ (setf (child-visitor-results tc) nil) tmp))) -(defmethod (setf maximum-size) :after (max-size (self window)) +(defmethod maximum-size ((self window)) + (max-size-of self)) + +(defmethod (setf maximum-size) (max-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) + (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) size))) -(defmethod (setf minimum-size) :after (min-size (self window)) +(defmethod minimum-size ((self window)) + (min-size-of self)) + +(defmethod (setf minimum-size) (min-size (self window)) (unless (or (gfs:disposed-p self) (null (layout-of self))) + (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size) (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) From junrue at common-lisp.net Mon Aug 21 03:03:54 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 20 Aug 2006 23:03:54 -0400 (EDT) Subject: [graphic-forms-cvs] r225 - in trunk: . src/demos src/demos/textedit src/demos/unblocked src/uitoolkit/widgets Message-ID: <20060821030354.E323E30046@common-lisp.net> Author: junrue Date: Sun Aug 20 23:03:53 2006 New Revision: 225 Added: trunk/src/demos/demo-utils.lisp trunk/src/demos/textedit/textedit.ico (contents, props changed) trunk/src/demos/unblocked/unblocked.ico (contents, props changed) Modified: trunk/graphic-forms-tests.asd trunk/src/demos/textedit/textedit-document.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: fixed bug in extract-foreign-strings function; removal of Cells usage from textedit demo; implemented shared about dialog for demo programs Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 20 23:03:53 2006 @@ -61,13 +61,16 @@ :components ((:module "demos" :components - ((:module "textedit" + ((:file "demo-utils") + (:module "textedit" :serial t + :depends-on ("demo-utils") :components ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" :serial t + :depends-on ("demo-utils") :components ((:file "tiles") (:file "unblocked-model") Added: trunk/src/demos/demo-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/demos/demo-utils.lisp Sun Aug 20 23:03:53 2006 @@ -0,0 +1,96 @@ +;;;; +;;;; demo-utils.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.tests) + +(defclass demo-about-dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp demo-about-dialog-events) (dlg gfw:dialog)) + (call-next-method) + (gfs:dispose dlg)) + +(defun about-demo (owner image-path title desc) + (let* ((image (make-instance 'gfg:image :file image-path)) + (dlg (make-instance 'gfw:dialog :owner owner + :dispatcher (make-instance 'demo-about-dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 8) + :style '(:owner-modal) + :text title)) + (label (make-instance 'gfw:label :parent dlg)) + (text-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 2 + :style '(:vertical)) + :parent dlg)) + (line1 (make-instance 'gfw:label + :parent text-panel + :text desc)) + (line2 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line3 (make-instance 'gfw:label + :parent text-panel + :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + (line4 (make-instance 'gfw:label + :parent text-panel + :text "All Rights Reserved.")) + (line5 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (line6 (make-instance 'gfw:label + :parent text-panel + :text " ")) + (btn-panel (make-instance 'gfw:panel + :parent dlg + :layout (make-instance 'gfw:flow-layout + :margins 0 + :spacing 0 + :style '(:vertical :normalize)))) + (close-btn (make-instance 'gfw:button + :callback (lambda (disp btn) + (declare (ignore disp btn)) + (gfs:dispose dlg)) + :style '(:cancel-button) + :text "Close" + :parent btn-panel))) + (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) + (unwind-protect + (gfg:with-image-transparency (image (gfs:make-point)) + (setf (gfw:image label) image)) + (gfs:dispose image)) + (gfw:pack dlg) + (gfw:center-on-owner dlg) + (gfw:show dlg t))) Modified: trunk/src/demos/textedit/textedit-document.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-document.lisp (original) +++ trunk/src/demos/textedit/textedit-document.lisp Sun Aug 20 23:03:53 2006 @@ -33,18 +33,13 @@ (in-package :graphic-forms.uitoolkit.tests) -(cells:defmodel textedit-document () - ((content-replaced - :cell :ephemeral - :accessor content-replaced - :initform (cells:c-in nil)) - (content-modified - :cell :ephemeral - :accessor content-modified - :initform (cells:c-in nil)) +(defclass textedit-document () + ((content-modified + :accessor content-modified-of + :initform nil) (file-path - :accessor file-path - :initform (cells:c-in nil)))) + :accessor file-path-of + :initform nil))) (defvar *textedit-model* (make-instance 'textedit-document)) @@ -57,7 +52,7 @@ (if (zerop (length line)) (setf buffer (concatenate 'string buffer (format nil "~c~c" #\Return #\Newline))) (setf buffer (concatenate 'string buffer (format nil "~a~c~c" line #\Return #\Newline)))))) - (setf (content-replaced *textedit-model*) buffer))) + buffer)) (defun save-textedit-doc (path buffer) (with-open-file (output path :direction :output :if-exists :supersede) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 20 23:03:53 2006 @@ -39,16 +39,21 @@ (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) +(defvar *textedit-new-title* "new file - TextEdit") + + (defun manage-textedit-file-menu (disp menu) (declare (ignore disp)) - (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*))) + (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0))) (defun textedit-file-new (disp item) (declare (ignore disp item)) (when *textedit-control* (setf (gfw:text *textedit-control*) "") (setf (gfw:text-modified-p *textedit-control*) nil) - (setf (file-path *textedit-model*) nil))) + (setf (file-path-of *textedit-model*) nil) + (setf (gfw:text *textedit-win*) *textedit-new-title*))) (defun textedit-file-open (disp item) (declare (ignore disp item)) @@ -57,14 +62,16 @@ paths :filters *textedit-file-filters*) (when paths - (load-textedit-doc (first paths)) - (setf (file-path *textedit-model*) (namestring (first paths)))))) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (setf (file-path-of *textedit-model*) (namestring (first paths))) + (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)))))) (defun textedit-file-save (disp item) - (if (file-path *textedit-model*) - (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*)) + (if (file-path-of *textedit-model*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) (textedit-file-save-as disp item)) - (setf (gfw:text-modified-p *textedit-control*) nil)) + (if (file-path-of *textedit-model*) + (setf (gfw:text-modified-p *textedit-control*) nil))) (defun textedit-file-save-as (disp item) (declare (ignore disp item)) @@ -75,8 +82,9 @@ :text "Save As") (when paths (save-textedit-doc (first paths) (gfw:text *textedit-control*)) - (setf (file-path *textedit-model*) (namestring (first paths))) - (setf (gfw:text-modified-p *textedit-control*) nil)))) + (setf (file-path-of *textedit-model*) (namestring (first paths)) + (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)) + (gfw:text-modified-p *textedit-control*) nil)))) (defun textedit-file-quit (disp item) (declare (ignore disp item)) @@ -143,80 +151,11 @@ (declare (ignore window)) (textedit-file-quit disp nil)) -(defclass textedit-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-textedit (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *textedit-win* - :dispatcher (make-instance 'textedit-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About TextEdit"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "TextEdit version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) - -(cells:defobserver content-replaced ((self textedit-document)) - (if *textedit-control* - (setf (gfw:text *textedit-control*) (content-replaced self)))) - -(cells:defobserver content-modified ((self textedit-document))) - -(cells:defobserver file-path ((self textedit-document)) - (if *textedit-win* - (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self))) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.5"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu @@ -252,9 +191,11 @@ :auto-vscroll :vertical-scrollbar :want-return))) - (setf (gfw:menu-bar *textedit-win*) menubar) - (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500)) - (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit") + (setf (gfw:menu-bar *textedit-win*) menubar + (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500) + (gfw:text *textedit-win*) *textedit-new-title*) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) + (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) (gfw:show *textedit-win* t))) (defun textedit () Added: trunk/src/demos/textedit/textedit.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 20 23:03:53 2006 @@ -94,79 +94,21 @@ (declare (ignore timer)) (update-panel *tiles-panel*)) -(defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog)) - (call-next-method) - (gfs:dispose dlg)) - (defun about-unblocked (disp item) (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) - (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) - (dlg (make-instance 'gfw:dialog :owner *unblocked-win* - :dispatcher (make-instance 'unblocked-about-dialog-events) - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 8) - :style '(:owner-modal) - :text (concatenate 'string "About UnBlocked"))) - (label (make-instance 'gfw:label :parent dlg)) - (text-panel (make-instance 'gfw:panel - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 2 - :style '(:vertical)) - :parent dlg)) - (line1 (make-instance 'gfw:label - :parent text-panel - :text "UnBlocked version 0.5")) - (line2 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line3 (make-instance 'gfw:label - :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) - (line4 (make-instance 'gfw:label - :parent text-panel - :text "All Rights Reserved.")) - (line5 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (line6 (make-instance 'gfw:label - :parent text-panel - :text " ")) - (btn-panel (make-instance 'gfw:panel - :parent dlg - :layout (make-instance 'gfw:flow-layout - :margins 0 - :spacing 0 - :style '(:vertical :normalize)))) - (close-btn (make-instance 'gfw:button - :callback (lambda (disp btn) - (declare (ignore disp btn)) - (gfs:dispose dlg)) - :style '(:cancel-button) - :text "Close" - :parent btn-panel))) - (declare (ignore line1 line2 line3 line4 line5 line6 close-btn)) - (unwind-protect - (gfg:with-image-transparency (image (gfs:make-point)) - (setf (gfw:image label) image)) - (gfs:dispose image)) - (gfw:pack dlg) - (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (image-path (merge-pathnames "about.bmp"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.5"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "&New" :callback #'new-unblocked) - (:item "&Restart" :callback #'restart-unblocked) - (:item "Reveal &Move" :callback #'reveal-unblocked) - (:item "" :separator) - (:item "E&xit" :callback #'quit-unblocked))) + :submenu ((:item "&New" :callback #'new-unblocked) + (:item "&Restart" :callback #'restart-unblocked) + (:item "Reveal &Move" :callback #'reveal-unblocked) + (:item "" :separator) + (:item "E&xit" :callback #'quit-unblocked))) (:item "&Help" - :submenu ((:item "&About" :callback #'about-unblocked)))))) + :submenu ((:item "&About UnBlocked" :callback #'about-unblocked)))))) (scoreboard-buffer-size (compute-scoreboard-size)) (tile-buffer-size (gfs:make-size :width (+ (* +horz-tile-count+ +tile-bmp-width+) 2) @@ -189,14 +131,16 @@ :style '(:border) :dispatcher (make-instance 'tiles-panel-events :buffer-size tile-buffer-size))) - (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked") + (setf (gfw:text *unblocked-win*) "UnBlocked") (setf (gfw:resizable-p *unblocked-win*) nil) (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size) - (setf (gfw:maximum-size *unblocked-win*) size)) + (setf (gfw:minimum-size *unblocked-win*) size + (gfw:maximum-size *unblocked-win*) size)) (new-unblocked nil nil) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) + (setf (gfw:image *unblocked-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "unblocked.ico")))) (gfw:show *unblocked-win* t))) (defun unblocked () Added: trunk/src/demos/unblocked/unblocked.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Sun Aug 20 23:03:53 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory From junrue at common-lisp.net Mon Aug 21 04:36:52 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 21 Aug 2006 00:36:52 -0400 (EDT) Subject: [graphic-forms-cvs] r226 - in trunk: . docs/manual src/demos/unblocked src/uitoolkit/widgets Message-ID: <20060821043652.C3D942E1AB@common-lisp.net> Author: junrue Date: Mon Aug 21 00:36:51 2006 New Revision: 226 Modified: trunk/NEWS.txt trunk/README.txt trunk/build.lisp trunk/config.lisp trunk/docs/manual/overview.texinfo trunk/graphic-forms-tests.asd trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/file-dialog.lisp Log: completed removal of Cells usage, updated dependency documentation Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 00:36:51 2006 @@ -1,11 +1,16 @@ . SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch -to enable the stdcall calling convention for alien callbacks, located -in src/external-libraries/sbcl-callback-patch + to enable the stdcall calling convention for alien callbacks, located + in src/external-libraries/sbcl-callback-patch. + +. Implemented a plugin mechanism for integrating graphics libraries. . Implemented the standard color chooser dialog. +. Simplified external library dependencies, getting rid of some and + bundling small libraries into the Graphic-Forms distribution. + ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Aug 21 00:36:51 2006 @@ -16,9 +16,6 @@ http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ *note: ASDF is bundled with SBCL* - - Cells (latest from CVS) - http://www.common-lisp.net/project/cells/ - - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ @@ -114,7 +111,6 @@ ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; - ;; gfsys::*cells-dir* ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Aug 21 00:36:51 2006 @@ -44,7 +44,6 @@ (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/")) Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Mon Aug 21 00:36:51 2006 @@ -39,7 +39,6 @@ (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/") @@ -54,7 +53,6 @@ (defun configure-asdf () (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) Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Aug 21 00:36:51 2006 @@ -70,14 +70,13 @@ @section Dependencies -The libraries that Graphic-Forms relies upon are: + at strong{Libraries required by Graphic-Forms to be downloaded +separately:} @table @code @item ASDF - at url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf} - - at item Cells (latest from CVS) - at url{http://www.common-lisp.net/project/cells/} + at url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf}@* + at emph{Note that ASDF is bundled with SBCL.} @item CFFI @url{http://common-lisp.net/project/cffi} @@ -85,21 +84,39 @@ @item Closer to MOP @url{http://common-lisp.net/project/closer/downloads.html} - at item ImageMagick - at url{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe} + at item lw-compat + at url{http://common-lisp.net/project/closer/downloads.html} + at end table + + at strong{Required libraries bundled with Graphic-Forms:} + + at table @code + + at item Practical Common Lisp Chapter08 and Chapter24 + at url{http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz} @item lisp-unit @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html} - at item lw-compat - at url{http://common-lisp.net/project/closer/downloads.html} + at end table + + at strong{Optional libraries that can be used with Graphic-Forms:} + + at table @code + + at item ImageMagick + at url{http://imagemagick.org/script/binary-releases.php#windows}@* + at emph{Install the Q16 version and push the symbol +:load-imagemagick-plugin onto *features* before executing ASDF.} + @end table @section Building the Library and Running Tests Please see the @code{README.txt} file included in the -distribution for instructions on how to load the ASDF system and run tests. +distribution for instructions on how to load the test program +ASDF system and run unit-tests, test programs, and demo programs. @section Support Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Aug 21 00:36:51 2006 @@ -55,7 +55,6 @@ :version "0.5.0" :author "Jack D. Unrue" :licence "BSD" - :depends-on ("cells") :components ((:module "src" :components Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Aug 21 00:36:51 2006 @@ -117,7 +117,10 @@ (shape-pnts (shape-pnts-of self))) (when (and (eql button :left-button) shape-pnts) (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) - (game-shape-data shape-pnts) + (progn + (update-game-tiles shape-pnts) + (update-panel (get-scoreboard-panel)) + (update-panel (get-tiles-panel))) (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Mon Aug 21 00:36:51 2006 @@ -48,66 +48,53 @@ until (> entry score) finally (return level))) -(defun revise-tiles (active-tiles orig-tiles shape-data) - (if shape-data - (loop with tmp = (clone-tiles active-tiles) - for pnt in shape-data do (set-tile tmp pnt 0) - finally (return (collapse-tiles tmp))) - orig-tiles)) - -(cells:defmodel unblocked-game-model () - ((level - :accessor level - :initform (cells:c? (lookup-level-reached (^score)))) - (score - :accessor score - :initform (cells:c? (+ (or cells:.cache 0) - (* 5 (length (^shape-data)))))) +(defun compute-new-game-tiles () + (collapse-tiles (init-tiles +horz-tile-count+ +vert-tile-count+ (1- +max-tile-kinds+)))) + +(defclass unblocked-game-model () + ((score + :accessor score-of + :initform 0) (shape-data - :accessor shape-data - :initform (cells:c-in nil)) + :accessor shape-data-of + :initform nil) (original-tiles - :accessor original-tiles - :initarg :original-tiles - :initform (cells:c-in (collapse-tiles (init-tiles +horz-tile-count+ - +vert-tile-count+ - (1- +max-tile-kinds+))))) + :accessor original-tiles-of + :initform nil) (active-tiles - :accessor active-tiles - :initform (cells:c? (revise-tiles cells:.cache (^original-tiles) (^shape-data)))))) + :accessor active-tiles-of + :initform nil))) (defvar *game* (make-instance 'unblocked-game-model)) (defun new-game () - (cells:cells-reset) - (setf *game* (make-instance 'unblocked-game-model))) + (let ((tiles (compute-new-game-tiles))) + (setf (score-of *game*) 0 + (original-tiles-of *game*) tiles + (active-tiles-of *game*) tiles))) (defun restart-game () - (let ((saved-tiles (original-tiles *game*))) - (cells:cells-reset) - (setf *game* (make-instance 'unblocked-game-model :original-tiles saved-tiles)))) + (setf (score-of *game*) 0 + (active-tiles-of *game*) (original-tiles-of *game*))) (defun game-tiles () - (active-tiles *game*)) + (active-tiles-of *game*)) -(defun game-shape-data (pnts) - (setf (shape-data *game*) pnts)) +(defun update-game-tiles (shape-data) + (setf (active-tiles-of *game*) + (if shape-data + (progn + (incf (score-of *game*) (* 5 (length shape-data))) + (loop with tmp = (clone-tiles (active-tiles-of *game*)) + for pnt in shape-data do (set-tile tmp pnt 0) + finally (return (collapse-tiles tmp)))) + (original-tiles-of *game*)))) (defun game-level () - (level *game*)) + (lookup-level-reached (score-of *game*))) (defun game-points-needed () - (- (nth (1- (level *game*)) *points-needed-table*) (score *game*))) + (- (nth (1- (game-level)) *points-needed-table*) (score-of *game*))) (defun game-score () - (score *game*)) - -(defun update-panel (panel) - (update-buffer (gfw:dispatcher panel)) - (gfw:redraw panel)) - -(cells:defobserver score ((self unblocked-game-model)) - (update-panel (get-scoreboard-panel))) - -(cells:defobserver active-tiles ((self unblocked-game-model)) - (update-panel (get-tiles-panel))) + (score-of *game*)) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Aug 21 00:36:51 2006 @@ -65,6 +65,10 @@ (kind (shape-kind shape))) (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) +(defun update-panel (panel) + (update-buffer (gfw:dispatcher panel)) + (gfw:redraw panel)) + (defun reveal-unblocked (disp item) (declare (ignore disp item)) (let ((shape (find-shape (game-tiles) #'accept-shape-p))) Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/file-dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/file-dialog.lisp Mon Aug 21 00:36:51 2006 @@ -124,7 +124,7 @@ (title-buffer (cffi:null-pointer)) (dir-buffer (cffi:null-pointer)) (ext-buffer (cffi:null-pointer)) - (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element #\Null))) ; see FIXME above + (file-buffer (cffi:foreign-alloc :char :count 1024 :initial-element 0))) ; see FIXME above (if text (setf title-buffer (collect-foreign-strings (list text)))) (if initial-directory From junrue at common-lisp.net Mon Aug 21 06:49:16 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 21 Aug 2006 02:49:16 -0400 (EDT) Subject: [graphic-forms-cvs] r227 - in trunk: . docs/manual docs/website Message-ID: <20060821064916.1805624002@common-lisp.net> Author: junrue Date: Mon Aug 21 02:49:15 2006 New Revision: 227 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo trunk/docs/website/index.html Log: doc updates in preparation for the 0.5.0 release Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 02:49:15 2006 @@ -1,15 +1,90 @@ +Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI +programming, is now available. This is an alpha release, meaning that +the feature set and API have not yet stabilized. + +Here is what's new in this release: + +. SBCL is now supported (version 0.9.15 tested). Graphic-Forms includes + a small patch provided to the SBCL community by Alastair Bridgewater + to enable the stdcall calling convention for alien callbacks. Please + see src/external-libraries/sbcl-callback-patch + +. Implemented a plugin mechanism for integrating graphics libraries. This + means that ImageMagick is now optional -- if your application can get + by with just BMP and ICO formats, then the default plugin (which has no + external dependencies) may be used. This feature also allows applications + to integrate other graphics libraries of their choice. + +. In addition to ImageMagick now being optional, external library + dependencies have been further simplified. Several small libraries + are now directly bundled with the Graphic-Forms. Cells is no longer + used in the library proper nor in the demos (but may return at a + later point). + +. Implemented a class called icon-bundle which may be populated with + multiple images and then used to set icon data for window frames. + This includes the concept of there being 'large' and 'small' icon + sizes. + +. Simplified the argument lists for the event-*** generic functions. + Provided gfw:obtain-event-time as a substitute for passing a time + argument to every function (for which the vast majority of methods + had no use). + +. Provided a new generic function called event-session so applications + can participate in the WM_QUERYENDSESSION / WM_ENDSESSION protocol. + +. Provided event-activate and event-deactivate generic functions so + applications can respond to window activation state changes. + +. Defined generic functions for querying undo and redo state. Implemented + corresponding methods for edit controls. + +. Defined generic functions for configuring auto-scrolling and scrollbar + visibility. Implemented corresponding methods for edit controls. + +. Defined generic functions representing text clipboard data convenience + functionality. Implemented corresponding methods for edit controls. -. SBCL 0.9.15 is now supported. Graphic-Forms includes a small patch - to enable the stdcall calling convention for alien callbacks, located - in src/external-libraries/sbcl-callback-patch. +. Made other miscellaneous improvements to flesh out edit control + support. -. Implemented a plugin mechanism for integrating graphics libraries. +. Implemented the standard color chooser dialog and associated + convenience macro 'with-color-dialog'. -. Implemented the standard color chooser dialog. +. Added the macro 'with-graphics-context' as a convenience for code that + needs to instantiate a context outside of event-paint. -. Simplified external library dependencies, getting rid of some and - bundling small libraries into the Graphic-Forms distribution. +. Heavily revised internal layout manager code in preparation for + supporting more sophisticated layouts. A new class called layout-managed + has been created to serve as a mix-in when defining objects (not + necessarily only windows) that have children to be sized and positioned. + +. Implemented a new demo program called textedit which is essentially + a Notepad clone. Its purpose is to show off the multi-line edit + control and the standard Find/Replace dialog. + +. Upgraded to the latest lisp-unit and changed test loading code so that + unit-tests are no longer compiled. + +. Wrote more documentation and reorganized existing content a bit. + Added discussion of certain naming convention choices. + +. Made a variety of bug fixes. + +The README.txt file in the release zip file also has additional important +information about this release. + +Download the release zip file here: +http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.5.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +25 August 2006 ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Aug 21 02:49:15 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 +Graphic-Forms README for version 0.5.0 (25 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -10,7 +10,8 @@ Dependencies ------------ -Graphic-Forms depends on the following packages: +Graphic-Forms requires the following libraries which must be downloaded +separately: - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ @@ -19,14 +20,13 @@ - CFFI (cffi-060606 or later) http://common-lisp.net/project/cffi/ - - lw-compat + - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - Closer to MOP + - lw-compat http://common-lisp.net/project/closer/downloads.html -The following libraries are bundled with Graphic-Forms, thus do not need -to be downloaded separately: +The following libraries are bundled with Graphic-Forms: - Practical Common Lisp Chapter08 and Chapter24 http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz @@ -43,8 +43,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 -(the latter with a small patch). +Graphic-Forms currently supports CLISP 2.38 or higher, LispWorks 4.4.6, +and SBCL 0.9.15 (the latter with a small patch). Known Problems @@ -58,103 +58,102 @@ http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1355&atid=101355 - may result in intermittent GPFs when windows with layout managers are - resized. - -2. Image loading currently requires installation of the ImageMagick - library as described in the next section. I have tested with Windows - BMP files (and this is what the image-tester application displays). - ImageMagick itself supports many image formats, but Graphic-Forms - has not been tested with all of them. Therefore, images may not - display properly, expecially when a transparency is selected. - -3. The src/demos/unblocked directory contains a start at a demo - program in the form of a simple game where one clicks on block - shapes to score points, and the rest of the blocks fall down to - fill in the gaps. This demo program is not yet finished, but the - source code can still serve as sample code. - -4. The text-extent generic function currently does not return - the correct text height. As a workaround, get the text metrics - for the desired font and base height calculations on that - value. The text-extent function does return the correct width. - + may result in a GPF if a window's layout manager is changed. Compared + to prior releases of Graphic-Forms, there is much less chance of this + problem affecting layout management. + +2. Please be advised that SBCL is itself still in the early stages of + supporting Windows, and as a consequence, you may experience problems + such as 'GC invariant lost' errors that result in a crash to LDB. + +3. The gfg:text-extent method currently does not return the correct text + height value. As a workaround, get the text metrics for the font and + compute height from that. The gfg:text-extent function does return + the correct width. How To Configure and Build -------------------------- -NOTE: in a future release, this project will be packaged for use -with asdf-install. +NOTE: in a future release, this project will be packaged for delivery +via asdf-install. -1. Install ImageMagick 6.2.6.5-Q16 (note in particular that it is the Q16 - version that is needed, not the Q8 version). The default installation - directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". +1. [OPTIONAL] Install ImageMagick 6.2.6.5-Q16 (note in particular that it + is the Q16 version that is needed, not the Q8 version). The default + installation directory is "c:/Program Files/ImageMagick-6.2.6-Q16/". 2. Extract the Graphic-Forms distribution archive somewhere on your machine (or check out the source from Subversion). 3. Change to the Graphic-Forms top-level directory. -4. Load ASDF into your Lisp image if it is not already present. +4. Load ASDF into your Lisp image if it is not already present. Note that + SBCL bundles ASDF, so in this case you just need to (require 'asdf) -5. Execute the following forms from your REPL - - (load "config.lisp") +5. Execute the following forms at your REPL ;; - ;; If ImageMagick is not installed in the default location, execute: + ;; If you need the ImageMagick plugin, execute: + + (push :load-imagemagick-plugin *features*) + (setf cl-user::*magick-library-directory* "c:/path/to/ImageMagick/") + + ;; ... the latter being necessary only if ImageMagick is not installed + ;; in the default location. + ;; - (setf cl-user::*magick-library-directory* "c:/path/to/your/ImageMagick/install/") + ;; Next, execute: - ;; setf these variables as needed for your specific environment to + (load "config.lisp") + + ;; + ;; Set these variables as needed for your specific environment to ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* ;; gfsys::*lw-compat-dir* - ;; - ;; Set the following var only if you want to run the unit-tests. - ;; Its value is the path to the lisp-unit.lisp source file minus - ;; the file extension. - ;; - ;; gfsys::*lisp-unit-file* + ;; ;; Execute the following form to populate asdf:*central-registry* ;; Note that it will skip any systems whose location variables were ;; set to nil in the previous step. - ;; + (gfsys::configure-asdf) - ;; Now load the graphic-forms system and its dependencies. ;; + ;; Now load the graphic-forms system and its dependencies. + (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit) 6. You may optionally compile the reference manual. GNU Make and - makeinfo are prerequisites. Assuming you already have those - components installed, the reference manual can be built by - opening a command prompt and cd'ing to the `docs\manual' + makeinfo (version 4.8) are prerequisites. Assuming you already + have those components installed, the reference manual can be + built by opening a command prompt and cd'ing to the `docs\manual' subdirectory, then typing `make'. The output will be - produced within a subdirectory called `reference'. + deposited in a subdirectory called `reference'. 7. Proceed to the next section to run the tests, or start coding! -How To Run Tests And Samples ----------------------------- +How To Run Tests And Demos +-------------------------- 1. Load the graphic-forms-uitoolkit system as described in the previous section. 2. Execute the following forms from your REPL: - (load (compile-file gfsys::*lisp-unit-file*)) + ;; + ;; configure ASDF for the test programs and then load it - (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load "tests.lisp") + (gfsys::load-tests) - ;; execute demos and test programs ;; + ;; execute demos and test programs + (gft:unblocked) (gft:textedit) @@ -169,14 +168,15 @@ (gft:windlg) - ;; execute the unit-tests ;; + ;; execute the unit-tests + (in-package :gft) (run-tests) -Support and Feedback --------------------- +Feedback and Bug Reports +------------------------ Please provide feedback via the following channels: Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Mon Aug 21 02:49:15 2006 @@ -14,19 +14,18 @@ focusing on the Windows platform. Graphic-Forms is licensed under the terms of the BSD License. -The goal is to provide a Lisp-based toolkit for developing GUI -applications on Windows. Platform-specific features are encapsulated -by a thin abstraction layer that presents a more Lisp-friendly -interface for programmers. The library can be extended by using the -Lisp bindings for system APIs, rather than requiring knowledge of -some other programming language. +The goal is to provide a Common Lisp-based toolkit for developing GUI +applications on Windows. GUI features are encapsulated by a thin +abstraction layer offering a Lisp-friendly interface. The library can +be extended via Common Lisp bindings for system APIs, avoiding a +prerequisite for coding ability in a non-Lisp programming language. Why implement another UI toolkit? Applications that need portability -across windowing systems are already served by projects such as McCLIM -or LTK or wxCL in the open-source world, or the toolkits provided by -commercial vendors. The audience served by Graphic-Forms consists of +across windowing systems are served today by projects such as +LTK or wxCL in the open-source world, or the toolkits provided by +commercial vendors. The target audience of Graphic-Forms consists of GUI developers focused on the Windows platform who want to leverage -platform features without compromises due to portability. +platform-specific features. Long-term goals for this project may include implementing an application framework on top of the toolkit, or a rapid UI development language, or Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Aug 21 02:49:15 2006 @@ -30,46 +30,47 @@ terms of the BSD License.

-

The goal is to provide a Lisp-based toolkit for developing GUI - applications on Windows. Platform-specific features are encapsulated - by a thin abstraction layer that presents a more Lisp-friendly interface - for programmers. The library can be extended by using the Lisp - bindings for system APIs, rather than requiring knowledge of some other - programming language.

-

Why implement another UI toolkit? Applications that need portability - across windowing systems are already served by projects such as - McCLIM - or +

The goal is to provide a Common Lisp-based + toolkit for developing GUI applications on Windows. GUI features + are encapsulated by a thin abstraction layer offering a Lisp-friendly + interface. The library can be extended via + Common Lisp bindings for system APIs, + avoiding a prerequisite for coding ability in a non-Lisp programming + language.

+

Why implement another UI toolkit? Applications requiring portability + across windowing systems are served today by projects such as LTK or wxCL in the open-source world, or the toolkits provided by commercial - vendors. The audience served by Graphic-Forms consists of GUI + vendors. The target audience of Graphic-Forms consists of GUI developers focused on the Windows platform who want to leverage - platform features without compromises due to portability. + platform-specific features.

Long-term goals for this project may include implementing an application framework on top of the toolkit, or a rapid UI development language, or a UI design tool, or some combination thereof.

Status

-

The current release is - version 0.4.0. - This library is in the alpha stage of development, which means that new - features are still being added and existing features require considerable - testing. Brave souls who experiment with the code should expect significant - API and behavior changes for at least several more releases.

+

The current version is + + 0.5.0, released on 25 August 2006.

+

Graphic-Forms is in the alpha stage of development, + meaning new features are still being added and existing features require + considerable testing. Brave souls who experiment with the code should expect + significant API and behavior changes for at least several more releases.

The supported Lisp implementations are:

The supported Windows versions are:

  • XP SP2
    • -
  • Vista (in progress, testing on Beta 2 currently underway)
    • +
  • Vista (testing on Beta 2 currently underway)

Mailing Lists

From junrue at common-lisp.net Mon Aug 21 16:51:49 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 21 Aug 2006 12:51:49 -0400 (EDT) Subject: [graphic-forms-cvs] r228 - in trunk: . src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060821165149.71CB115@common-lisp.net> Author: junrue Date: Mon Aug 21 12:51:48 2006 New Revision: 228 Modified: trunk/NEWS.txt trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: reviewed and fixed macro definitions Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Aug 21 12:51:48 2006 @@ -32,20 +32,22 @@ argument to every function (for which the vast majority of methods had no use). -. Provided a new generic function called event-session so applications - can participate in the WM_QUERYENDSESSION / WM_ENDSESSION protocol. +. Defined the following new generic functions: -. Provided event-activate and event-deactivate generic functions so - applications can respond to window activation state changes. + * event-session GF so applications can participate in the + WM_QUERYENDSESSION / WM_ENDSESSION protocol. -. Defined generic functions for querying undo and redo state. Implemented - corresponding methods for edit controls. + * event-activate and event-deactivate GFs so applications can respond + to window activation state changes. -. Defined generic functions for configuring auto-scrolling and scrollbar - visibility. Implemented corresponding methods for edit controls. + * GFs for querying undo and redo state. Implemented corresponding + methods for edit controls. -. Defined generic functions representing text clipboard data convenience - functionality. Implemented corresponding methods for edit controls. + * GFs for configuring auto-scrolling and scrollbar visibility. Implemented + corresponding methods for edit controls. + + * GFs representing text clipboard data convenience functionality. + Implemented corresponding methods for edit controls. . Made other miscellaneous improvements to flesh out edit control support. Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Mon Aug 21 12:51:48 2006 @@ -35,19 +35,21 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro color->rgb (color) - (let ((result (gensym))) - `(let ((,result 0)) - (setf (ldb (byte 8 0) ,result) (color-red ,color)) - (setf (ldb (byte 8 8) ,result) (color-green ,color)) - (setf (ldb (byte 8 16) ,result) (color-blue ,color)) + (let ((tmp-color (gensym)) + (result (gensym))) + `(let ((,tmp-color ,color) + (,result 0)) + (setf (ldb (byte 8 0) ,result) (color-red ,tmp-color)) + (setf (ldb (byte 8 8) ,result) (color-green ,tmp-color)) + (setf (ldb (byte 8 16) ,result) (color-blue ,tmp-color)) ,result))) (defmacro rgb->color (colorref) - (let ((color (gensym))) - `(let ((,color (make-color :red (ldb (byte 8 0) ,colorref) - :green (ldb (byte 8 8) ,colorref) - :blue (ldb (byte 8 16) ,colorref)))) - ,color)))) + (let ((tmp-colorref (gensym))) + `(let ((,tmp-colorref ,colorref)) + (make-color :red (ldb (byte 8 0) ,tmp-colorref) + :green (ldb (byte 8 8) ,tmp-colorref) + :blue (ldb (byte 8 16) ,tmp-colorref)))))) (defvar *color-black* (make-color :red 0 :green 0 :blue 0)) (defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) @@ -57,4 +59,4 @@ (defmethod print-object ((obj color) stream) (print-unreadable-object (obj stream :type t) - (format stream "~a,~a,~a" (color-red obj) (color-green obj) (color-blue obj)))) + (format stream "(~a,~a,~a)" (color-red obj) (color-green obj) (color-blue obj)))) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Aug 21 12:51:48 2006 @@ -62,8 +62,10 @@ `(gfg::font-metrics-leading ,metrics)) (defmacro height (metrics) - `(+ (gfg::font-metrics-ascent ,metrics) - (gfg::font-metrics-descent ,metrics))) + (let ((tmp-metrics (gensym))) + `(let ((,tmp-metrics ,metrics)) + (+ (gfg::font-metrics-ascent ,tmp-metrics) + (gfg::font-metrics-descent ,tmp-metrics))))) (defmacro average-char-width (metrics) `(gfg::font-metrics-avg-char-width ,metrics)) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Aug 21 12:51:48 2006 @@ -38,13 +38,15 @@ ;;; (defmacro with-image-transparency ((image pnt) &body body) - (let ((orig-pnt (gensym))) - `(let ((,orig-pnt (transparency-pixel-of ,image))) + (let ((tmp-image (gensym)) + (orig-pnt (gensym))) + `(let* ((,tmp-image ,image) + (,orig-pnt (transparency-pixel-of ,tmp-image))) (unwind-protect (progn - (setf (transparency-pixel-of ,image) ,pnt) + (setf (transparency-pixel-of ,tmp-image) ,pnt) , at body) - (setf (transparency-pixel-of ,image) ,orig-pnt))))) + (setf (transparency-pixel-of ,tmp-image) ,orig-pnt))))) (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Aug 21 12:51:48 2006 @@ -50,9 +50,10 @@ `(loop for ,i from 0 below (foreign-type-size (quote ,type)) do (setf (mem-aref ,object :char ,i) 0)))) -#+lispworks (defun native-object-special-action (obj) - (if (typep obj 'gfs:native-object) - (gfs:dispose obj))) +#+lispworks +(defun native-object-special-action (obj) + (if (typep obj 'gfs:native-object) + (gfs:dispose obj))) ;;; ;;; convenience macros Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Aug 21 12:51:48 2006 @@ -37,29 +37,33 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-graphics-context ((gc &optional thing) &body body) - `(let ((,gc (cond - ((null ,thing) - (make-instance 'gfg:graphics-context)) ; DC compatible with display - ((typep ,thing 'gfw:widget) - (make-instance 'gfg:graphics-context :widget ,thing)) - ((typep ,thing 'gfg:image) - (make-instance 'gfg:graphics-context :image ,thing)) - (t - (error 'gfs:toolkit-error - :detail (format nil "~a is an unsupported type" ,thing)))))) - (unwind-protect - (progn - , at body) - (gfs:dispose ,gc)))) + (let ((tmp-thing (gensym))) + `(let* ((,tmp-thing ,thing) + (,gc (cond + ((null ,tmp-thing) + (make-instance 'gfg:graphics-context)) ; DC compatible with display + ((typep ,tmp-thing 'gfw:widget) + (make-instance 'gfg:graphics-context :widget ,tmp-thing)) + ((typep ,tmp-thing 'gfg:image) + (make-instance 'gfg:graphics-context :image ,tmp-thing)) + (t + (error 'gfs:toolkit-error + :detail (format nil "~a is an unsupported type" ,tmp-thing)))))) + (unwind-protect + (progn + , at body) + (gfs:dispose ,gc))))) (defmacro with-drawing-disabled ((widget) &body body) - `(unwind-protect - (progn - (unless (gfs:disposed-p ,widget) - (error 'gfs:disposed-error)) - (gfs::lock-window-update (gfs:handle ,widget)) - , at body) - (gfs::lock-window-update (cffi:null-pointer))))) + (let ((tmp-widget (gensym))) + `(let ((,tmp-widget ,widget)) + (unwind-protect + (progn + (unless (gfs:disposed-p ,tmp-widget) + (error 'gfs:disposed-error)) + (gfs::lock-window-update (gfs:handle ,tmp-widget)) + , at body) + (gfs::lock-window-update (cffi:null-pointer))))))) (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr) From junrue at common-lisp.net Mon Aug 21 21:23:24 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 21 Aug 2006 17:23:24 -0400 (EDT) Subject: [graphic-forms-cvs] r229 - in trunk/src: . uitoolkit/graphics uitoolkit/graphics/plugins/default uitoolkit/graphics/plugins/imagemagick Message-ID: <20060821212324.D4E4617046@common-lisp.net> Author: junrue Date: Mon Aug 21 17:23:22 2006 New Revision: 229 Modified: trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Log: refactored graphics plugins slightly for common code Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Aug 21 17:23:22 2006 @@ -151,7 +151,7 @@ #:copy-color #:copy-font-data #:copy-font-metrics - #:data->image + #:copy-pixels #:data-object #:depth #:descent Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Aug 21 17:23:22 2006 @@ -39,9 +39,6 @@ (defgeneric (setf background-color) (color self) (:documentation "Sets the current background color.")) -(defgeneric data->image (self) - (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ.")) - (defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of self.")) @@ -132,6 +129,9 @@ (defgeneric metrics (self font) (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) +(defgeneric obtain-pixels (self pixels-pointer) + (:documentation "Plugins implement this to populate pixels-pointer with image pixel data.")) + (defgeneric size (self) (:documentation "Returns a size object describing the dimensions of self.")) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Mon Aug 21 17:23:22 2006 @@ -166,7 +166,7 @@ ((typep file 'pathname) (let ((data (load-image-data file))) (setf image-list (loop for entry in data - collect (make-instance 'gfg:image :handle (data->image entry)))))) + collect (make-instance 'gfg:image :handle (plugin->image entry)))))) ((listp images) (setf image-list images))) (when image-list Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Aug 21 17:23:22 2006 @@ -78,12 +78,47 @@ ;;; helper functions ;;; +(defun make-initial-bitmapinfo (plugin) + (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) + (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount + gfs::bicompression gfs::bmicolors) + bi-ptr gfs::bitmapinfo) + (gfs::zero-mem bi-ptr gfs::bitmapinfo) + (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) + gfs::biplanes 1 + gfs::bibitcount (depth plugin) + gfs::bicompression gfs::+bi-rgb+) + (let ((im-size (size plugin))) + (setf gfs::biwidth (gfs:size-width im-size) + gfs::biheight (- (gfs:size-height im-size))))) + bi-ptr)) + (defun load-image-data (path) (loop for loader in *image-plugins* for data = (funcall loader path) until data finally (return data))) +(defun plugin->image (plugin) + (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) + (hbmp (cffi:null-pointer))) + (unwind-protect + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + plugin + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfs:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) + (copy-pixels plugin (cffi:mem-ref pix-bits-ptr :pointer))) + (gfs::release-dc (cffi:null-pointer) screen-dc)) + hbmp)) + +(defun data->image (self) + (plugin->image (data-plugin-of self))) + (defun image->data (hbmp) (declare (ignore hbmp))) #| (defun image->data (hbmp) @@ -175,9 +210,6 @@ ;;; methods ;;; -(defmethod data->image ((self image-data)) - (data->image (data-plugin-of self))) - (defmethod depth ((self image-data)) (depth (data-plugin-of self))) @@ -208,7 +240,7 @@ (size (data-plugin-of self))) (defmethod (setf size) (size (self image-data)) - (setf (gfg:size (data-plugin-of self)) size)) + (setf (size (data-plugin-of self)) size)) (defmethod print-object ((self image-data) stream) (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle self))) Modified: trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp Mon Aug 21 17:23:22 2006 @@ -114,26 +114,6 @@ (push #'loader gfg::*image-plugins*) -(defmethod gfg:data->image ((self default-data-plugin)) - (let ((screen-dc (gfs::get-dc (cffi:null-pointer))) - (hbmp (cffi:null-pointer))) - (unwind-protect - (cffi:with-foreign-object (pix-bits-ptr :pointer) - (setf hbmp (gfs::create-dib-section screen-dc - self - gfs::+dib-rgb-colors+ - pix-bits-ptr - (cffi:null-pointer) - 0)) - (if (gfs:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-dib-section failed")) - (let ((plugin-pixels (pixels-of self)) - (ptr (cffi:mem-ref pix-bits-ptr :pointer))) - (dotimes (i (length plugin-pixels)) - (setf (cffi:mem-aref ptr :uint8 i) (aref plugin-pixels i))))) - (gfs::release-dc (cffi:null-pointer) screen-dc)) - hbmp)) - (defmethod gfg:depth ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info @@ -143,59 +123,42 @@ (defmethod gfs:dispose ((self default-data-plugin)) (setf (slot-value self 'gfs:handle) nil)) -(defmethod cffi:free-translated-object (pixels-ptr (name (eql 'gfs::bitmap-pixels-pointer)) param) - (declare (ignore param)) - (cffi:foreign-free pixels-ptr)) - (defmethod cffi:free-translated-object (bi-ptr (name (eql 'gfs::bitmap-info-pointer)) param) (declare (ignore param)) (cffi:foreign-free bi-ptr)) +(defmethod gfg:copy-pixels ((self default-data-plugin) pixels-pointer) + (let ((plugin-pixels (pixels-of self))) + (dotimes (i (length plugin-pixels)) + (setf (cffi:mem-aref pixels-pointer :uint8 i) (aref plugin-pixels i)))) + pixels-pointer) + (defmethod gfg:size ((self default-data-plugin)) (let ((info (gfs:handle self))) (unless info (error 'gfs:disposed-error)) - (gfs:make-size :width (biWidth info) :height (biHeight info)))) + (gfs:make-size :width (biWidth info) :height (- (biHeight info))))) (defmethod (setf gfg:size) (size (self default-data-plugin)) (let ((info (gfs:handle self))) (unless info (error 'gfs:disposed-error)) (setf (biWidth info) (gfs:size-width size) - (biHeight info) (gfs:size-height size))) + (biHeight info) (- (gfs:size-height size)))) size) (defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) - (name (eql 'gfs::bitmap-pixels-pointer))) - (let* ((plugin-pixels (pixels-of lisp-obj)) - (pixels-ptr (cffi:foreign-alloc :uint8 :count (length plugin-pixels)))) - (dotimes (i (length plugin-pixels)) - (setf (cffi:mem-aref pixels-ptr :uint8 i) (aref plugin-pixels i))) - pixels-ptr)) - -(defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin) (name (eql 'gfs::bitmapinfo-pointer))) - (let ((bi-ptr (cffi:foreign-alloc 'gfs::bitmapinfo))) - (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes gfs::bibitcount - gfs::bicompression gfs::bmicolors) - bi-ptr gfs::bitmapinfo) - (gfs::zero-mem bi-ptr gfs::bitmapinfo) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biplanes 1 - gfs::bibitcount (gfg:depth lisp-obj) - gfs::bicompression gfs::+bi-rgb+) - (let ((im-size (gfg:size lisp-obj))) - (setf gfs::biwidth (gfs:size-width im-size) - gfs::biheight (gfs:size-height im-size))) - (let ((colors (gfg:color-table (palette-of lisp-obj))) - (ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) - (dotimes (i (length colors)) - (let ((clr (aref colors i))) - (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen - gfs::rgbred gfs::rgbreserved) - (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) - (setf gfs::rgbblue (gfg:color-blue clr) - gfs::rgbgreen (gfg:color-green clr) - gfs::rgbred (gfg:color-red clr) - gfs::rgbreserved 0)))))) + (let ((bi-ptr (gfg::make-initial-bitmapinfo lisp-obj)) + (colors (gfg:color-table (palette-of lisp-obj)))) + (let ((ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors))) + (dotimes (i (length colors)) + (let ((clr (aref colors i))) + (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen + gfs::rgbred gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0 + gfs::rgbblue (gfg:color-blue clr) + gfs::rgbgreen (gfg:color-green clr) + gfs::rgbred (gfg:color-red clr)))))) bi-ptr)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Aug 21 17:23:22 2006 @@ -136,6 +136,11 @@ (width :unsigned-long) (height :unsigned-long)) +(defcfun + ("GetIndexes" get-indexes) + :pointer ;; IndexPacket* + (image :pointer)) ;; Image* + (defun scale-quantum-to-byte (quant) (floor quant 257)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp Mon Aug 21 17:23:22 2006 @@ -63,6 +63,8 @@ (defctype quantum :unsigned-short) +(defctype index-packet quantum) + (defcenum boolean-type (:false 0) (:true 1)) Modified: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp (original) +++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Aug 21 17:23:22 2006 @@ -54,73 +54,16 @@ (push #'loader gfg::*image-plugins*) -(defmethod gfg:data->image ((self magick-data-plugin)) - (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo) - (cffi:with-foreign-slots ((gfs::bisize - gfs::biwidth - gfs::biheight - gfs::biplanes - gfs::bibitcount - gfs::bicompression - gfs::bisizeimage - gfs::bixpels - gfs::biypels - gfs::biclrused - gfs::biclrimp - gfs::bmicolors) - bi-ptr gfs::bitmapinfo) - (let* ((handle (gfs:handle self)) - (sz (gfg:size self)) - (pix-count (* (gfs:size-width sz) (gfs:size-height sz))) - (hbmp (cffi:null-pointer)) - (screen-dc (gfs::get-dc (cffi:null-pointer)))) - (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader) - gfs::biwidth (gfs:size-width sz) - gfs::biheight (- 0 (gfs:size-height sz)) - gfs::biplanes 1 - gfs::bibitcount 32 ;; 32bpp even if original image file is not - gfs::bicompression gfs::+bi-rgb+ - gfs::bisizeimage 0 - gfs::bixpels 0 - gfs::biypels 0 - gfs::biclrused 0 - gfs::biclrimp 0) - - ;; create the bitmap - ;; - (cffi:with-foreign-object (pix-bits-ptr :pointer) - (setf hbmp (gfs::create-dib-section screen-dc - bi-ptr - gfs::+dib-rgb-colors+ - pix-bits-ptr - (cffi:null-pointer) - 0)) - (if (gfs:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-dib-section failed")) - - ;; update the RGBQUADs - ;; - (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz))) - (ptr (cffi:mem-ref pix-bits-ptr :pointer))) - (dotimes (i pix-count) - (cffi:with-foreign-slots ((blue green red reserved) - (cffi:mem-aref tmp 'pixel-packet i) - pixel-packet) - (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) - (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) - (setf gfs::rgbreserved 0) - (setf gfs::rgbred (scale-quantum-to-byte red)) - (setf gfs::rgbgreen (scale-quantum-to-byte green)) - (setf gfs::rgbblue (scale-quantum-to-byte blue))))))) - (unless (gfs:null-handle-p screen-dc) - (gfs::release-dc (cffi:null-pointer) screen-dc)) - hbmp)))) - (defmethod gfg:depth ((self magick-data-plugin)) + ;; FIXME: further debugging of non-true-color format required throughout + ;; this plugin, reverting back to assumption of 32bpp for now. +#| (let ((handle (gfs:handle self))) (if (null handle) (error 'gfs:disposed-error)) (cffi:foreign-slot-value handle 'magick-image 'depth))) +|# + 32) (defmethod gfs:dispose ((self magick-data-plugin)) (let ((victim (gfs:handle self))) @@ -128,6 +71,22 @@ (destroy-image victim))) (setf (slot-value self 'gfs:handle) nil)) +(defmethod gfg:copy-pixels ((self magick-data-plugin) pixels-pointer) + (let* ((handle (gfs:handle self)) + (im-size (gfg:size self)) + (pixel-count (* (gfs:size-width im-size) (gfs:size-height im-size))) + (pix-tmp (get-image-pixels handle 0 0 (gfs:size-width im-size) (gfs:size-height im-size)))) + (dotimes (i pixel-count) + (cffi:with-foreign-slots ((blue green red reserved) + (cffi:mem-aref pix-tmp 'pixel-packet i) pixel-packet) + (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) + (cffi:mem-aref pixels-pointer 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0 + gfs::rgbred (scale-quantum-to-byte red) + gfs::rgbgreen (scale-quantum-to-byte green) + gfs::rgbblue (scale-quantum-to-byte blue)))))) + pixels-pointer) + (defmethod gfg:size ((self magick-data-plugin)) (let ((handle (gfs:handle self)) (size (gfs:make-size))) @@ -161,3 +120,9 @@ (destroy-image handle)) (destroy-exception-info ex))) size) + +(defmethod cffi:translate-to-foreign ((lisp-obj magick-data-plugin) + (name (eql 'gfs::bitmapinfo-pointer))) + ;; FIXME: assume true-color for now + ;; + (gfg::make-initial-bitmapinfo lisp-obj)) From junrue at common-lisp.net Tue Aug 22 06:42:17 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 02:42:17 -0400 (EDT) Subject: [graphic-forms-cvs] r230 - trunk/docs/manual Message-ID: <20060822064217.E0325671AB@common-lisp.net> Author: junrue Date: Tue Aug 22 02:42:16 2006 New Revision: 230 Added: trunk/docs/manual/image-plugins.texinfo trunk/docs/manual/terminology.texinfo Modified: trunk/docs/manual/glossary.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/miscellaneous.texinfo Log: documented the image plugin mechanism Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Tue Aug 22 02:42:16 2006 @@ -10,7 +10,8 @@ @node Glossary @chapter Glossary -Terms and definitions. Content will be added in due time. +This chapter defines fundamental terms encountered throughout +the documentation of Graphic-Forms. @table @samp @@ -18,44 +19,65 @@ @anchor{accelerator} @cindex accelerator An accelerator is a key sequence assigned to an application function -that allows a user to bypass navigation of the menu or control +allowing a user to bypass navigation of the menu or control hierarchy normally required to invoke the function. Some accelerators are established by Windows style guidelines, such as @sc{control-c} for the clipboard copy operation from an Edit menu. Applications may define other accelerators as appropriate. Accelerators are generally intended for more knowledgeable users and should not be the sole -mechanism for invoking functionality. Compare with @ref{mnemonic}. +mechanism for invoking functionality. Compare with @ref{mnemonic}.@* @item auto-scrolling @cindex auto-scrolling Auto-scrolling is a feature whereby scrolling occurs as a side effect of user input so content can remain visible, thus avoiding the need to explicitly manipulate scrollbars to -achieve the same result. +achieve the same result.@* @item control @cindex control -A control is a system-defined window class that accepts user input -and/or generates notification events. +A control is a system-defined window class whose role is to +accept user input and possibly generate notification events +based on such input.@* @item dialog @cindex dialog A dialog is a mechanism for collecting user input or showing information. The system defines common dialogs for tasks like choosing files, fonts, or colors. Custom dialogs can be defined -by application code. +by application code.@* + + at item extension + at anchor{extension} + at cindex extension +An extension is code providing additional functionality beyond the +original scope of a system. An extension framework encourages +modularity. More importantly, it is a conscious design choice to allow +a system to be stretched beyond what the original designers may have +anticipated. Compare with @ref{plugin}.@* @item menu @cindex menu -A collection of menu items. +A collection of menu items presented within a single rectangular +region. Menus are often anchored to a menu bar, but may also be +invoked in a context-sensitive manner via the mouse or an + at ref{accelerator}.@* @item mnemonic @anchor{mnemonic} @cindex mnemonic A mnemonic is a key sequence (usually a single character modified by -the @sc{alt} key) that enables mouse-free navigation of a menu or +the @sc{alt} key) enabling mouse-free navigation of a menu or control hierarchy to invoke an application function. Depending on the user's system settings, mnemonic characters may be hidden until -the user presses the @sc{alt} key. Compare with @ref{accelerator}. +the user presses the @sc{alt} key. Compare with @ref{accelerator}.@* + + at item plugin + at anchor{plugin} + at cindex plugin +A plugin is code integrated into a larger system in order to implement +a specific instance of an established category of services. A plugin +framework encourages modularity within a defined scope of +functionality. Compare with @ref{extension}.@* @end table Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Tue Aug 22 02:42:16 2006 @@ -220,8 +220,9 @@ order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the proper transparency @ref{color}; or else by default, the pixel -color at @code{(0, 0)} in each image will be used. @emph{FIXME: -link to documentation of graphics plugins here}. +color at @code{(0, 0)} in each image will be used. See + at ref{Image data plugins} for more information on how image +files are loaded. @end deffn @deffn Initarg :images This initarg accepts a @sc{cl:list} of image objects. Since @@ -263,8 +264,8 @@ This subclass of @ref{native-object} wraps a Win32 bitmap handle. Instances may be drawn using @ref{draw-image} or displayed within certain @ref{control}s such as a @ref{label}. Images may originate -from a variety of formats. @emph{FIXME: link to documentation -of graphics plugins here}. +from a variety of formats -- see @ref{Image data plugins} for +more information on how file formats are loaded. @table @var @anchor{transparency-pixel} @item transparency-pixel @@ -288,8 +289,9 @@ may be loaded (via the @ref{load} method) and then converted to an @ref{image} object by the @ref{data-object} @sc{setf} function.@*@* @code{image-data} serves as an integration point between Graphic-Forms -and third-party graphics libraries such as ImageMagick. @emph{FIXME: -link to documentation of graphics plugins here}. +and third-party graphics libraries such as ImageMagick -- see + at ref{Image data plugins} for more information on supporting other +representations. @table @var @item data-plugin This slot holds a subclass of @ref{image-data-plugin} encapsulating @@ -302,9 +304,10 @@ @anchor{image-data-plugin} @deftp Class image-data-plugin This is a base class for plugin objects that encapsulate third-party -library representations of images. @emph{FIXME: -link to documentation of graphics plugins here}. It derives from - at ref{native-object}. +library representations of images. See @ref{Image data plugins} for +more information on the role of this class. + +This class derives from @ref{native-object}. @end deftp Added: trunk/docs/manual/image-plugins.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/image-plugins.texinfo Tue Aug 22 02:42:16 2006 @@ -0,0 +1,118 @@ + + at c This file is part of the documentation source for + at c the Graphic-Forms library. + at c + at c Copyright (c) 2006, Jack D. Unrue + + at node Image data plugins + at section Image data plugins + +This section documents the image data plugin system. + + + at subsection Rationale + +An important feature of a user interface library is the display of +graphical images, which are aggregates of pixel data and color +information. The Windows @sc{gdi} provides adequate +support at footnote{Nowadays, the Windows platform offers alternatives, +such as @sc{gdi+} which adds among other features native support for +additional image formats. Graphic-Forms sticks with plain-old @sc{gdi} +to avoid the possibility of these alternatives not being installed.} +for the basic tasks of creating system objects populated with image +data, drawing on them, rendering them on the screen, and querying +their attributes. Central to the @sc{gdi} concept of an image is the + at emph{bitmap}. This format has a long history which becomes evident as +one learns about features designed at a time when memory and CPU +performance were markedly constrained compared to today's +machines. For our purposes, the @sc{gdi} bitmap serves as a normalized +representation of image data. Graphic-Forms encapsulates @sc{gdi} +bitmap functionality via the @ref{graphics-context} and @ref{image} +classes, plus related functions and macros. + +A traditional Windows application embeds bitmap data within its binary +executable (or @sc{dll}) via the Windows resource compiler. Such an +application then uses Win32 @sc{api} calls to access the resource +data and instantiate bitmap objects. Windows applications may also +choose to store image data in other locations, such as within files on +disk. Graphic-Forms relies on this latter arrangement instead of +the resource infrastructure. at footnote{As do GUI bindings in other +languages such as Java.} + +There are many image formats in use today. Whether images are stored +as @sc{gif}, @sc{jpeg}, @sc{png}, @sc{bmp}, or some other format, +there must be code to read the file data and convert it into a + at sc{gdi} bitmap format for use with drawing operations. This is the +problem solved by the image data plugin mechanism in Graphic-Forms. +It is solved in a manner insulating format-independent code in the +main library from format-specific details, and in a manner allowing +applications to provide their own code to do likewise. + + + at subsection Image file loading + +When an image file is to be loaded, such as when a @sc{pathname} is +supplied to the @code{:file} keyword for the @ref{image} or + at ref{icon-bundle} classes, the library traverses a list of file loader +functions bound to the @code{gfg::*image-plugins*} variable -- + at code{funcall}'ing each one in turn until one of them returns a +non- at sc{nil} list, or the members of @code{gfg::*image-plugins*} is +exhausted. In the latter case, a @ref{toolkit-error} is raised to +notify application code that no registered plugin supports the file. + +Under normal circumstances, the library will manage the list bound to + at code{gfg::*image-plugins*} behind the scenes. However, applications +requiring precise control over loader function calling order may +directly modify @code{gfg::*image-plugins*} @emph{but must take care +to do so properly}. Improper modifications, such as accidentally +assigning some other data structure, or adding the wrong kind of +object, will result in program errors. + + + at subsection Plugins bundled with the library + +Graphic-Forms includes two plugins in the distribution. + +The @emph{Default} plugin is available to applications unless the + at code{:skip-default-plugin} keyword symbol is pushed onto + at code{*features*} prior to loading the system. This plugin implements +support for the @sc{bmp} and @sc{ico} formats directly in Common Lisp, +thus imposing no additional external dependencies on applications. + +The @emph{ImageMagick} plugin is loaded when the + at code{:load-imagemagick-plugin} keyword symbol is pushed onto + at code{*features*} prior to loading the system. Thanks to the +ImageMagick library, this plugin supports most of the image formats +one might expect to need. However, it requires additional preparation +compared to the @emph{Default} plugin. Developers must download the +ImageMagick Q16 distribution and install it. at footnote{See the main +ImageMagick website at @url{http://imagemagick.org} for downloads and +documentation.} When delivering applications, the developer must +execute the ImageMagick installation process, or else replicate the +expected directory structure and registry entries. Also, bear in mind +that due to the rich functionality offered by ImageMagick, +applications will pull in additional @sc{dll}s and may have larger +memory requirements. + + + at subsection Implementing additional plugins + + at strong{FIXME:} @emph{add more info to this subsection once the plugin +system has matured a bit.} + +As described in the rationale, the role of an image data plugin is to +translate an external library representation of image data. In a +nutshell, this is accomplished by subclassing @ref{image-data-plugin} +and implementing certain generic functions. Third parties may +implement and register additional plugins in an identical fashion. + +As a convenience, the symbol @code{gfg::*image-file-types*} is bound +to an @sc{alist} where the first of each pair is a string naming a +file extension, and the second of each pair is a string supplying a +brief description of the format. Plugin developers may retrieve these +pairs to avoid duplication of the same information in their own code. + +Developers are welcome to inspect the source code of bundled plugins +(located under @code{src/uitoolkit/graphics/plugins} in the +distribution) for additional hints as to how these plugins may be +implemented. Modified: trunk/docs/manual/miscellaneous.texinfo ============================================================================== --- trunk/docs/manual/miscellaneous.texinfo (original) +++ trunk/docs/manual/miscellaneous.texinfo Tue Aug 22 02:42:16 2006 @@ -11,77 +11,9 @@ @chapter Miscellaneous Topics @menu -* terminology:: Some notes about terminology conventions. +* Image data plugins:: Documentation of the image data plugin system. +* Terminology conventions:: Some notes about terminology conventions. @end menu - - at node terminology - at section terminology - -This chapter documents terminology conventions observed in -Graphic-Forms. These conventions should be interpreted with the -traditional Common Lisp conventions in mind (some of which are -documented here: @url{http://www.cliki.net/Naming%20conventions}). - - at table @option - - at item accessor names -For clearer identification of accessors, Graphic-Forms -uses the suffix @samp{-of} whenever possible. - - at item @samp{check} versus @samp{select} -Admittedly, these two concepts are similar. They can be used as verbs -and they both describe a state of being (@samp{checked} and - at samp{selected}). Yet they need to remain separate due to the fact -that certain @ref{widget}s can exist in both states simultaneously, -like a tri-state @ref{button}, or a table or tree whose items are -checkboxes. The choice of which best describes an action or state -amounts to a judgement call. In Graphic-Forms, the author chooses to -use @samp{select} when a user gesture causes a widget to issue its -primary notification event, such as a menu item or button being -clicked. Hence, the verb @samp{select} aligns with the - at ref{event-select} function. at footnote{This topic gets muddier when -edit controls come into the picture. Text in an edit control is -selected despite there being no notification event; yet there is a -notification (event-modify) then the user types text. I'm choosing to -live with this inconsistency, partly because otherwise my -categorization scheme seems to work well; and one can refer to the act -of retrieving edit control selection, confident that developers will -know this means obtaining highlighted text.} And so the - at samp{selection} state is associated with highlighting of an - at ref{item}. Graphic-Forms uses @samp{check} to identify an operation -that flags or annotates a widget; the @samp{checked} state means being -annotated. - - at c @item @samp{clear} versus @samp{delete} - at c There is a distinction between @samp{clear} and @samp{delete} which - at c hinges on the difference between the primary content of a @ref{widget} - at c and secondary state information. An example of primary content is text - at c within an @ref{edit} @ref{control}. An example of secondary state - at c information (relevant to this topic at least) is the @ref{span} of - at c selected text in an edit control. With that in mind, Graphic-Forms - at c functions @samp{delete} content but @samp{clear} secondary state. This - at c choice aligns with the semantics of @sc{CL:delete}, including the - at c notion of that function being a destructive operation. - - at item function and method names -Functions and methods should be named using a verb to suggest -action. It may be tempting (especially for former Java programmers) to -use the Java getter/setter naming conventions for accessor-like -functions, but the author prefers @samp{obtain} rather than - at samp{get}, and he prefers @sc{setf}'able places which therefore can -have @sc{setf} functions defined for them. For status querying -functions, the author suggests @samp{available-p}, such as - at ref{undo-available-p}. - - at item macro names -Macros should be named consistent with established Common Lisp -practice, with an exception being allowed for convenience wrappers -around structure accessors (see for example - at ref{location}). Otherwise, the temptation to define an unorthodox -macro name is a symptom that maybe the code in question should not be -a macro in the first place. The rule of thumb is: if something can -be a function, then let it be a function; in general, think carefully -before creating a new macro. - - at end table + at include image-plugins.texinfo + at include terminology.texinfo Added: trunk/docs/manual/terminology.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/terminology.texinfo Tue Aug 22 02:42:16 2006 @@ -0,0 +1,73 @@ + + at c This file is part of the documentation source for + at c the Graphic-Forms library. + at c + at c Copyright (c) 2006, Jack D. Unrue + + at node Terminology conventions + at section Terminology conventions + +This section documents terminology conventions observed in +Graphic-Forms. These conventions should be interpreted with the +traditional Common Lisp conventions in mind (some of which are +documented here: @url{http://www.cliki.net/Naming%20conventions}). + + at table @option + + at item accessor names +For clearer identification of accessors, Graphic-Forms +uses the suffix @samp{-of} whenever possible. + + at item @samp{check} versus @samp{select} +Admittedly, these two concepts are similar. They can be used as verbs +and they both describe a state of being (@samp{checked} and + at samp{selected}). Yet they need to remain separate due to the fact +that certain @ref{widget}s can exist in both states simultaneously, +like a tri-state @ref{button}, or a table or tree whose items are +checkboxes. The choice of which best describes an action or state +amounts to a judgement call. In Graphic-Forms, the author chooses to +use @samp{select} when a user gesture causes a widget to issue its +primary notification event, such as a menu item or button being +clicked. Hence, the verb @samp{select} aligns with the + at ref{event-select} function. at footnote{This topic gets muddier when +edit controls come into the picture. Text in an edit control is +selected despite there being no notification event; yet there is a +notification (event-modify) then the user types text. I'm choosing to +live with this inconsistency, partly because otherwise my +categorization scheme seems to work well; and one can refer to the act +of retrieving edit control selection, confident that developers will +know this means obtaining highlighted text.} And so the + at samp{selection} state is associated with highlighting of an + at ref{item}. Graphic-Forms uses @samp{check} to identify an operation +that flags or annotates a widget; the @samp{checked} state means being +annotated. + + at c @item @samp{clear} versus @samp{delete} + at c There is a distinction between @samp{clear} and @samp{delete} which + at c hinges on the difference between the primary content of a @ref{widget} + at c and secondary state information. An example of primary content is text + at c within an @ref{edit} @ref{control}. An example of secondary state + at c information (relevant to this topic at least) is the @ref{span} of + at c selected text in an edit control. With that in mind, Graphic-Forms + at c functions @samp{delete} content but @samp{clear} secondary state. This + at c choice aligns with the semantics of @sc{CL:delete}, including the + at c notion of that function being a destructive operation. + + at item function and method names +Functions and methods should be named using a verb to suggest +action. It may be tempting (especially for former Java programmers) to +use the Java getter/setter naming conventions for accessor-like +functions, but the author prefers @samp{obtain} rather than + at samp{get}, and he prefers @sc{setf}able places to Java-style + at samp{put} or @samp{set} functions. In the latter case, where a symbol +refers to both an accessor and a @sc{setf} function, the author +omits the @samp{obtain} prefix (like @ref{size}). For status querying +functions, the author suggests following the standard Common Lisp +convention of @samp{availablep} or @samp{some-test-p}. + + at item macro names +Macro names should be chosen in a manner consistent with established +Common Lisp practice. An exception is allowed for convenience wrappers +around structure accessors (see for example @ref{location}). + + at end table From junrue at common-lisp.net Tue Aug 22 21:26:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 17:26:06 -0400 (EDT) Subject: [graphic-forms-cvs] r231 - in trunk: docs/manual src/uitoolkit/graphics src/uitoolkit/widgets Message-ID: <20060822212606.531381202C@common-lisp.net> Author: junrue Date: Tue Aug 22 17:26:05 2006 New Revision: 231 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: resolved more style warnings reported by SBCL Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Tue Aug 22 17:26:05 2006 @@ -1204,6 +1204,8 @@ @end deffn @deffn GenericFunction cancel-widget self +(setf (@strong{cancel-widget} @var{self}) @var{widget})@* + Returns the @ref{widget} that responds to the @sc{esc} key or otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this widget must be a @ref{button} and is typically labelled @emph{Cancel}. @@ -1285,6 +1287,8 @@ @end deffn @deffn GenericFunction default-widget self +(setf (@strong{default-widget} @var{self}) @var{widget})@* + Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil} if none has been set. If @sc{nil} is passed to the corresponding @sc{setf} function, then no default widget is set. The default widget @@ -1577,6 +1581,8 @@ @anchor{resizable-p} @deffn GenericFunction resizable-p self => boolean +(setf (@strong{resizable-p} @var{self}) @var{boolean})@* + Returns T if @code{self} can be resized by the user; @sc{nil} otherwise. The corresponding @sc{setf} function is implemented for the @ref{top-level} class (but only has meaning when the @code{:frame} @@ -1634,6 +1640,8 @@ @end deffn @deffn GenericFunction text self => string +(setf (@strong{text} @var{self}) @var{string})@* + For a @ref{window} or @ref{dialog}, this function returns @code{self}'s titlebar text (which may be blank). For other @ref{widget}s that have a text component, this function returns that text component. For anything else, Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Tue Aug 22 17:26:05 2006 @@ -210,6 +210,8 @@ ;;; methods ;;; +(defgeneric copy-pixels (self pixels-pointer)) + (defmethod depth ((self image-data)) (depth (data-plugin-of self))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Aug 22 17:26:05 2006 @@ -411,26 +411,24 @@ (w (get-widget tc hwnd)) (info-ptr (cffi:make-pointer lparam))) (if (typep w 'top-level) - (cffi:with-foreign-slots ((gfs::mintracksize gfs::maxtracksize) - info-ptr gfs::minmaxinfo) - (let ((max-size (maximum-size w)) - (min-size (minimum-size w))) - (if max-size - (cffi:with-foreign-slots ((gfs::x gfs::y) - (cffi:foreign-slot-pointer info-ptr - 'gfs::minmaxinfo - 'gfs::maxtracksize) - gfs::point) - (setf gfs::x (gfs:size-width max-size) - gfs::y (gfs:size-height max-size)))) - (if min-size - (cffi:with-foreign-slots ((gfs::x gfs::y) - (cffi:foreign-slot-pointer info-ptr - 'gfs::minmaxinfo - 'gfs::mintracksize) - gfs::point) - (setf gfs::x (gfs:size-width min-size) - gfs::y (gfs:size-height min-size)))))))) + (let ((max-size (maximum-size w)) + (min-size (minimum-size w))) + (if max-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::maxtracksize) + gfs::point) + (setf gfs::x (gfs:size-width max-size) + gfs::y (gfs:size-height max-size)))) + (if min-size + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:foreign-slot-pointer info-ptr + 'gfs::minmaxinfo + 'gfs::mintracksize) + gfs::point) + (setf gfs::x (gfs:size-width min-size) + gfs::y (gfs:size-height min-size))))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) @@ -479,10 +477,7 @@ ;;; (defmethod process-subclass-message (hwnd msg wparam lparam) - (let ((wndproc (get-class-wndproc hwnd))) - (if wndproc - (gfs::call-window-proc (cffi:make-pointer wndproc) hwnd msg wparam lparam) - (gfs::def-window-proc hwnd msg wparam lparam)))) + (gfs::call-window-proc (cffi:make-pointer (get-class-wndproc hwnd)) hwnd msg wparam lparam)) (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Tue Aug 22 17:26:05 2006 @@ -137,28 +137,14 @@ (error 'gfs:toolkit-error :detail (format nil "invalid menu item option: ~a" opt))))) (when sep - (if (or checked disabled disp image sub) + (if (or callback checked disabled disp image sub) (error 'gfs:toolkit-error :detail "invalid separator options"))) - (when image - (if (or sep sub) - (error 'gfs:toolkit-error :detail "image cannot be set for separators or submenus")) - (if (null image) - (error 'gfs:toolkit-error :detail "missing image object"))) (when callback - (if sep - (error 'gfs:toolkit-error :detail "callbacks cannot be set for separators")) - (if (null callback) - (error 'gfs:toolkit-error :detail "missing callback argument")) (if sub (setf disp `(make-instance (define-dispatcher 'gfw:menu ,callback))) (setf disp `(make-instance (define-dispatcher 'gfw:menu-item ,callback))))) - (when disp - (if sep - (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators")) - (if (null disp) - (error 'gfs:toolkit-error :detail "missing dispatcher argument"))) (when sub - (if (or checked image sep (not (listp sub))) + (if (or checked image (not (listp sub))) (error 'gfs:toolkit-error :detail "invalid option for submenu"))) (cond (sep (push `(define-separator ,generator-sym) code)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Aug 22 17:26:05 2006 @@ -63,6 +63,12 @@ (defgeneric border-width (self) (:documentation "Returns the object's border width.")) +(defgeneric cancel-widget (self) + (:documentation "Returns the widget that will be activated when the ESC key is pressed.")) + +(defgeneric (setf cancel-widget) (widget self) + (:documentation "Sets the widget that will be activated when the ESC key is pressed.")) + (defgeneric caret (self) (:documentation "Returns the object's caret.")) @@ -118,7 +124,10 @@ (:documentation "Copies the current text selection to the clipboard and removes it from self.")) (defgeneric default-widget (self) - (:documentation "Returns the child widget or item that has the default emphasis.")) + (:documentation "Returns the widget or item that will be selected when self is active.")) + +(defgeneric (setf default-widget) (self widget) + (:documentation "Sets the widget or item that will be selected when self is active.")) (defgeneric delete-all (self) (:documentation "Removes all content from the object.")) @@ -241,7 +250,10 @@ (:documentation "Sets the largest dimensions to which the user may resize self.")) (defgeneric menu-bar (self) - (:documentation "Returns the menu object serving as the menubar for this object.")) + (:documentation "Returns the menu object serving as the menubar self.")) + +(defgeneric (setf menu-bar) (menu self) + (:documentation "Sets the menu object to serve as the menubar for self.")) (defgeneric minimum-size (self) (:documentation "Returns a size object describing the smallest supported dimensions of self.")) @@ -300,6 +312,9 @@ (defgeneric resizable-p (self) (:documentation "Returns T if the object is resizable; nil otherwise.")) +(defgeneric (setf resizable-p) (flag self) + (:documentation "Pass nil to disable user resizing of self, or non-nil to enable user resizing.")) + (defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) @@ -361,7 +376,10 @@ (:documentation "Return an integer representing the configured step size for the object.")) (defgeneric text (self) - (:documentation "Returns the object's text.")) + (:documentation "Returns self's text.")) + +(defgeneric (setf text) (text self) + (:documentation "Sets self's text.")) (defgeneric text-baseline (self) (:documentation "Returns the y coordinate of the object's text component, if any.")) Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Tue Aug 22 17:26:05 2006 @@ -39,9 +39,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self widget-with-items)) - (let ((count (length (items self)))) - (unless (zerop count) - (delete-item-span self (gfs:make-span :start 0 :end (1- count)))))) + (let ((items (items self))) + (dotimes (i (length items)) + (gfs:dispose (aref items i)))) + (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) (defmethod delete-item :before ((self widget-with-items) index) (declare (ignore index)) @@ -51,7 +52,7 @@ (defmethod delete-item ((self widget-with-items) index) (let* ((items (items self)) (it (elt items index))) - (delete it (items self) :test #'items-equal-p) + (setf (items self) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) From junrue at common-lisp.net Tue Aug 22 21:37:23 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 17:37:23 -0400 (EDT) Subject: [graphic-forms-cvs] r232 - trunk/src/uitoolkit/widgets Message-ID: <20060822213723.D33D81202C@common-lisp.net> Author: junrue Date: Tue Aug 22 17:37:23 2006 New Revision: 232 Modified: trunk/src/uitoolkit/widgets/layout.lisp Log: fixed layout manager regression Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Tue Aug 22 17:37:23 2006 @@ -65,10 +65,10 @@ (defun delete-layout-item (layout thing) "Removes thing from layout." - (delete thing (data-of layout) :key #'first)) + (setf (data-of layout) (remove thing (data-of layout) :key #'first))) (defun cleanup-disposed-items (layout) - (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + (setf (data-of layout) (remove-if #'gfs:disposed-p (data-of layout) :key #'first))) (defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) From junrue at common-lisp.net Tue Aug 22 22:38:08 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 18:38:08 -0400 (EDT) Subject: [graphic-forms-cvs] r233 - in trunk: . docs/website src/tests/uitoolkit Message-ID: <20060822223808.4B35C24002@common-lisp.net> Author: junrue Date: Tue Aug 22 18:38:07 2006 New Revision: 233 Added: trunk/src/tests/uitoolkit/computer.png (contents, props changed) trunk/src/tests/uitoolkit/open-folder.gif (contents, props changed) Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/website/index.html trunk/src/tests/uitoolkit/image-tester.lisp Log: added gif and png testcases to image-tester Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 22 18:38:07 2006 @@ -5,10 +5,10 @@ Here is what's new in this release: -. SBCL is now supported (version 0.9.15 tested). Graphic-Forms includes - a small patch provided to the SBCL community by Alastair Bridgewater - to enable the stdcall calling convention for alien callbacks. Please - see src/external-libraries/sbcl-callback-patch +. SBCL is now supported (specifically version 0.9.15). Graphic-Forms + includes a small patch provided to the SBCL community by + Alastair Bridgewater to enable the stdcall calling convention for + alien callbacks. Please see src/external-libraries/sbcl-callback-patch . Implemented a plugin mechanism for integrating graphics libraries. This means that ImageMagick is now optional -- if your application can get Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Aug 22 18:38:07 2006 @@ -66,7 +66,9 @@ supporting Windows, and as a consequence, you may experience problems such as 'GC invariant lost' errors that result in a crash to LDB. -3. The gfg:text-extent method currently does not return the correct text +3. The 'unblocked' and 'textedit' demo programs are not yet complete. + +4. The gfg:text-extent method currently does not return the correct text height value. As a workaround, get the text metrics for the font and compute height from that. The gfg:text-extent function does return the correct width. Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Tue Aug 22 18:38:07 2006 @@ -53,7 +53,7 @@

Status

The current version is - + 0.5.0, released on 25 August 2006.

Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require @@ -64,7 +64,7 @@

The supported Windows versions are: Added: trunk/src/tests/uitoolkit/computer.png ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Tue Aug 22 18:38:07 2006 @@ -33,20 +33,20 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defvar *image-win* nil) -(defvar *happy-image* nil) -(defvar *bw-image* nil) -(defvar *true-image* nil) +(defvar *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *comp-image* nil) +(defvar *folder-image* nil) +(defvar *true-image* nil) (defclass image-events (gfw:event-dispatcher) ()) (defun dispose-images () - (gfs:dispose *happy-image*) - (setf *happy-image* nil) - (gfs:dispose *bw-image*) - (setf *bw-image* nil) - (gfs:dispose *true-image*) - (setf *true-image* nil)) + (loop for var in '(*happy-image* *bw-image* *folder-image* *true-image* *comp-image*) + do (unless (null (symbol-value var)) + (gfs:dispose (symbol-value var)) + (setf (symbol-value var) nil)))) (defmethod gfw:event-close ((d image-events) window) (declare (ignore window)) @@ -55,36 +55,36 @@ (setf *image-win* nil) (gfw:shutdown 0)) +(defun draw-test-image (gc image origin pixel-pnt) + (gfg:draw-image gc image origin) + (incf (gfs:point-x origin) 36) + (gfg:with-image-transparency (image pixel-pnt) + (gfg:draw-image gc (gfg:transparency-mask image) origin) + (incf (gfs:point-x origin) 36) + (gfg:draw-image gc image origin))) + (defmethod gfw:event-paint ((d image-events) window gc rect) (declare (ignore window rect)) (let ((pnt (gfs:make-point)) (pixel-pnt1 (gfs:make-point)) - (pixel-pnt2 (gfs:make-point :x 0 :y 15))) - - (gfg:draw-image gc *happy-image* pnt) - (incf (gfs:point-x pnt) 36) - (gfg:with-image-transparency (*happy-image* pixel-pnt1) - (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) - (incf (gfs:point-x pnt) 36) - (gfg:draw-image gc *happy-image* pnt)) - + (pixel-pnt2 (gfs:make-point :x 15 :y 0)) + (pixel-pnt3 (gfs:make-point :x 31 :y 31))) + (declare (ignorable pixel-pnt3)) + (draw-test-image gc *happy-image* pnt pixel-pnt1) (setf (gfs:point-x pnt) 0) (incf (gfs:point-y pnt) 36) - (gfg:draw-image gc *bw-image* pnt) - (incf (gfs:point-x pnt) 24) - (gfg:with-image-transparency (*bw-image* pixel-pnt1) - (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) - (incf (gfs:point-x pnt) 24) - (gfg:draw-image gc *bw-image* pnt)) - + (draw-test-image gc *bw-image* pnt pixel-pnt1) (setf (gfs:point-x pnt) 0) - (incf (gfs:point-y pnt) 20) - (gfg:draw-image gc *true-image* pnt) - (incf (gfs:point-x pnt) 20) - (gfg:with-image-transparency (*true-image* pixel-pnt2) - (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) - (incf (gfs:point-x pnt) 20) - (gfg:draw-image gc *true-image* pnt)))) + (incf (gfs:point-y pnt) 36) + (draw-test-image gc *true-image* pnt pixel-pnt2) +#+load-imagemagick-plugin + (progn + (setf (gfs:point-x pnt) 112) + (setf (gfs:point-y pnt) 0) + (draw-test-image gc *folder-image* pnt pixel-pnt1) + (setf (gfs:point-x pnt) 112) + (incf (gfs:point-y pnt) 36) + (draw-test-image gc *comp-image* pnt pixel-pnt3)))) (defun exit-image-fn (disp item) (declare (ignorable disp item)) @@ -93,15 +93,24 @@ (setf *image-win* nil) (gfw:shutdown 0)) +(defun load-images () + (let ((*default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))) + (setf *happy-image* (make-instance 'gfg:image)) + (gfg::load *happy-image* "happy.bmp") + (setf *bw-image* (make-instance 'gfg:image)) + (gfg::load *bw-image* "blackwhite20x16.bmp") + (setf *true-image* (make-instance 'gfg:image)) + (gfg::load *true-image* "truecolor16x16.bmp") +#+load-imagemagick-plugin + (progn + (setf *folder-image* (make-instance 'gfg:image)) + (gfg::load *folder-image* "open-folder.gif") + (setf *comp-image* (make-instance 'gfg:image)) + (gfg::load *comp-image* "computer.png")))) + (defun image-tester-internal () - (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) + (load-images) (let ((menubar nil)) - (setf *happy-image* (make-instance 'gfg:image)) - (setf *bw-image* (make-instance 'gfg:image)) - (setf *true-image* (make-instance 'gfg:image)) - (gfg::load *happy-image* "happy.bmp") - (gfg::load *bw-image* "blackwhite20x16.bmp") - (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:workspace))) (setf (gfw:size *image-win*) (gfs:make-size :width 250 :height 200)) Added: trunk/src/tests/uitoolkit/open-folder.gif ============================================================================== Binary file. No diff available. From junrue at common-lisp.net Tue Aug 22 22:43:47 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 18:43:47 -0400 (EDT) Subject: [graphic-forms-cvs] r234 - trunk Message-ID: <20060822224347.99BD22608B@common-lisp.net> Author: junrue Date: Tue Aug 22 18:43:47 2006 New Revision: 234 Modified: trunk/config.lisp Log: make configure-asdf work like the readme says it should Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Tue Aug 22 18:43:47 2006 @@ -52,8 +52,6 @@ (defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () - (pushnew *binary-data-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)) + (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir*) + when (symbol-value var) + do (pushnew (symbol-value var) asdf:*central-registry* :test #'equal))) From junrue at common-lisp.net Tue Aug 22 23:10:18 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 19:10:18 -0400 (EDT) Subject: [graphic-forms-cvs] r235 - in trunk: . docs/website Message-ID: <20060822231018.350A33E002@common-lisp.net> Author: junrue Date: Tue Aug 22 19:10:17 2006 New Revision: 235 Modified: trunk/NEWS.txt trunk/README.txt trunk/build.lisp trunk/config.lisp trunk/docs/website/index.html Log: final tweaks for 0.5.0 Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 22 19:10:17 2006 @@ -86,7 +86,7 @@ Jack Unrue jdunrue (at) gmail (dot) com -25 August 2006 +22 August 2006 ============================================================================== Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Tue Aug 22 19:10:17 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 (25 August 2006) +Graphic-Forms README for version 0.5.0 (22 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -113,8 +113,13 @@ ;; load the other dependencies besides ImageMagick. Or if your Lisp ;; image already has these systems loaded, set the variables to nil. ;; + ;; Note that *gf-dir* should be the Graphic-Forms top-level directory + ;; path. + ;; + ;; ;; gfsys::*cffi-dir* ;; gfsys::*closer-mop-dir* + ;; gfsys::*gf-dir* ;; gfsys::*lw-compat-dir* ;; Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Tue Aug 22 19:10:17 2006 @@ -58,5 +58,4 @@ (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") (configure-asdf) - (pushnew *gf-dir* asdf:*central-registry* :test #'equal) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Tue Aug 22 19:10:17 2006 @@ -52,6 +52,6 @@ (defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () - (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir*) + (loop for var in '(*binary-data-dir* *cffi-dir* *closer-mop-dir* *lw-compat-dir* *macro-utilities-dir* *gf-dir*) when (symbol-value var) do (pushnew (symbol-value var) asdf:*central-registry* :test #'equal))) Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Tue Aug 22 19:10:17 2006 @@ -54,7 +54,7 @@

The current version is - 0.5.0, released on 25 August 2006.

+ 0.5.0, released on 22 August 2006.

Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect From junrue at common-lisp.net Tue Aug 22 23:13:26 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 22 Aug 2006 19:13:26 -0400 (EDT) Subject: [graphic-forms-cvs] r236 - tags/release-0.5.0 Message-ID: <20060822231326.6CBD83E002@common-lisp.net> Author: junrue Date: Tue Aug 22 19:13:26 2006 New Revision: 236 Added: tags/release-0.5.0/ - copied from r235, trunk/ Log: tagging the 0.5.0 release From junrue at common-lisp.net Wed Aug 23 13:25:24 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 23 Aug 2006 09:25:24 -0400 (EDT) Subject: [graphic-forms-cvs] r237 - in trunk: . docs/manual docs/website src/demos/textedit src/demos/unblocked Message-ID: <20060823132524.A16267433D@common-lisp.net> Author: junrue Date: Wed Aug 23 09:25:23 2006 New Revision: 237 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo trunk/docs/manual/reference.texinfo trunk/docs/website/index.html trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: version number bump Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Aug 23 09:25:23 2006 @@ -1,4 +1,8 @@ + + +============================================================================== + Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Aug 23 09:25:23 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.5.0 (22 August 2006) +Graphic-Forms README for version 0.6.0 (22 August 2006) Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Wed Aug 23 09:25:23 2006 @@ -53,7 +53,7 @@ @itemize @bullet @item CLISP 2.38 or later @item LispWorks 4.4.6 - at item SBCL 0.9.15 or later at footnote{a small patch to enable the + at item SBCL 0.9.15 at footnote{a small patch to enable the @sc{stdcall} calling convention for callbacks is temporarily bundled with Graphic-Forms, see @code{src/external-libraries/sbcl-callback-patch/}} @end itemize @@ -113,9 +113,9 @@ @section Building the Library and Running Tests -Please see the @code{README.txt} file included in the -distribution for instructions on how to load the test program -ASDF system and run unit-tests, test programs, and demo programs. +Please see the @code{README.txt} file included in the distribution for +instructions on how to load the ASDF system and run unit-tests, test +programs, and demo programs. @section Support Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Aug 23 09:25:23 2006 @@ -148,7 +148,7 @@ @titlepage @title Graphic-Forms Programming Reference - at c @subtitle Version 0.5 + at c @subtitle Version 0.6 @c @author Jack D. Unrue @page @@ -158,7 +158,7 @@ @ifnottex @node Top - at top Graphic-Forms Programming Reference (version 0.5) + at top Graphic-Forms Programming Reference (version 0.6) @insertcopying @end ifnottex Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Aug 23 09:25:23 2006 @@ -54,7 +54,7 @@

The current version is - 0.5.0, released on 22 August 2006.

+ 0.6.0, released on 22 August 2006.

Graphic-Forms is in the alpha stage of development, meaning new features are still being added and existing features require considerable testing. Brave souls who experiment with the code should expect Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Aug 23 09:25:23 2006 @@ -52,7 +52,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.5.0" + :version "0.6.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 23 09:25:23 2006 @@ -39,7 +39,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.5.0" + :version "0.6.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Aug 23 09:25:23 2006 @@ -155,7 +155,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.5"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.6"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Wed Aug 23 09:25:23 2006 @@ -102,7 +102,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.5"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.6"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File" From junrue at common-lisp.net Mon Aug 28 15:20:04 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 28 Aug 2006 11:20:04 -0400 (EDT) Subject: [graphic-forms-cvs] r239 - in trunk: . docs/manual src src/uitoolkit/widgets Message-ID: <20060828152004.A67BE550DB@common-lisp.net> Author: junrue Date: Mon Aug 28 11:20:02 2006 New Revision: 239 Added: trunk/src/uitoolkit/widgets/item-manager.lisp - copied, changed from r231, trunk/src/uitoolkit/widgets/widget-with-items.lisp Removed: trunk/src/uitoolkit/widgets/widget-with-items.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/glossary.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: widget-with-items base class renamed to item-manager and is now a mix-in Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Aug 28 11:20:02 2006 @@ -75,7 +75,7 @@ * Layouts:: Layout manager classes. * Controls:: Control classes. * Windows and dialogs:: Window and dialog classes. -* Miscellaneous types:: Base classes for more specialized kinds of widgets. +* Miscellaneous types:: Assorted base classes and utility classes. * Event functions:: Functions related to event processing. * Layout functions:: Functions related to layout management. * Widget functions:: Functions related to widgets. Modified: trunk/docs/manual/glossary.texinfo ============================================================================== --- trunk/docs/manual/glossary.texinfo (original) +++ trunk/docs/manual/glossary.texinfo Mon Aug 28 11:20:02 2006 @@ -63,6 +63,13 @@ invoked in a context-sensitive manner via the mouse or an @ref{accelerator}.@* + at item mix-in class + at anchor{mix-in class} + at cindex mix-in class +A mix-in class represents a specific abstraction that +complements the role(s) of other class(es) in a class +hierarchy.@* + @item mnemonic @anchor{mnemonic} @cindex mnemonic Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 11:20:02 2006 @@ -63,13 +63,24 @@ @deftp Class item item-id The @code{item} class is the base class for all non-windowed user interface objects serving as subcomponents of a - at ref{widget-with-items} object. It derives from @ref{event-source}. + at ref{item-manager} object. It derives from @ref{event-source}. @deffn Initarg :item-id @end deffn @deffn Accessor item-id @end deffn @end deftp + at anchor{item-manager} + at deftp Class item-manager items +This is is a mix-in class for @ref{widget}s containing sub-elements. + + at table @var + at item items +An @sc{adjustable} @sc{vector} containing @ref{item}s representing +sub-elements. + at end table + at end deftp + @anchor{layout-managed} @deftp Class layout-managed layout layout-p Instances of this class employ a @ref{layout-manager} to maintain @@ -93,9 +104,10 @@ @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It -derives from @ref{widget-with-items}. +derives from @ref{item-manager}. @end deftp + at anchor{menu-item} @deftp Class menu-item A subclass of @ref{item} representing a @ref{menu} item. @end deftp @@ -129,14 +141,6 @@ behavior of the widget; style keywords are widget-specific. @end deftp - at anchor{widget-with-items} - at deftp Class widget-with-items items -The widget-with-items class is the base class for objects composed of -sub-items. It derives from @ref{widget}. The @code{items} slot is an - at sc{adjustable} @sc{vector} containing @ref{item} objects, -representing sub-elements of the widget. - at end deftp - @node Controls @subsection Controls Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Aug 28 11:20:02 2006 @@ -131,7 +131,7 @@ (:file "edit") (:file "label") (:file "button") - (:file "widget-with-items") + (:file "item-manager") (:file "menu") (:file "menu-item") (:file "menu-language") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Aug 28 11:20:02 2006 @@ -256,6 +256,7 @@ #:flow-layout #:heap-layout #:item + #:item-manager #:layout-managed #:layout-manager #:menu @@ -265,7 +266,6 @@ #:timer #:top-level #:widget - #:widget-with-items #:window ;; constants Copied: trunk/src/uitoolkit/widgets/item-manager.lisp (from r231, trunk/src/uitoolkit/widgets/widget-with-items.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 11:20:02 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; widget-with-items.lisp +;;;; item-manager.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -33,23 +33,23 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((self widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) +(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) (declare (ignore text image disp checked disabled)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-all ((self widget-with-items)) +(defmethod delete-all ((self item-manager)) (let ((items (items self))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) -(defmethod delete-item :before ((self widget-with-items) index) +(defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item ((self widget-with-items) index) +(defmethod delete-item ((self item-manager) index) (let* ((items (items self)) (it (elt items index))) (setf (items self) (remove it items :test #'items-equal-p)) @@ -57,21 +57,21 @@ (error 'gfs:disposed-error)) (gfs:dispose it))) -(defmethod delete-item-span :before ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span :before ((self item-manager) (sp gfs:span)) (declare (ignore sp)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod delete-item-span ((self widget-with-items) (sp gfs:span)) +(defmethod delete-item-span ((self item-manager) (sp gfs:span)) (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) -(defmethod item-index :before ((self widget-with-items) (it item)) +(defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod item-index ((self widget-with-items) (it item)) +(defmethod item-index ((self item-manager) (it item)) (let ((pos (position it (items self) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 11:20:02 2006 @@ -154,21 +154,21 @@ (defclass font-dialog (widget) () (:documentation "This class represents the standard font dialog.")) -(defclass widget-with-items (widget) +(defclass item-manager () ((items :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t))) - (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) + (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget-with-items) +(defclass list-box (widget item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select :allocation :class)) ; shadowing same slot from event-source (:documentation "The list-box class represents the standard listbox control.")) -(defclass menu (widget-with-items) +(defclass menu (widget item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-activate From junrue at common-lisp.net Mon Aug 28 20:33:22 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 28 Aug 2006 16:33:22 -0400 (EDT) Subject: [graphic-forms-cvs] r240 - trunk/docs/manual Message-ID: <20060828203322.A68DE3200E@common-lisp.net> Author: junrue Date: Mon Aug 28 16:33:21 2006 New Revision: 240 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo Log: refined controls section of manual, added more doc for list-box Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Mon Aug 28 16:33:21 2006 @@ -89,6 +89,21 @@ The @ref{point} location of the mouse cursor. @end macro + at macro control-callback-initarg{classname,callbackname} + at deffn Initarg :callback +The function supplied via this initarg will be used as +the implementation of @sc{@ref{\callbackname\}} in an + at ref{event-dispatcher} configured for the \classname\. +See also @var{callback-event-name}. + at end deffn + at end macro + + at macro control-parent-initarg{classname} + at deffn Initarg :parent +This initarg specifies the @ref{parent} of the \classname\. + at end deffn + at end macro + @macro begin-control-subclass{classname,descr,callbackname} @anchor{\classname\} @deftp Class \classname\ callback-event-name Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 16:33:21 2006 @@ -8,10 +8,12 @@ @node Widget functions @subsection Widget functions - at deffn GenericFunction ancestor-p ancestor descendant -Returns T if ancestor is an ancestor of descendant; nil otherwise. + at anchor{ancestor-p} + at deffn GenericFunction ancestor-p ancestor descendant => boolean +Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise. @end deffn + at anchor{append-item} @deffn GenericFunction append-item self text image dispatcher &optional disabled checked Adds the new item with the specified @code{text}, @code{image}, and @ref{event-dispatcher} to the object, and returns the newly-created item. Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 16:33:21 2006 @@ -61,13 +61,13 @@ @anchor{item} @deftp Class item item-id -The @code{item} class is the base class for all non-windowed user -interface objects serving as subcomponents of a - at ref{item-manager} object. It derives from @ref{event-source}. - at deffn Initarg :item-id - at end deffn - at deffn Accessor item-id - at end deffn +This is the base class for all non-windowed user +interface objects serving as subcomponents of an + at ref{item-manager}. It derives from @ref{event-source}. + at table @var + at item item-id +An identifier for the item managed internally by Graphic-Forms. + at end table @end deftp @anchor{item-manager} @@ -104,7 +104,7 @@ @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It -derives from @ref{item-manager}. +derives from @ref{widget} and @ref{item-manager}. @end deftp @anchor{menu-item} @@ -146,17 +146,14 @@ @subsection Controls @begin-control-subclass{button, -This @ref{control} class represents selectable controls that generate +This @ref{control} subclass represents selectable controls that generate an event when clicked., event-select} - at deffn Initarg :callback -The @sc{function} value supplied via this initarg will be -used as the implementation of @ref{event-select} in an - at ref{event-dispatcher} configured for the @code{button}. - at end deffn + at control-callback-initarg{button,event-select} @deffn Initarg :image -Supplies an image to be used as the @code{button}'s label. +Supplies an image to be used as the button's label. @end deffn + at control-parent-initarg{button} @deffn Initarg :style @table @code @item :cancel-button @@ -165,26 +162,26 @@ action should be interpreted as the user discarding the content of the dialog. @item :check-box -This style specifies a @code{button} having a small box, which may -contain a check mark depending on the @code{button}'s selection state, +This style specifies a button having a small box, which may +contain a check mark depending on the button's selection state, adjacent to a text label. @item :default-button Placing a @code{:default-button} in a dialog enables the @sc{return} key @ref{accelerator} for dismissing the dialog. This action should be interpreted as the user accepting the content of the dialog. Also, the - at code{button} is rendered with an extra thick border. +button is rendered with an extra thick border. @item :push-button This style specifies a traditional push button control. No special keyboard accelerators are enabled. @item :radio-button -This style specifies a @code{button} having a small circle, which may -be filled or unfilled depending on the @code{button}'s selection -state, adjacent to a text label. Radio @code{button}s are typically +This style specifies a button having a small circle, which may +be filled or unfilled depending on the button's selection +state, adjacent to a text label. Radio buttons are typically used in groups and are managed such that only one member of the group is enabled at a time. @item :toggle-button This style specifies a control that when unselected looks like a push - at code{button}. But when in the selected state, the @code{button} +button. But when in the selected state, the button maintains a sunken look. It is similar in function to a @code{:check-box}. @item :tri-state @@ -194,7 +191,7 @@ @end table @end deffn @deffn Initarg :text -Supplies the text for the @code{button} label. +Supplies the text for the button label. @end deffn @end-control-subclass @@ -202,67 +199,65 @@ @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from @ref{widget}.@*@* - at strong{Note:} application code should not manipulate @code{control} slots -directly, unless defining a new @code{control} type as an extension to + at strong{Note:} application code should not manipulate control slots +directly, unless defining a new control type as an extension to Graphic-Forms. @table @var @item brush-color -If set, this @ref{color} object is used as the @code{control}'s background color -when the @code{control} needs to be redrawn. +If set, this @ref{color} object is used as the control's background color +when the control needs to be redrawn. @item brush-handle This is a native handle for a Win32 @sc{brush} that is used when customizing -the @code{control}'s background color. +the control's background color. @item font -This is a @ref{font} object for customizing the text of a @code{control}. +This is a @ref{font} object for customizing the text of a control. @item pixel-point This is a @ref{point} object specifying a pixel in an @ref{image} -associated with a @code{control}, for the purpose of determining what +associated with a control, for the purpose of determining what color to use for transparency. @item maximum-size This is a @ref{size} object that places a maximum constraint on the -size that a @ref{layout-manager} may set for the @code{control}. It +size that a @ref{layout-manager} may set for the control. It may be @sc{nil} if no such constraint has been set. @item minimum-size This is a @ref{size} object that places a minimum constraint on the -size that a @ref{layout-manager} may set for the @code{control}. It +size that a @ref{layout-manager} may set for the control. It may be @sc{nil} if no such constraint has been set. @item text-color -If set, this color object is used as the @code{control}'s foreground text -color when the @code{control} needs to be redrawn. +If set, this color object is used as the control's foreground text +color when the control needs to be redrawn. @end table @deffn Initarg :callback -This initarg associates a @sc{function} with an @ref{event-dispatcher} +This initarg associates a function with an @ref{event-dispatcher} subclass that is generated behind the scenes and then instantiated to -serve as the @code{control}'s event dispatcher. Each @code{control} +serve as the control's event dispatcher. Each control subclass specifies the particular event function (e.g., @ref{event-select}) that this callback will implement; see the documentation for specific - at code{control} subclasses for more information on this initarg. +control subclasses for more information on this initarg. @end deffn + at control-parent-initarg{control} @end deftp @begin-control-subclass{edit, This subclass of @ref{control} represents a rectangular area that permits the user to enter and edit text. The @ref{event-focus-gain} -and @ref{event-focus-loss} methods of each @code{edit control}'s +and @ref{event-focus-loss} methods of each edit control's @ref{event-dispatcher} are invoked when focus is given or taken away. The @ref{event-modify} method is invoked when the user edits content., event-modify} - at deffn Initarg :callback -The @sc{function} value supplied via this initarg will be -used as the implementation of @ref{event-modify} in an - at ref{event-dispatcher} configured for the @code{edit control}. - at end deffn + at control-callback-initarg{edit,event-modify} + at control-parent-initarg{edit} @deffn Initarg :style @table @code @item :auto-hscroll -Specifies that the @code{edit control} will scroll text content to the +Specifies that the edit control will scroll text content to the right by 10 characters when the user types a character at the end -of the line. For single-line @code{edit control}s, this style is set +of the line. For single-line edit controls, this style is set by the library. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and @ref{enable-auto-scrolling}. @item :auto-vscroll -Specifies that the @code{edit control} will scroll text up by a page +Specifies that the edit control will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword is only meaningful when @code{:multi-line} is also specified. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and @@ -274,21 +269,21 @@ instead of the one literally typed. The character can be changed via the @ref{echo-character} @sc{setf} method. @item :multi-line -By default, @code{edit control}s are single-line text fields. By specifying +By default, edit controls are single-line text fields. By specifying @code{:multi-line}, multiple lines of text can be supplied. When the - at code{edit control} is in a @ref{dialog}, the @sc{enter} key will invoke +edit control is in a @ref{dialog}, the @sc{enter} key will invoke the default @ref{button}'s @ref{event-dispatcher}, unless @code{:want-return} is also specified. If @code{:auto-hscroll} is not specified, then text will be automatically word-wrapped. @item :no-border -By default, an @code{edit control} is rendered with a border; this style +By default, an edit control is rendered with a border; this style keyword disables that feature. @item :no-hide-selection This specifies that any selection remain rendered even when the - at code{edit control} loses input focus. By default, the selection +edit control loses input focus. By default, the selection is hidden when focus is lost. @item :read-only -Specifies that the @code{edit control}'s contents cannot be modified by +Specifies that the edit control's contents cannot be modified by the user. @item :vertical-scrollbar Specifies that a vertical scrollbar should be displayed. @@ -301,13 +296,14 @@ @end table @end deffn @deffn Initarg :text -Supplies the initial text for the @code{edit control}. +Supplies the initial text for the edit control. @end deffn @end-control-subclass @begin-control-subclass-no-callback{label, This @ref{control} subclass represents non-selectable controls that display a string\, image\, or etched line.} + at control-parent-initarg{label} @deffn Initarg :image Supply an @ref{image} object as the value of this initarg to configure the label to display the image rather than text. @@ -347,8 +343,50 @@ @end-control-subclass @begin-control-subclass{list-box, -This @ref{control} class represents a list of selectable items., +This @ref{control} subclass represents a list of selectable items; it +also inherits @ref{item-manager}. The list is always visible\, unlike +a combo-box., event-select} + at control-callback-initarg{list-box,event-select} + at deffn Initarg :collator +This initarg accepts a predicate function of two arguments +returning a @sc{boolean}, for the purpose of ordering the list-box +items. The arguments passed are the application-supplied data objects +used to populate the list-box. + at end deffn + at deffn Initarg :initial-items +This initarg accepts a list of objects for initially populating the +contents of the list-box. @sc{print-object} will be called for +each object to produce the corresponding item's display string. +The list-box will hold references to the supplied objects. See +also @ref{append-item}. + at end deffn + at control-parent-initarg{list-box} + at deffn Initarg :style + at table @code + at item :extend-select +This style keyword causes the list-box to allow multiple items to +be selected by use of the @sc{shift} key and the mouse or special +keys. + at item :multiple-select +This style keyword enables individual toggling of multiple item +selections within the list-box. Without this style, the list-box will +only allow a single selection. + at item :no-select +This style keyword means that the list-box will display items but +not allow any selections. + at item :tab-stops +This style keyword configures the list-box to to expand tab characters +when rendering item strings. + at item :want-keys +This style keyword allows the application to perform special processing +when the list-box has focus and the user presses a key. + at item :want-scrollbar +This style keyword causes the list-box to show a disabled vertical +scrollbar when it does not contain enough items to scroll. Otherwise +in such a case, the scrollbar will be hidden. + at end table + at end deffn @end-control-subclass From junrue at common-lisp.net Mon Aug 28 22:52:56 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 28 Aug 2006 18:52:56 -0400 (EDT) Subject: [graphic-forms-cvs] r241 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060828225256.46C5777003@common-lisp.net> Author: junrue Date: Mon Aug 28 18:52:53 2006 New Revision: 241 Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: item-manager now has slots for functions to obtain text and image from item data, revised append-item accordingly Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Mon Aug 28 18:52:53 2006 @@ -10,25 +10,27 @@ @anchor{ancestor-p} @deffn GenericFunction ancestor-p ancestor descendant => boolean -Returns T if @var{ancestor} is the parent of @var{descendant}; nil otherwise. +Returns T if @var{ancestor} is the parent of @var{descendant}; @sc{nil} +otherwise. @end deffn @anchor{append-item} - at deffn GenericFunction append-item self text image dispatcher &optional disabled checked -Adds the new item with the specified @code{text}, @code{image}, and - at ref{event-dispatcher} to the object, and returns the newly-created item. -The optional @code{checked} and @code{disabled} arguments can be used -to set the item's initial state. - at end deffn - - at deffn GenericFunction append-separator self -Adds a separator item to the object, and returns the newly-created -item. - at end deffn - - at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked -Adds a submenu anchored to a parent menu and returns the corresponding -menu item. The optional @code{checked} and @code{disabled} arguments can + at deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item} +Adds a new item representing @var{thing} to @var{self}, where the +class of @var{self} must derive from @ref{item-manager}. The +newly-created item is returned. The @var{dispatcher} parameter must +be an instance of @ref{event-dispatcher} or a subclass thereof. The +optional @var{checked} and @var{disabled} arguments can be used to set +the item's initial state. + at end deffn + + at deffn GenericFunction append-separator self => @ref{item} +Adds a separator item to @var{self}, and returns the newly-created item. + at end deffn + + at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item} +Adds @var{submenu} anchored to @var{self} and returns the corresponding + at ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can be used to set the menu item's initial state. @end deffn Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Aug 28 18:52:53 2006 @@ -60,24 +60,35 @@ @end deftp @anchor{item} - at deftp Class item item-id + at deftp Class item data item-id This is the base class for all non-windowed user interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var + at item data +A reference to the application-defined object to be wrapped +by the item. @item item-id An identifier for the item managed internally by Graphic-Forms. @end table @end deftp @anchor{item-manager} - at deftp Class item-manager items + at deftp Class item-manager image-provider items text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. - @table @var + at item image-provider +This slot holds a function accepting one argument and returning an +instance of @ref{image}. The default implementation simply +returns @sc{nil}. @item items An @sc{adjustable} @sc{vector} containing @ref{item}s representing sub-elements. + at item text-provider +This slot holds a function accepting one argument and returning a + at sc{string}. The default implementation checks whether the argument +is already a @sc{string}, and if so just returns it; otherwise it +calls @sc{format}. @end table @end deftp @@ -356,10 +367,8 @@ @end deffn @deffn Initarg :initial-items This initarg accepts a list of objects for initially populating the -contents of the list-box. @sc{print-object} will be called for -each object to produce the corresponding item's display string. -The list-box will hold references to the supplied objects. See -also @ref{append-item}. +contents of the list-box. The list-box will hold references to the +supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @deffn Initarg :style Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Aug 28 18:52:53 2006 @@ -177,7 +177,7 @@ (gfw:mapchildren *layout-tester-win* (lambda (parent child) (declare (ignore parent)) - (let ((it (gfw::append-item menu (gfw:text child) nil nil))) + (let ((it (gfw::append-item menu (gfw:text child) nil))) (unless (null (sub-disp-class-of d)) (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) (unless (null (check-test-fn d)) @@ -378,9 +378,9 @@ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) (let ((style (gfw:style-of (gfw:layout-of *layout-tester-win*)))) - (setf it (gfw:append-item menu "Normalize" nil #'set-flow-layout-normalize)) + (setf it (gfw:append-item menu "Normalize" #'set-flow-layout-normalize)) (gfw:check it (find :normalize style)) - (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (setf it (gfw:append-item menu "Wrap" #'set-flow-layout-wrap)) (gfw:check it (find :wrap style))))) (defun exit-layout-callback (disp item) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Aug 28 18:52:53 2006 @@ -33,8 +33,27 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defmethod append-item :before ((self item-manager) text (image gfg:image) (disp event-dispatcher) &optional checked disabled) - (declare (ignore text image disp checked disabled)) +;;; +;;; helper functions +;;; + +(defun call-text-provider (manager thing) + (let ((func (text-provider-of manager)) + (*print-readably* nil)) + (cond + ((stringp thing) + thing) + ((null func) + (format nil "~a" thing)) + (t + (funcall func thing))))) + +;;; +;;; methods +;;; + +(defmethod append-item :before ((self item-manager) thing (disp event-dispatcher) &optional checked disabled) + (declare (ignore thing disp checked disabled)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Aug 28 18:52:53 2006 @@ -32,7 +32,7 @@ ;;;; (in-package :graphic-forms.uitoolkit.widgets) - + (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Mon Aug 28 18:52:53 2006 @@ -166,15 +166,15 @@ (error 'gfs:win32-error :detail "set-menu-item-info failed")) (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+)))) -(defun create-menuitem-with-callback (hmenu disp) +(defun create-menuitem-with-callback (hmenu thing disp) (let ((item nil)) (cond ((null disp) - (setf item (make-instance 'menu-item :handle hmenu))) + (setf item (make-instance 'menu-item :data thing :handle hmenu))) ((functionp disp) - (setf item (make-instance 'menu-item :handle hmenu :callback disp))) + (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp))) + (setf item (make-instance 'menu-item :data thing :handle hmenu :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Aug 28 18:52:53 2006 @@ -167,6 +167,8 @@ ;;; code generation ;;; +(defstruct menu-item-data text image) + (defun generate-menusystem-code (sexp generator-sym) (let ((code nil)) (mapcar #'(lambda (var) @@ -177,19 +179,25 @@ (defclass win32-menu-generator (base-menu-generator) ()) (defmethod initialize-instance :after ((gen win32-menu-generator) &key) - (let ((m (make-instance 'menu :handle (gfs::create-menu)))) + (let ((m (make-instance 'menu :handle (gfs::create-menu) + :image-provider #'menu-item-data-image + :text-provider #'menu-item-data-text))) (put-widget (thread-context) m) (push m (menu-stack-of gen)))) (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) - (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked)) + (append-item (first (menu-stack-of gen)) + (make-menu-item-data :text label :image image) + dispatcher disabled checked)) (defmethod define-separator ((gen win32-menu-generator)) (let ((owner (first (menu-stack-of gen)))) (append-separator owner))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))) + (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) + :image-provider #'menu-item-data-image + :text-provider #'menu-item-data-text))) (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled) (push submenu (menu-stack-of gen)))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Aug 28 18:52:53 2006 @@ -90,12 +90,12 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) text image disp &optional disabled checked) - (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items +(defmethod append-item ((owner menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) (id (increment-menuitem-id tc)) (hmenu (gfs:handle owner)) - (item (create-menuitem-with-callback hmenu disp))) + (item (create-menuitem-with-callback hmenu thing disp)) + (text (call-text-provider owner thing))) (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (setf (item-id item) id) (put-menuitem tc item) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Aug 28 18:52:53 2006 @@ -80,6 +80,10 @@ :accessor item-id :initarg :item-id :initform 0) + (data + :accessor data-of + :initarg :data + :initform nil) (callback-event-name :accessor callback-event-name-of :initform 'event-select @@ -158,7 +162,15 @@ ((items :accessor items ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t))) + :initform (make-array 7 :fill-pointer 0 :adjustable t)) + (text-provider + :accessor text-provider-of + :initarg :text-provider + :initform nil) + (image-provider + :accessor image-provider-of + :initarg :image-provider + :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) (defclass list-box (widget item-manager) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Aug 28 18:52:53 2006 @@ -45,8 +45,8 @@ (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (self text image dispatcher &optional checked disabled) - (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) +(defgeneric append-item (self thing dispatcher &optional checked disabled) + (:documentation "Adds a new item encapsulating thing to self, and returns the newly-created item.")) (defgeneric append-separator (self) (:documentation "Add a separator item to the object, and returns the newly-created item.")) From junrue at common-lisp.net Tue Aug 29 19:28:44 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 29 Aug 2006 15:28:44 -0400 (EDT) Subject: [graphic-forms-cvs] r242 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060829192844.B050510D6@common-lisp.net> Author: junrue Date: Tue Aug 29 15:28:42 2006 New Revision: 242 Added: trunk/src/uitoolkit/widgets/list-box.lisp Modified: trunk/NEWS.txt trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: continued work on item-manager refactoring and list-box implementation Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Aug 29 15:28:42 2006 @@ -1,5 +1,7 @@ +. Implemented GFW:ENABLE-REDRAW to enable applications to temporarily + disable (and later re-enable) drawing of widget content. ============================================================================== Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Aug 29 15:28:42 2006 @@ -186,24 +186,34 @@ and @ref{auto-vscroll-p}. @end deffn + at anchor{enable-layout} @deffn GenericFunction enable-layout self flag -Cause the object to allow or disallow layout management. +Passing @sc{nil} for @var{flag} disables layout management in @var{self}; +any non- at sc{nil} value enables it. @end deffn - at deffn GenericFunction enabled-p self -Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise. + at anchor{enable-redraw} + at deffn GenericFunction enable-redraw self flag +Passing @sc{nil} for @var{flag} prevents @var{self} from being redrawn +when its client area is invalidated; any non- at sc{nil} value enables +drawing and also invalidates the client area. @end deffn @anchor{enable-scrollbars} @deffn GenericFunction enable-scrollbars self horizontal vertical -Specifying T for @code{horizontal} (@code{vertical}) reveals a +Specifying T for @var{horizontal} (@var{vertical}) reveals a scrollbar to attached to the right-hand (bottom) of - at code{self}. Specifying @sc{nil} hides the scrollbar. These flags do + at var{self}. Specifying @sc{nil} hides the scrollbar. These flags do not affect scrolling behavior in @code{self} -- they only control scrollbar visibility. See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn + at anchor{enabled-p} + at deffn GenericFunction enabled-p self +Returns @sc{t} if @var{self} is enabled; @sc{nil} otherwise. + at end deffn + @anchor{file-dialog-paths} @defun file-dialog-paths dlg => @sc{list} Interrogates the data structure associated with an instance of @@ -533,6 +543,14 @@ before this function returns. @end deffn + at anchor{update-from-items} + at deffn GenericFunction update-from-items self +Synchronizes @var{self}'s internal model (i.e., a native control's +data structures) with the list from the @var{items} slot +after that list has been sorted. Application code typically does not +need to call this function. + at end deffn + @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean Returns T if @code{self} has been configured to display a vertical Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Aug 29 15:28:42 2006 @@ -74,9 +74,14 @@ @end deftp @anchor{item-manager} - at deftp Class item-manager image-provider items text-provider + at deftp Class item-manager collator image-provider items text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. @table @var + at item collator +This slot holds a predicate function of two arguments returning a + at sc{boolean}, for the purpose of ordering @var{items}. The arguments +passed are application-defined objects. Note that not all subclasses +make use of this feature. @item image-provider This slot holds a function accepting one argument and returning an instance of @ref{image}. The default implementation simply @@ -359,14 +364,8 @@ a combo-box., event-select} @control-callback-initarg{list-box,event-select} - at deffn Initarg :collator -This initarg accepts a predicate function of two arguments -returning a @sc{boolean}, for the purpose of ordering the list-box -items. The arguments passed are the application-supplied data objects -used to populate the list-box. - at end deffn - at deffn Initarg :initial-items -This initarg accepts a list of objects for initially populating the + at deffn Initarg :items +This initarg accepts a list of objects for populating the contents of the list-box. The list-box will hold references to the supplied objects. See also @ref{append-item}. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Aug 29 15:28:42 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-box") (:file "menu") (:file "menu-item") (:file "menu-language") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Aug 29 15:28:42 2006 @@ -259,6 +259,7 @@ #:item-manager #:layout-managed #:layout-manager + #:list-box #:menu #:menu-item #:panel @@ -521,6 +522,7 @@ #:trim-sizes #:undo-available-p #:update + #:update-from-items #:vertical-scrollbar #:visible-item-count #:visible-p Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Tue Aug 29 15:28:42 2006 @@ -44,3 +44,18 @@ (assert-true (> (gfs:size-width size)) 0) (assert-true (> (gfs:size-height size)) 0)) (assert-true (> (length (gfw:text display)) 0)))) + +(define-test indexed-sort-test + (let* ((orig1 '("zzz" "mmm" "aaa")) + (result1 (gfs::indexed-sort orig1 #'string< #'identity)) + (orig2 '((zzz 10) (mmm 5) (aaa 1))) + (result2 (gfs::indexed-sort orig2 #'string< #'first))) + (assert-true (string= "aaa" (first result1))) + (assert-true (string= "mmm" (second result1))) + (assert-true (string= "zzz" (third result1))) + (assert-true (eql 'aaa (first (first result2)))) + (assert-true (= 1 (second (first result2)))) + (assert-true (eql 'mmm (first (second result2)))) + (assert-true (= 5 (second (second result2)))) + (assert-true (eql 'zzz (first (third result2)))) + (assert-true (= 10 (second (third result2)))))) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Aug 29 15:28:42 2006 @@ -38,6 +38,7 @@ ;;; (defparameter *button-classname* "button") (defparameter *edit-classname* "edit") +(defparameter *listbox-classname* "listbox") (defparameter *static-classname* "static") ;;; @@ -512,6 +513,66 @@ (defconstant +image-cursor+ 2) (defconstant +image-enhmetafile+ 3) +(defconstant +lb-addstring+ #x0180) +(defconstant +lb-insertstring+ #x0181) +(defconstant +lb-deletestring+ #x0182) +(defconstant +lb-selitemrangeex+ #x0183) +(defconstant +lb-resetcontent+ #x0184) +(defconstant +lb-setsel+ #x0185) +(defconstant +lb-setcursel+ #x0186) +(defconstant +lb-getsel+ #x0187) +(defconstant +lb-getcursel+ #x0188) +(defconstant +lb-gettext+ #x0189) +(defconstant +lb-gettextlen+ #x018A) +(defconstant +lb-getcount+ #x018B) +(defconstant +lb-selectstring+ #x018C) +(defconstant +lb-dir+ #x018D) +(defconstant +lb-gettopindex+ #x018E) +(defconstant +lb-findstring+ #x018F) +(defconstant +lb-getselcount+ #x0190) +(defconstant +lb-getselitems+ #x0191) +(defconstant +lb-settabstops+ #x0192) +(defconstant +lb-gethorizontalextent+ #x0193) +(defconstant +lb-sethorizontalextent+ #x0194) +(defconstant +lb-setcolumnwidth+ #x0195) +(defconstant +lb-addfile+ #x0196) +(defconstant +lb-settopindex+ #x0197) +(defconstant +lb-getitemrect+ #x0198) +(defconstant +lb-getitemdata+ #x0199) +(defconstant +lb-setitemdata+ #x019A) +(defconstant +lb-selitemrange+ #x019B) +(defconstant +lb-setanchorindex+ #x019C) +(defconstant +lb-getanchorindex+ #x019D) +(defconstant +lb-setcaretindex+ #x019E) +(defconstant +lb-getcaretindex+ #x019F) +(defconstant +lb-setitemheight+ #x01A0) +(defconstant +lb-getitemheight+ #x01A1) +(defconstant +lb-findstringexact+ #x01A2) +(defconstant +lb-setlocale+ #x01A5) +(defconstant +lb-getlocale+ #x01A6) +(defconstant +lb-setcount+ #x01A7) +(defconstant +lb-initstorage+ #x01A8) +(defconstant +lb-itemfrompoint+ #x01A9) +(defconstant +lb-multipleaddstring+ #x01B1) +(defconstant +lb-getlistboxinfo+ #x01B2) + +(defconstant +lbs-notify+ #x0001) +(defconstant +lbs-sort+ #x0002) +(defconstant +lbs-noredraw+ #x0004) +(defconstant +lbs-multiplesel+ #x0008) +(defconstant +lbs-ownerdrawfixed+ #x0010) +(defconstant +lbs-ownerdrawvariable+ #x0020) +(defconstant +lbs-hasstrings+ #x0040) +(defconstant +lbs-usetabstops+ #x0080) +(defconstant +lbs-nointegralheight+ #x0100) +(defconstant +lbs-multicolumn+ #x0200) +(defconstant +lbs-wantkeyboardinput+ #x0400) +(defconstant +lbs-extendedsel+ #x0800) +(defconstant +lbs-disablenoscroll+ #x1000) +(defconstant +lbs-nodata+ #x2000) +(defconstant +lbs-nosel+ #x4000) +(defconstant +lbs-combobox+ #x8000) + (defconstant +lf-facesize+ 32) (defconstant +lf-fullfacesize+ 64) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Aug 29 15:28:42 2006 @@ -37,6 +37,13 @@ ;;; convenience functions ;;; +(defun indexed-sort (sequence predicate key) + (let* ((tmp1 (loop for item in sequence + collect (list (funcall key item) item))) + (tmp2 (sort tmp1 predicate :key #'first))) + (loop for item in tmp2 + collect (second item)))) + (defun flatten (tree) (if (cl:atom tree) (list tree) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Tue Aug 29 15:28:42 2006 @@ -95,3 +95,7 @@ (if (null pos) (return-from item-index 0)) 0)) + +(defmethod update-from-items :before ((self item-manager)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) Added: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Aug 29 15:28:42 2006 @@ -0,0 +1,102 @@ +;;;; +;;;; list-box.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.widgets) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self list-box) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+lbs-notify+ + gfs::+ws-vscroll+ gfs::+ws-border+)) + (style (style-of self))) + (loop for sym in style + do (ecase sym + ;; primary list-box styles + ;; + (:extend-select (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) + (setf std-flags (logior std-flags + gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+))) + + (:multiple (setf std-flags (logand std-flags (lognot gfs::+lbs-nosel+))) + (setf std-flags (logior std-flags gfs::+lbs-multiplesel+))) + + (:no-select (setf std-flags (logand std-flags + (lognot (logior gfs::+lbs-extendedsel+ + gfs::+lbs-multiplesel+)))) + (setf std-flags (logior std-flags gfs::+lbs-nosel+))) + + ;; styles that can be combined + ;; + (:tab-stops (setf std-flags (logior std-flags gfs::+lbs-usetabstops+))) + + (:want-keys (setf std-flags (logior std-flags gfs::+lbs-wantkeyboardinput+))) + + (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((self list-box) &key parent &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window gfs::*listbox-classname* + "" + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self) + (update-from-items self)) + +(defmethod (setf items) :after (new-items (self list-box)) + (declare (ignore new-items)) + (update-from-items self)) + +(defmethod update-from-items ((self list-box)) + (let ((collator (collator-of self)) + (items (items-of self)) + (hwnd (gfs:handle self))) + (when collator + (setf items (gfs::indexed-sort items collator (lambda (it) (data-of it))) + (items-of self) items)) + (enable-redraw self nil) + (unwind-protect + (progn + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) + (loop for item in items + do (append-item self item ???))) + (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Aug 29 15:28:42 2006 @@ -159,7 +159,11 @@ (:documentation "This class represents the standard font dialog.")) (defclass item-manager () - ((items + ((collator + :accessor collator-of + :initarg :collator + :initform nil) + (items :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Aug 29 15:28:42 2006 @@ -203,12 +203,22 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enabled-p :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod enabled-p :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod enabled-p ((w widget)) - (not (zerop (gfs::is-window-enabled (gfs:handle w))))) +(defmethod enable-redraw :before ((self widget) flag) + (declare (ignore flag)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod enable-redraw ((self widget) flag) + (gfs::send-message (gfs:handle self) gfs::+wm-setredraw+ (if flag 1 0) 0) + (if flag + (redraw self))) + +(defmethod enabled-p ((self widget)) + (not (zerop (gfs::is-window-enabled (gfs:handle self))))) (defmethod image :before ((self widget)) (if (gfs:disposed-p self) From junrue at common-lisp.net Wed Aug 30 01:29:35 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 29 Aug 2006 21:29:35 -0400 (EDT) Subject: [graphic-forms-cvs] r243 - in trunk: docs/manual src src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060830012935.C82A1710F3@common-lisp.net> Author: junrue Date: Tue Aug 29 21:29:32 2006 New Revision: 243 Modified: trunk/docs/manual/widget-types.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented list-box version of append-item, renamed items accessor to items-of Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Aug 29 21:29:32 2006 @@ -74,26 +74,29 @@ @end deftp @anchor{item-manager} - at deftp Class item-manager collator image-provider items text-provider + at deftp Class item-manager image-provider items sort-predicate text-provider This is is a mix-in class for @ref{widget}s containing sub-elements. @table @var - at item collator -This slot holds a predicate function of two arguments returning a - at sc{boolean}, for the purpose of ordering @var{items}. The arguments -passed are application-defined objects. Note that not all subclasses -make use of this feature. @item image-provider This slot holds a function accepting one argument and returning an -instance of @ref{image}. The default implementation simply -returns @sc{nil}. +instance of @ref{image}. The function's argument will be one of the +application-supplied objects used to populate the list. The default +implementation simply returns @sc{nil}. @item items -An @sc{adjustable} @sc{vector} containing @ref{item}s representing -sub-elements. +An @sc{adjustable} @sc{vector} containing instances of an + at ref{item} subclass appropriate for the actual @ref{widget}. +Each such item wraps an application-supplied data object. @item text-provider This slot holds a function accepting one argument and returning a - at sc{string}. The default implementation checks whether the argument -is already a @sc{string}, and if so just returns it; otherwise it -calls @sc{format}. + at sc{string}. The function's argument will be one of the +application-supplied objects used to populate the list. The default +implementation checks whether the argument is a @sc{string}, +and if so just returns it; otherwise it calls @sc{format}. + at item sort-predicate +This slot holds a predicate function of two arguments returning a + at sc{boolean}, for the purpose of ordering the members of the @var{items} +list. The actual arguments passed are the application-supplied objects. +Note that not all subclasses make use of this feature. @end table @end deftp @@ -364,6 +367,14 @@ a combo-box., event-select} @control-callback-initarg{list-box,event-select} + at deffn Initarg :estimated-count +This initarg accepts a positive integer value indicating the expected +number of items that the list-box will hold. If supplied, it enables +an optimization in storage allocation by the underlying native control. +As the name of the initarg implies, this is an estimate, which may be +too high (in which case heap space may be wasted) or too low (in which +case the control will re-allocate storage as necessary). + at end deffn @deffn Initarg :items This initarg accepts a list of objects for populating the contents of the list-box. The list-box will hold references to the Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Tue Aug 29 21:29:32 2006 @@ -44,8 +44,8 @@ (defun manage-textedit-file-menu (disp menu) (declare (ignore disp)) - (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)) - (gfw:enable (elt (gfw:items menu) 3) (> (length (gfw:text *textedit-control*)) 0))) + (gfw:enable (elt (gfw:items-of menu) 2) (gfw:text-modified-p *textedit-control*)) + (gfw:enable (elt (gfw:items-of menu) 3) (> (length (gfw:text *textedit-control*)) 0))) (defun textedit-file-new (disp item) (declare (ignore disp item)) @@ -97,7 +97,7 @@ (declare (ignore disp)) (unless *textedit-control* (return-from manage-textedit-edit-menu nil)) - (let ((items (gfw:items menu)) + (let ((items (gfw:items-of menu)) (text (gfw:text *textedit-control*)) (text-sel (gfw:selection-span *textedit-control*))) (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Aug 29 21:29:32 2006 @@ -438,7 +438,7 @@ #:item-height #:item-id #:item-index - #:items + #:items-of #:key-down-p #:key-toggled-p #:label Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Aug 29 21:29:32 2006 @@ -44,8 +44,8 @@ (defun find-checked-item (disp menu) (declare (ignore disp)) - (dotimes (i (length (gfw:items menu))) - (let ((item (elt (gfw:items menu) i))) + (dotimes (i (length (gfw:items-of menu))) + (let ((item (elt (gfw:items-of menu) i))) (when (gfw:checked-p item) (setf *last-checked-drawing-item* item) (return))))) Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Aug 29 21:29:32 2006 @@ -213,7 +213,7 @@ (defun manage-file-menu (disp menu) (declare (ignore disp)) - (let ((item (elt (gfw:items menu) 0))) + (let ((item (elt (gfw:items-of menu) 0))) (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) (defun manage-timer (disp item) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Aug 29 21:29:32 2006 @@ -211,8 +211,8 @@ (defun check-flow-orient-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout))) - (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout))))) + (gfw:check (elt (gfw:items-of menu) 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (elt (gfw:items-of menu) 1) (find :vertical (gfw:style-of layout))))) (defun set-flow-horizontal (disp item) (declare (ignorable disp item)) @@ -253,7 +253,7 @@ (defun enable-flow-spacing-items (disp menu) (declare (ignore disp)) (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) - (gfw:enable (elt (gfw:items menu) 0) (> spacing 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> spacing 0)))) (defun decrease-flow-spacing (disp item) (declare (ignore disp item)) @@ -273,22 +273,22 @@ (defun enable-left-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:left-margin-of layout) 0)))) (defun enable-top-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:top-margin-of layout) 0)))) (defun enable-right-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:right-margin-of layout) 0)))) (defun enable-bottom-flow-margin-items (disp menu) (declare (ignore disp)) (let ((layout (gfw:layout-of *layout-tester-win*))) - (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0)))) + (gfw:enable (elt (gfw:items-of menu) 0) (> (gfw:bottom-margin-of layout) 0)))) (defun inc-left-flow-margin (disp item) (declare (ignore disp item)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Aug 29 21:29:32 2006 @@ -180,7 +180,7 @@ (if owner (cond ((zerop lparam) - (let ((item (get-menuitem tc wparam-lo))) + (let ((item (get-item tc wparam-lo))) (if (null item) (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo)) (unless (null (dispatcher item)) @@ -208,7 +208,7 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) (declare (ignore hwnd lparam)) ; FIXME: handle system menus (let* ((tc (thread-context)) - (item (get-menuitem tc (lo-word wparam)))) + (item (get-item tc (lo-word wparam)))) (unless (null item) (let ((d (dispatcher item))) (unless (null d) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Tue Aug 29 21:29:32 2006 @@ -58,10 +58,10 @@ (error 'gfs:disposed-error))) (defmethod delete-all ((self item-manager)) - (let ((items (items self))) + (let ((items (items-of self))) (dotimes (i (length items)) (gfs:dispose (aref items i)))) - (setf (items self) (make-array 7 :fill-pointer 0 :adjustable t))) + (setf (items-of self) (make-array 7 :fill-pointer 0 :adjustable t))) (defmethod delete-item :before ((self item-manager) index) (declare (ignore index)) @@ -69,9 +69,9 @@ (error 'gfs:disposed-error))) (defmethod delete-item ((self item-manager) index) - (let* ((items (items self)) + (let* ((items (items-of self)) (it (elt items index))) - (setf (items self) (remove it items :test #'items-equal-p)) + (setf (items-of self) (remove it items :test #'items-equal-p)) (if (gfs:disposed-p it) (error 'gfs:disposed-error)) (gfs:dispose it))) @@ -91,7 +91,7 @@ (error 'gfs:disposed-error))) (defmethod item-index ((self item-manager) (it item)) - (let ((pos (position it (items self) :test #'items-equal-p))) + (let ((pos (position it (items-of self) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0)) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Tue Aug 29 21:29:32 2006 @@ -32,7 +32,22 @@ ;;;; (in-package :graphic-forms.uitoolkit.widgets) - + +(defun create-item-with-callback (howner thing disp) + (let ((item nil) + (id (increment-item-id (thread-context)))) + (cond + ((null disp) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner))) + ((functionp disp) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + ((typep disp 'gfw:event-dispatcher) + (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :dispatcher disp))) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) + item)) + (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Aug 29 21:29:32 2006 @@ -34,9 +34,31 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(defun insert-list-item (hwnd index label hbmp) + (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box + (let ((text (or label ""))) + (cffi:with-foreign-string (str-ptr text) + (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) + (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + +;;; ;;; methods ;;; +(defmethod append-item ((self list-box) thing disp &optional disabled checked) + (declare (ignore disabled checked)) + (let* ((tc (thread-context)) + (hcontrol (gfs:handle self)) + (text (call-text-provider self thing)) + (item (create-item-with-callback hcontrol thing disp))) + (insert-list-item hcontrol -1 text (cffi:null-pointer)) + (put-item tc item) + (vector-push-extend item (items-of self)) + item)) + (defmethod compute-style-flags ((self list-box) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+lbs-notify+ @@ -68,7 +90,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self list-box) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) @@ -80,23 +102,28 @@ (increment-widget-id (thread-context))))) (setf (slot-value self 'gfs:handle) hwnd))) (init-control self) + (if (and estimated-count (> estimated-count 0)) + (gfs::send-message (gfs:handle self) + gfs::+lb-initstorage+ + estimated-count + (* estimated-count +estimated-text-size+))) (update-from-items self)) -(defmethod (setf items) :after (new-items (self list-box)) +(defmethod (setf items-of) :after (new-items (self list-box)) (declare (ignore new-items)) (update-from-items self)) (defmethod update-from-items ((self list-box)) - (let ((collator (collator-of self)) + (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) - (when collator - (setf items (gfs::indexed-sort items collator (lambda (it) (data-of it))) + (when sort-func + (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) (items-of self) items)) (enable-redraw self nil) (unwind-protect (progn (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item ???))) + do (append-item self item (dispatcher self)))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Aug 29 21:29:32 2006 @@ -166,20 +166,6 @@ (error 'gfs:win32-error :detail "set-menu-item-info failed")) (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+)))) -(defun create-menuitem-with-callback (hmenu thing disp) - (let ((item nil)) - (cond - ((null disp) - (setf item (make-instance 'menu-item :data thing :handle hmenu))) - ((functionp disp) - (setf item (make-instance 'menu-item :data thing :handle hmenu :callback disp))) - ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :data thing :handle hmenu :dispatcher disp))) - (t - (error 'gfs:toolkit-error - :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) - item)) - ;;; ;;; methods ;;; @@ -196,7 +182,7 @@ (defmethod gfs:dispose ((it menu-item)) (setf (dispatcher it) nil) - (delete-menuitem (thread-context) it) + (delete-tc-item (thread-context) it) (let ((id (item-id it)) (owner (owner it))) (unless (null owner) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Tue Aug 29 21:29:32 2006 @@ -37,7 +37,7 @@ ;;; helper functions ;;; -(defun insert-menuitem (hmenu mid label hbmp hchildmenu disabled checked) +(defun append-menuitem (hmenu mid label hbmp hchildmenu disabled checked) (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) @@ -79,8 +79,8 @@ nil))) (defun visit-menu-tree (menu fn) - (dotimes (index (length (items menu))) - (let ((it (elt (items menu) index)) + (dotimes (index (length (items-of menu))) + (let ((it (elt (items-of menu) index)) (child (sub-menu menu index))) (unless (null child) (visit-menu-tree child fn)) @@ -90,43 +90,39 @@ ;;; methods ;;; -(defmethod append-item ((owner menu) thing disp &optional disabled checked) +(defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (hmenu (gfs:handle owner)) - (item (create-menuitem-with-callback hmenu thing disp)) - (text (call-text-provider owner thing))) - (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items owner)) + (hmenu (gfs:handle self)) + (item (create-item-with-callback hmenu thing disp)) + (text (call-text-provider self thing))) + (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) + (put-item tc item) + (vector-push-extend item (items-of self)) item)) -(defmethod append-separator ((owner menu)) - (if (gfs:disposed-p owner) +(defmethod append-separator ((self menu)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (howner (gfs:handle owner)) - (item (make-instance 'menu-item :handle howner))) - (insert-menuitem howner id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items owner)) + (id (increment-item-id tc)) + (hmenu (gfs:handle self)) + (item (make-instance 'menu-item :handle hmenu :item-id id))) + (append-menuitem hmenu id nil (cffi:null-pointer) (cffi:null-pointer) nil nil) + (put-item tc item) + (vector-push-extend item (items-of self)) item)) -(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked) - (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) +(defmethod append-submenu ((self menu) text (submenu menu) disp &optional disabled checked) + (if (or (gfs:disposed-p self) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) (let* ((tc (thread-context)) - (id (increment-menuitem-id tc)) - (hparent (gfs:handle parent)) + (id (increment-item-id tc)) + (hparent (gfs:handle self)) (hmenu (gfs:handle submenu)) - (item (make-instance 'menu-item :handle hparent))) - (insert-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) - (setf (item-id item) id) - (put-menuitem tc item) - (vector-push-extend item (items parent)) + (item (make-instance 'menu-item :handle hparent :item-id id))) + (append-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked) + (put-item tc item) + (vector-push-extend item (items-of self)) (put-widget tc submenu) (cond ((null disp)) @@ -143,7 +139,7 @@ (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) (delete-widget tc (gfs:handle menu)) - (delete-menuitem tc item))) + (delete-tc-item tc item))) (defmethod gfs:dispose ((m menu)) (visit-menu-tree m #'menu-cleanup-callback) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Aug 29 21:29:32 2006 @@ -41,10 +41,10 @@ (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) - (menuitems-by-id :initform (make-hash-table :test #'equal)) + (items-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) - (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (next-item-id :initform 10000 :reader next-item-id) (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) @@ -108,10 +108,10 @@ (defgeneric put-kbdnav-widget (self widget)) (defgeneric delete-kbdnav-widget (self widget)) (defgeneric intercept-kbdnav-message (self msg-ptr)) -(defgeneric get-menuitem (self id)) -(defgeneric put-menuitem (self item)) -(defgeneric delete-menuitem (self item)) -(defgeneric increment-menuitem-id (self)) +(defgeneric get-item (self id)) +(defgeneric put-item (self item)) +(defgeneric delete-tc-item (self item)) +(defgeneric increment-item-id (self)) (defgeneric get-timer (self id)) (defgeneric put-timer (self timer)) (defgeneric delete-timer (self timer)) @@ -202,27 +202,27 @@ (return-from intercept-kbdnav-message widget)))) nil) -(defmethod get-menuitem ((tc thread-context) id) - "Returns the menu item identified by id." - (gethash id (slot-value tc 'menuitems-by-id))) - -(defmethod put-menuitem ((tc thread-context) (it menu-item)) - "Stores a menu item using its id as the key." - (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it)) +(defmethod get-item ((tc thread-context) id) + "Returns the item identified by id." + (gethash id (slot-value tc 'items-by-id))) + +(defmethod put-item ((tc thread-context) (it item)) + "Stores an item using its id as the key." + (setf (gethash (item-id it) (slot-value tc 'items-by-id)) it)) -(defmethod delete-menuitem ((tc thread-context) (it menu-item)) - "Removes the menu item using its id as the key." +(defmethod delete-tc-item ((tc thread-context) (it item)) + "Removes the item using its id as the key." (maphash #'(lambda (k v) (declare (ignore v)) (if (eql k (item-id it)) - (remhash k (slot-value tc 'menuitems-by-id)))) - (slot-value tc 'menuitems-by-id))) + (remhash k (slot-value tc 'items-by-id)))) + (slot-value tc 'items-by-id))) -(defmethod increment-menuitem-id ((tc thread-context)) +(defmethod increment-item-id ((tc thread-context)) "Return the next menu item ID; also increment the internal value." - (let ((id (next-menuitem-id tc))) - (incf (slot-value tc 'next-menuitem-id)) + (let ((id (next-item-id tc))) + (incf (slot-value tc 'next-item-id)) id)) (defmethod get-timer ((tc thread-context) id) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Aug 29 21:29:32 2006 @@ -159,12 +159,12 @@ (:documentation "This class represents the standard font dialog.")) (defclass item-manager () - ((collator - :accessor collator-of - :initarg :collator + ((sort-predicate + :accessor sort-predicate-of + :initarg :sort-predicate :initform nil) (items - :accessor items + :accessor items-of ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t)) (text-provider Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Tue Aug 29 21:29:32 2006 @@ -95,4 +95,5 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+))) + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +estimated-text-size+ 32)) ;; bytes Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Aug 29 21:29:32 2006 @@ -420,6 +420,9 @@ (defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) +(defgeneric update-from-items (self) + (:documentation "Rebuilds the native control's model of self from self's item list.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) From junrue at common-lisp.net Wed Aug 30 04:57:26 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 30 Aug 2006 00:57:26 -0400 (EDT) Subject: [graphic-forms-cvs] r244 - in trunk: . docs/manual src/uitoolkit/widgets Message-ID: <20060830045726.B067B404A@common-lisp.net> Author: junrue Date: Wed Aug 30 00:57:25 2006 New Revision: 244 Added: trunk/src/uitoolkit/widgets/list-item.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: refactored more of menu-item, implemented new list-item class Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Aug 30 00:57:25 2006 @@ -104,17 +104,21 @@ @end deffn @end macro - at macro begin-control-subclass{classname,descr,callbackname} - at anchor{\classname\} - at deftp Class \classname\ callback-event-name -\descr\ - at table @var + at macro callback-event-name-slot{callbackname} @item callback-event-name This is an @code{(:allocation :class)} slot that holds the symbol @sc{@ref{\callbackname\}} identifying the event generic function to be implemented on behalf of the application when a function is supplied for the @code{:callback} initarg. See @ref{event-source} for more details on this slot. + at end macro + + at macro begin-control-subclass{classname,descr,callbackname} + at anchor{\classname\} + at deftp Class \classname\ callback-event-name +\descr\ + at table @var + at callback-event-name-slot{\callbackname\} @end table @end macro Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Wed Aug 30 00:57:25 2006 @@ -65,6 +65,7 @@ interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var + at callback-event-name-slot{event-select} @item data A reference to the application-defined object to be wrapped by the item. @@ -120,6 +121,16 @@ @end deffn @end deftp + at anchor{list-item} + at deftp Class list-item index +A subclass of @ref{item} representing an element of a @ref{list-box}. + at table @var + at item index +This is an internal value representing the position of the item +within the list-box control. + at end table + at end deftp + @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 30 00:57:25 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-item") (:file "list-box") (:file "menu") (:file "menu-item") Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Aug 30 00:57:25 2006 @@ -85,6 +85,12 @@ (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp)))) +(defmethod gfs:dispose ((self item-manager)) + (let ((items (items-of self)) + (tc (thread-context))) + (dotimes (i (length items)) + (delete-tc-item tc (elt items i))))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self) Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Wed Aug 30 00:57:25 2006 @@ -33,16 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defun create-item-with-callback (howner thing disp) +;;; +;;; helper functions +;;; + +(defun create-item-with-callback (howner class-symbol thing disp) (let ((item nil) (id (increment-item-id (thread-context)))) (cond ((null disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) ((functionp disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :dispatcher disp))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) @@ -51,6 +55,10 @@ (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2))) +;;; +;;; methods +;;; + (defmethod check :before ((self item) flag) (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) @@ -59,3 +67,26 @@ (defmethod checked-p :before ((self item)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) + +(defmethod gfs:dispose ((self item)) + (setf (dispatcher self) nil) + (delete-tc-item (thread-context) self) + (setf (data-of self) nil) + (setf (item-id self) 0) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) + (when callback + (unless (typep callback 'function) + (error 'gfs:toolkit-error :detail ":callback value must be a function")) + (setf (dispatcher self) + (make-instance (define-dispatcher (class-name (class-of self)) callback))))) + +(defmethod owner ((self item)) + (let ((hwnd (gfs:handle self))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:toolkit-error :detail "null owner widget handle")) + (let ((widget (get-widget (thread-context) hwnd))) + (if (null widget) + (error 'gfs:toolkit-error :detail "no owner widget")) + widget))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Aug 30 00:57:25 2006 @@ -53,7 +53,7 @@ (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol thing disp))) + (item (create-item-with-callback hcontrol 'list-item thing disp))) (insert-list-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) @@ -125,5 +125,8 @@ (progn (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item (dispatcher self)))) + for index = 0 then (1+ index) + do (progn + (setf (index-of item) index) + (append-item self item (dispatcher self))))) (enable-redraw self t)))) Added: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-item.lisp Wed Aug 30 00:57:25 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; list-item.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.widgets) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self list-item)) + (let ((index (index-of self)) + (owner (owner self))) + (if owner + (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (setf (index-of self) 0)) + (call-next-method)) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Wed Aug 30 00:57:25 2006 @@ -170,65 +170,47 @@ ;;; methods ;;; -(defmethod check ((it menu-item) flag) - (let ((hmenu (gfs:handle it))) - (check-menuitem hmenu (item-id it) flag))) +(defmethod check ((self menu-item) flag) + (let ((hmenu (gfs:handle self))) + (check-menuitem hmenu (item-id self) flag))) -(defmethod checked-p ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod checked-p ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (is-menuitem-checked hmenu (item-id it)))) + (is-menuitem-checked hmenu (item-id self)))) -(defmethod gfs:dispose ((it menu-item)) - (setf (dispatcher it) nil) - (delete-tc-item (thread-context) it) - (let ((id (item-id it)) - (owner (owner it))) +(defmethod gfs:dispose ((self menu-item)) + (let ((id (item-id self)) + (owner (owner self))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) - (let* ((index (item-index owner it)) + (let* ((index (item-index owner self)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfs:dispose child-menu)))) - (setf (item-id it) 0) - (setf (slot-value it 'gfs:handle) nil))) + (gfs:dispose child-menu))))) + (call-next-method)) -(defmethod enable ((it menu-item) flag) +(defmethod enable ((self menu-item) flag) (let ((bits 0)) (if flag (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) - (gfs::enable-menu-item (gfs:handle it) (item-id it) bits))) + (gfs::enable-menu-item (gfs:handle self) (item-id self) bits))) -(defmethod enabled-p ((it menu-item)) - (= (logand (get-menuitem-state (gfs:handle it) (item-id it)) +(defmethod enabled-p ((self menu-item)) + (= (logand (get-menuitem-state (gfs:handle self) (item-id self)) gfs::+mfs-enabled+) gfs::+mfs-enabled+)) -(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys) - (when callback - (unless (typep callback 'function) - (error 'gfs:toolkit-error :detail ":callback value must be a function")) - (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback))))) - -(defmethod owner ((it menu-item)) - (let ((hmenu (gfs:handle it))) - (if (gfs:null-handle-p hmenu) - (error 'gfs:toolkit-error :detail "null owner menu handle")) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no owner menu")) - m))) - -(defmethod text ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod text ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (get-menuitem-text hmenu (item-id it)))) + (get-menuitem-text hmenu (item-id self)))) -(defmethod (setf text) (str (it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod (setf text) (str (self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (set-menuitem-text hmenu (item-id it) str))) + (set-menuitem-text hmenu (item-id self) str))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Aug 30 00:57:25 2006 @@ -93,7 +93,7 @@ (defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu thing disp)) + (item (create-item-with-callback hmenu 'menu-item thing disp)) (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) @@ -141,11 +141,13 @@ (delete-widget tc (gfs:handle menu)) (delete-tc-item tc item))) -(defmethod gfs:dispose ((m menu)) - (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfs:handle m))) - (delete-widget (thread-context) hwnd) - (if (not (gfs:null-handle-p hwnd)) +(defmethod gfs:dispose ((self menu)) + (unless (null (dispatcher self)) + (event-dispose (dispatcher self) self)) + (visit-menu-tree self #'menu-cleanup-callback) + (let ((hwnd (gfs:handle self))) + (when (not (gfs:null-handle-p hwnd)) + (delete-widget (thread-context) hwnd) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) - (setf (slot-value m 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Aug 30 00:57:25 2006 @@ -90,8 +90,14 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects.")) +(defclass list-item (item) + ((index + :accessor index-of + :initform 0)) + (:documentation "A subclass of item representing an element of a list-box.")) + (defclass menu-item (item) () - (:documentation "A subtype of item representing a menu item.")) + (:documentation "A subclass of item representing a menu item.")) (defclass widget (event-source) ((style