From erik.enge at gmail.com Fri Mar 3 14:48:58 2006 From: erik.enge at gmail.com (Erik Enge) Date: Fri, 3 Mar 2006 09:48:58 -0500 Subject: [graphic-forms-cvs] test - ignore Message-ID: <58f839b70603030648l32bb9d0fmda05460bb3c827fe@mail.gmail.com> test - ignore From junrue at common-lisp.net Fri Mar 3 22:27:21 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 3 Mar 2006 17:27:21 -0500 (EST) Subject: [graphic-forms-cvs] r24 - trunk/src/uitoolkit/widgets Message-ID: <20060303222721.BEBD916010@common-lisp.net> Author: junrue Date: Fri Mar 3 17:27:21 2006 New Revision: 24 Modified: trunk/src/uitoolkit/widgets/menu-language.lisp Log: Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Fri Mar 3 17:27:21 2006 @@ -53,7 +53,9 @@ ;;; (defclass base-menu-generator () - ((menu-stack :accessor menu-stack-of + ((commands :accessor commands-of + :initform nil) + (menu-stack :accessor menu-stack-of :initform nil))) (defgeneric define-item (generator label dispatcher disabled checked image) @@ -61,10 +63,10 @@ (:method (generator label dispatcher disabled checked image) (declare (ignorable generator label dispatcher disabled checked image)))) -(defgeneric define-submenu (generator label body dispatcher disabled) +(defgeneric define-submenu (generator label dispatcher disabled) (:documentation "Defines a submenu and its associated item on the parent menu.") - (:method (generator label body dispatcher disabled) - (declare (ignorable generator label body dispatcher disabled)))) + (:method (generator label dispatcher disabled) + (declare (ignorable generator label dispatcher disabled)))) (defgeneric define-separator (generator) (:documentation "Defines a separator.") @@ -144,14 +146,17 @@ (if (or checked image sep (not (listp sub))) (error 'gfs:toolkit-error :detail "invalid option for submenu"))) (cond - (sep `(define-separator ,generator)) - (sub `(define-submenu ,generator ,label ,sub ,disp ,disabled)) - (t `(define-item ,generator ,label ,disp ,disabled ,checked ,image))))) - -#| - (mapcar #'(lambda (var) (process-item-form gen var)) body) - (complete-submenu gen))) -|# + (sep (push (commands-of generator) `(define-separator ,generator))) + (sub (push (commands-of generator) `(define-submenu ,generator + ,label + ,disp + ,disabled))) + (t (push (commands-of generator) `(define-item ,generator + ,label + ,disp + ,disabled + ,checked + ,image)))))) ;;; ;;; interpreter for debugging @@ -159,7 +164,8 @@ (defun interp-menusystem (sexp) (let ((gen (make-instance 'base-menu-generator))) - (mapcar #'(lambda (var) (process-item-form gen var)) sexp))) + (mapcar #'(lambda (var) (process-item-form gen var)) sexp) + (commands-of gen))) ;;; ;;; the real generator @@ -187,7 +193,7 @@ (setf (slot-value it 'gfi:handle) hmenu) (vector-push-extend it (items owner)))) -(defmethod define-submenu ((gen win32-menu-generator) label body dispatcher disabled) +(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) (parent (first (menu-stack-of gen))) (item (append-submenu parent label submenu))) @@ -200,4 +206,5 @@ (defmacro defmenusystem (sexp) (let ((gen (gensym))) `(let ((,gen (make-instance 'win32-menu-generator))) - ,@(loop for form in sexp append (process-item-form gen form))))) + (loop for form in sexp do (process-item-form gen form)) + ,@(commands-of ,gen)))) From junrue at common-lisp.net Sat Mar 4 07:13:11 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 4 Mar 2006 02:13:11 -0500 (EST) Subject: [graphic-forms-cvs] r25 - in trunk: . src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060304071311.7B1502015@common-lisp.net> Author: junrue Date: Sat Mar 4 02:13:10 2006 New Revision: 25 Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/widgets/menu-language.lisp Log: more menu system rewrite fixes Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Mar 4 02:13:10 2006 @@ -49,9 +49,9 @@ :components ((:module "uitoolkit" :components - ((:file "hello-world"))))))))) + ((:file "hello-world") + (:file "event-tester"))))))))) #| - ((:file "event-tester") (:file "hello-world"))))))))) (:file "layout-tester")) |# Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Sat Mar 4 02:13:10 2006 @@ -195,7 +195,7 @@ (setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md :submenu ((:item "&Open..." :dispatcher echo-md) (:item "&Save..." :disabled :dispatcher echo-md) - (:item :separator) + (:item "" :separator) (:item "E&xit" :dispatcher exit-md))) (:item "&Options" :dispatcher echo-md :submenu ((:item "&Enabled" :checked :dispatcher echo-md) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sat Mar 4 02:13:10 2006 @@ -53,9 +53,7 @@ ;;; (defclass base-menu-generator () - ((commands :accessor commands-of - :initform nil) - (menu-stack :accessor menu-stack-of + ((menu-stack :accessor menu-stack-of :initform nil))) (defgeneric define-item (generator label dispatcher disabled checked image) @@ -78,19 +76,15 @@ (:method (generator) (declare (ignorable generator)))) -;;; borrowed from Practical Common Lisp, pg. 433 -;;; -(defun self-evaluating-p (form) - (and (atom form) (if (symbolp form) (keywordp form) t))) - (defun item-form-p (form) (and (consp form) (eq (car form) :item))) -(defun process-item-form (generator form) +(defun process-item-form (form generator-sym) (if (not (item-form-p form)) (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" form))) - (let ((checked nil) + (let ((cmds nil) + (checked nil) (disabled nil) (disp nil) (image nil) @@ -105,7 +99,7 @@ ((not (null disp-tmp)) (setf disp opt) (setf disp-tmp nil)) - ((not (null image-tmp)) + ((not (null image-tmp)) (setf image opt) (setf image-tmp nil)) ((not (null sub-tmp)) @@ -141,35 +135,33 @@ (if sep (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators")) (if (null disp) - (error 'gfs:toolkit-error :detail "missing dispatcher function"))) + (error 'gfs:toolkit-error :detail "missing dispatcher argument"))) (when sub (if (or checked image sep (not (listp sub))) (error 'gfs:toolkit-error :detail "invalid option for submenu"))) (cond - (sep (push (commands-of generator) `(define-separator ,generator))) - (sub (push (commands-of generator) `(define-submenu ,generator - ,label - ,disp - ,disabled))) - (t (push (commands-of generator) `(define-item ,generator - ,label - ,disp - ,disabled - ,checked - ,image)))))) - -;;; -;;; interpreter for debugging -;;; - -(defun interp-menusystem (sexp) - (let ((gen (make-instance 'base-menu-generator))) - (mapcar #'(lambda (var) (process-item-form gen var)) sexp) - (commands-of gen))) - -;;; -;;; the real generator -;;; + (sep (push `(define-separator ,generator-sym) cmds)) + (sub (push `(define-submenu ,generator-sym + ,label + ,disp + ,disabled) cmds) + (loop for subform in sub + do (setf cmds (append (process-item-form subform generator-sym) cmds))) + (push `(complete-submenu ,generator-sym) cmds)) + (t (push `(define-item ,generator-sym + ,label + ,disp + ,disabled + ,checked + ,image) cmds))) + cmds)) + +(defun generate-menusystem-code (sexp generator-sym) + (let ((cmds nil)) + (mapcar #'(lambda (var) + (setf cmds (append (process-item-form var generator-sym) cmds))) + sexp) + (reverse cmds))) (defclass win32-menu-generator (base-menu-generator) ()) @@ -204,7 +196,8 @@ (pop (menu-stack-of gen))) (defmacro defmenusystem (sexp) - (let ((gen (gensym))) + (let* ((gen (gensym)) + (cmds (generate-menusystem-code sexp gen))) `(let ((,gen (make-instance 'win32-menu-generator))) - (loop for form in sexp do (process-item-form gen form)) - ,@(commands-of ,gen)))) + , at cmds + (pop (menu-stack-of ,gen))))) From junrue at common-lisp.net Sat Mar 4 17:23:23 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 4 Mar 2006 12:23:23 -0500 (EST) Subject: [graphic-forms-cvs] r26 - in trunk: . src/tests/uitoolkit Message-ID: <20060304172323.2191446115@common-lisp.net> Author: junrue Date: Sat Mar 4 12:23:22 2006 New Revision: 26 Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/layout-tester.lisp Log: layout tester up-to-date with new menu system definition Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Mar 4 12:23:22 2006 @@ -50,8 +50,5 @@ ((:module "uitoolkit" :components ((:file "hello-world") - (:file "event-tester"))))))))) -#| - (:file "hello-world"))))))))) - (:file "layout-tester")) -|# + (:file "event-tester") + (:file "layout-tester"))))))))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sat Mar 4 12:23:22 2006 @@ -123,15 +123,11 @@ (gfw:clear-all menu) (gfw:with-children (*layout-tester-win* kids) (loop for k in kids - do (let ((it (make-instance 'gfw:menu-item))) - (gfw:append-item menu it) + do (let ((it (gfw::append-item menu (gfw:text k) nil nil))) (unless (null (sub-disp-class-of d)) (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d)))) - (setf (gfw:text it) (gfw:text k)) (unless (null (check-test-fn d)) - (if (funcall (check-test-fn d) k) - (gfw::check it) - (gfw::uncheck it))))))) + (gfw:check it (funcall (check-test-fn d) k))))))) (defclass remove-child-dispatcher (gfw:event-dispatcher) ()) @@ -158,9 +154,7 @@ do (if (string= (gfw:text k) text) (setf victim k)))) (unless (null victim) - (if (gfw:visible-p victim) - (gfw:hide victim) - (gfw:show victim)) + (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) (defclass flow-modifier-menu-dispatcher (gfw:event-dispatcher) ()) @@ -169,34 +163,28 @@ (declare (ignore time)) (gfw:clear-all menu) (let ((it nil) - (margin-menu (gfw:defmenusystem `(((:menu "Top") - (:menuitem "Decrease") - (:menuitem "Increase")) - ((:menu "Left") - (:menuitem "Decrease") - (:menuitem "Increase")) - ((:menu "Right") - (:menuitem "Decrease") - (:menuitem "Increase")) - ((:menu "Bottom") - (:menuitem "Decrease") - (:menuitem "Increase"))))) - (orient-menu (gfw:defmenusystem `(((:menu "") - (:menuitem "Horizontal") - (:menuitem "Vertical"))))) - (spacing-menu (gfw:defmenusystem `(((:menu "") - (:menuitem "Decrease") - (:menuitem "Increase")))))) + (margin-menu (gfw:defmenusystem ((:item "Top" + :submenu ((:item "Decrease") + (:item "Increase"))) + (:item "Left" + :submenu ((:item "Decrease") + (:item "Increase"))) + (:item "Right" + :submenu ((:item "Decrease") + (:item "Increase"))) + (:item "Bottom" + :submenu ((:item "Decrease") + (:item "Increase")))))) + (orient-menu (gfw:defmenusystem ((:item "Horizontal") + (:item "Vertical")))) + (spacing-menu (gfw:defmenusystem ((:item "Decrease") + (:item "Increase"))))) (gfw:append-submenu menu "Margin" margin-menu) (gfw:append-submenu menu "Orientation" orient-menu) (gfw:append-submenu menu "Spacing" spacing-menu) - (setf it (make-instance 'gfw:menu-item)) - (gfw:append-item menu it) - (setf (gfw:text it) "Fill") - (gfw:check it) - (setf it (make-instance 'gfw:menu-item)) - (gfw:append-item menu it) - (setf (gfw:text it) "Wrap"))) + (setf it (gfw:append-item menu "Fill" nil nil)) + (gfw:check it t) + (gfw:append-item menu "Wrap" nil nil))) (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -219,24 +207,27 @@ (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) - (setf menubar (gfw:defmenusystem `(((:menu "&File") - (:menuitem "E&xit" :dispatcher ,exit-disp)) - ((:menu "&Children") - (:menuitem :submenu ((:menu "Add") - (:menuitem "Button" :dispatcher ,add-btn-disp) - (:menuitem "Label" :dispatcher ,add-text-label-disp))) - (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp))) - (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp)))) - ((:menu "&Window") - (:menuitem :submenu ((:menu "Modify Layout" :dispatcher ,mod-layout-menu-disp))) - (:menuitem :submenu ((:menu "Select Layout") - (:menuitem "Flow"))) - (:menuitem "Pack" :dispatcher ,pack-disp))))) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :dispatcher exit-disp))) + (:item "&Children" + :submenu ((:item "Add" + :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Label" :dispatcher add-text-label-disp))) + (:item "Remove" :dispatcher rem-menu-disp + :submenu ((:item ""))) + (:item "Visible" :dispatcher vis-menu-disp + :submenu ((:item ""))))) + (:item "&Window" + :submenu ((:item "Modify Layout" :dispatcher mod-layout-menu-disp + :submenu ((:item ""))) + (:item "Select Layout" + :submenu ((:item "Flow"))) + (:item "Pack" :dispatcher pack-disp)))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button)) (gfw:pack *layout-tester-win*) - (gfw:show *layout-tester-win*))) + (gfw:show *layout-tester-win* t))) (defun run-layout-tester () (gfw:startup "Layout Tester" #'run-layout-tester-internal)) From junrue at common-lisp.net Sat Mar 4 21:54:25 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 4 Mar 2006 16:54:25 -0500 (EST) Subject: [graphic-forms-cvs] r27 - trunk/src/uitoolkit/widgets Message-ID: <20060304215425.F3DA51E00F@common-lisp.net> Author: junrue Date: Sat Mar 4 16:54:25 2006 New Revision: 27 Modified: trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp Log: fixed cleanup bug when submenu items disposed, which caused duplication in layout-tester menu tree Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sat Mar 4 16:54:25 2006 @@ -154,7 +154,6 @@ (increment-menuitem-id tc) (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) - (setf (slot-value item 'gfi:handle) hmenu) (put-menuitem tc item) (vector-push-extend item (items parent)) (put-widget tc submenu) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Mar 4 16:54:25 2006 @@ -40,7 +40,7 @@ (:documentation "If the object is visible, move it to the top of the display z-order and request the window manager to set it active.")) (defgeneric alignment (object) - (:documentation "Returns an integer describing the position of internal content within the object.")) + (:documentation "Returns a keyword symbol describing the position of internal content within the object.")) (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) 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 Sat Mar 4 16:54:25 2006 @@ -56,8 +56,8 @@ (error 'gfi:disposed-error))) (defmethod clear-span ((w widget-with-items) (sp gfi:span)) - (loop for index from (gfi:span-start sp) to (gfi:span-end sp) - collect (clear-item w 0))) + (dotimes (i (1+ (- (gfi:span-end sp) (gfi:span-start sp)))) + (clear-item w (gfi:span-start sp)))) (defmethod item-at :before ((w widget-with-items) index) (declare (ignore index)) From junrue at common-lisp.net Sun Mar 5 23:36:31 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 5 Mar 2006 18:36:31 -0500 (EST) Subject: [graphic-forms-cvs] r28 - in trunk/src/third-party: . lw-compat Message-ID: <20060305233631.180F477000@common-lisp.net> Author: junrue Date: Sun Mar 5 18:36:30 2006 New Revision: 28 Added: trunk/src/third-party/ trunk/src/third-party/lw-compat/ trunk/src/third-party/lw-compat/lw-compat-package.lisp trunk/src/third-party/lw-compat/lw-compat.asd trunk/src/third-party/lw-compat/lw-compat.lisp Log: added local copy of lw-compat lib written by Pascal Costanza Added: trunk/src/third-party/lw-compat/lw-compat-package.lisp ============================================================================== --- (empty file) +++ trunk/src/third-party/lw-compat/lw-compat-package.lisp Sun Mar 5 18:36:30 2006 @@ -0,0 +1,34 @@ +;;;; +;;;; Copyright (c) 2005 Pascal Costanza +;;;; with permission from http://www.lispworks.com +;;;; +;;;; 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. +;;;; + +;;; (in-package :cl-user) +(in-package #:graphic-forms-system) + +#-lispworks +(defpackage #:lispworks + (:use #:common-lisp) + (:export #:appendf #:nconcf #:rebinding #:removef + #:when-let #:when-let* #:with-unique-names)) Added: trunk/src/third-party/lw-compat/lw-compat.asd ============================================================================== --- (empty file) +++ trunk/src/third-party/lw-compat/lw-compat.asd Sun Mar 5 18:36:30 2006 @@ -0,0 +1,36 @@ +(in-package :cl-user) + +(asdf:defsystem #:lw-compat + :name "LispWorks Compatibility Library" + :author "Pascal Costanza, with permission from http://www.lispworks.com" + :version "0.2" + :licence " +Copyright (c) 2005 Pascal Costanza +with permission from http://www.lispworks.com + +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. +" + :components (#-lispworks + (:file "lw-compat-package") + #-lispworks + (:file "lw-compat" + :depends-on ("lw-compat-package")))) Added: trunk/src/third-party/lw-compat/lw-compat.lisp ============================================================================== --- (empty file) +++ trunk/src/third-party/lw-compat/lw-compat.lisp Sun Mar 5 18:36:30 2006 @@ -0,0 +1,76 @@ +;;;; +;;;; Copyright (c) 2005 Pascal Costanza +;;;; with permission from http://www.lispworks.com +;;;; +;;;; 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. +;;;; + +(in-package #:lispworks) + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "lw-compat is not needed in LispWorks.")) + +(define-modify-macro appendf (&rest lists) + append "Appends lists to the end of given list.") + +(define-modify-macro nconcf (&rest lists) + nconc "Appends lists to the end of given list by NCONC.") + +(defmacro rebinding (vars &body body) + "Ensures unique names for all the variables in a groups of forms." + (loop for var in vars + for name = (gensym (symbol-name var)) + collect `(,name ,var) into renames + collect ``(,,var ,,name) into temps + finally (return `(let ,renames + (with-unique-names + ,vars + `(let (,, at temps) + ,, at body)))))) + +(define-modify-macro removef (item &rest keys) + (lambda (place item &rest keys &key test test-not start end key) + (declare (ignorable test test-not start end key)) + (apply #'remove item place keys)) + "Removes an item from a sequence.") + +(defmacro when-let ((var form) &body body) + "Executes a body of code if a form evaluates to non-nil, + propagating the result of the form through the body of code." + `(let ((,var ,form)) + (when ,var + (locally + , at body)))) + +(defmacro when-let* (bindings &body body) + "Executes a body of code if a series of forms evaluates to non-nil, + propagating the results of the forms through the body of code." + (loop for form = `(progn , at body) then `(when-let (,(car binding) ,(cadr binding)) ,form) + for binding in (reverse bindings) + finally (return form))) + +(defmacro with-unique-names (names &body body) + "Returns a body of code with each specified name bound to a similar name." + `(let ,(mapcar (lambda (name) `(,name (gensym ,(symbol-name name)))) + names) + , at body)) From junrue at common-lisp.net Sun Mar 5 23:37:13 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 5 Mar 2006 18:37:13 -0500 (EST) Subject: [graphic-forms-cvs] r29 - trunk Message-ID: <20060305233713.770BA77000@common-lisp.net> Author: junrue Date: Sun Mar 5 18:37:13 2006 New Revision: 29 Modified: trunk/graphic-forms-uitoolkit.asd Log: added local copy of lw-compat lib written by Pascal Costanza Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 5 18:37:13 2006 @@ -45,7 +45,14 @@ :components ((:module "src" :components - ((:file "packages") + ((:module "third-party" + :components + ((:module "lw-compat" + :components + (#-lispworks (:file "lw-compat-package") + #-lispworks (:file "lw-compat" + :depends-on ("lw-compat-package")))))) + (:file "packages") (:module "intrinsics" :depends-on ("packages") :components From junrue at common-lisp.net Mon Mar 6 03:45:38 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 5 Mar 2006 22:45:38 -0500 (EST) Subject: [graphic-forms-cvs] r30 - trunk/src/third-party Message-ID: <20060306034538.EDD4854055@common-lisp.net> Author: junrue Date: Sun Mar 5 22:45:38 2006 New Revision: 30 Removed: trunk/src/third-party/ Log: changed my mind about importing lw-compat From junrue at common-lisp.net Mon Mar 6 03:57:40 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 5 Mar 2006 22:57:40 -0500 (EST) Subject: [graphic-forms-cvs] r31 - trunk Message-ID: <20060306035740.BE24254060@common-lisp.net> Author: junrue Date: Sun Mar 5 22:57:40 2006 New Revision: 31 Modified: trunk/graphic-forms-uitoolkit.asd Log: changed my mind about importing lw-compat Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 5 22:57:40 2006 @@ -45,14 +45,7 @@ :components ((:module "src" :components - ((:module "third-party" - :components - ((:module "lw-compat" - :components - (#-lispworks (:file "lw-compat-package") - #-lispworks (:file "lw-compat" - :depends-on ("lw-compat-package")))))) - (:file "packages") + ((:file "packages") (:module "intrinsics" :depends-on ("packages") :components @@ -100,6 +93,7 @@ (:file "event-generics") (:file "layout-generics") (:file "widget-generics") + (:file "event-dispatcher") (:file "widget-utils") (:file "item") (:file "widget") From junrue at common-lisp.net Mon Mar 6 07:16:31 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 6 Mar 2006 02:16:31 -0500 (EST) Subject: [graphic-forms-cvs] r32 - in trunk: . src src/uitoolkit/widgets Message-ID: <20060306071631.3DB5352000@common-lisp.net> Author: junrue Date: Mon Mar 6 02:16:30 2006 New Revision: 32 Added: trunk/src/uitoolkit/widgets/event-dispatcher.lisp Modified: trunk/build.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layouts.lisp Log: implemented backend to support :callbacks initarg for event-source instances Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Mar 6 02:16:30 2006 @@ -39,36 +39,40 @@ (defvar *external-build-dirs* nil) -(defvar *library-root* "c:/projects/third_party/") -(defvar *project-root* "c:/projects/public/") +(defvar *library-root* "c:/projects/third_party/") +(defvar *project-root* "c:/projects/public/") -(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) +(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) -(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) -(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) -(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) -(defvar *cldoc-dir* (concatenate 'string *asdf-root* "cldoc/")) - -(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") -(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) +(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) +(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) +(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) +(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) + +(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") +(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) (defvar *asdf-dirs* (list *cffi-dir* + *closer-mop-dir* + *lw-compat-dir* *pcl-ch08-dir* *pcl-ch24-dir* - *cldoc-dir* *gf-dir*)) -(defvar *library-build-root* (concatenate 'string *library-root* "build/")) -(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) -(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/")) -(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/")) -(defvar *cldoc-build-dir* (concatenate 'string *library-build-root* "cldoc/")) +(defvar *library-build-root* (concatenate 'string *library-root* "build/")) +(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) +(defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/")) +(defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/")) +(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/")) +(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/")) (defvar *build-dirs* (list *cffi-build-dir* + *closer-mop-build-dir* + *lw-compat-build-dir* *pcl-ch08-build-dir* *pcl-ch24-build-dir* - *cldoc-build-dir* *gf-build-dir*)) #+lispworks (defmacro chdir (path) @@ -87,6 +91,18 @@ (asdf:operate 'asdf:load-op :cffi) (if *external-build-dirs* + (chdir *lw-compat-build-dir*)) + (asdf:operate 'asdf:load-op :lw-compat) + + (if *external-build-dirs* + (chdir *closer-mop-build-dir*)) + (asdf:operate 'asdf:load-op :closer-mop) + + (if *external-build-dirs* + (chdir *cffi-build-dir*)) + (asdf:operate 'asdf:load-op :cffi) + + (if *external-build-dirs* (chdir *pcl-ch08-build-dir*)) (asdf:operate 'asdf:load-op :macro-utilities) @@ -97,14 +113,3 @@ (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) - -;;; FIXME: reference to :cldoc below can't be satisfied yet when -;;; this file is loaded -#| -(defun build-docs () - (chdir *gf-doc-dir*) - (load "c:/projects/third_party/asdf-repo/cldoc/src/cldoc.asd") - (asdf:operate 'asdf:load-op :cldoc) - (let ((fn (find-symbol "EXTRACT-DOCUMENTATION" :cldoc))) - (funcall fn 'cldoc:html *gf-doc-dir* (asdf:find-system 'graphic-forms-uitoolkit)))) -|# Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 6 02:16:30 2006 @@ -431,7 +431,7 @@ #:size #:startup #:step-increment - #:style + #:style-of #:sub-menu #:text #:text-height Added: trunk/src/uitoolkit/widgets/event-dispatcher.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/event-dispatcher.lisp Mon Mar 6 02:16:30 2006 @@ -0,0 +1,89 @@ +;;;; +;;;; event-dispatcher.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) + +(defun dispatcher-for-activate-callback (class fn) + (lispworks:with-unique-names (arg0 arg1 arg2) + (let ((gf (clos:ensure-generic-function 'gfw:event-activate + :lambda-list (list arg0 arg1 arg2)))) + (c2mop:ensure-method gf + `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2)) + :specializers (list class + (find-class 'gfw:event-source) + (find-class 'integer)))))) + +(defun dispatcher-for-arm-callback (class fn) + (lispworks:with-unique-names (arg0 arg1 arg2) + (let ((gf (clos:ensure-generic-function 'gfw:event-arm + :lambda-list (list arg0 arg1 arg2)))) + (c2mop:ensure-method gf + `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2)) + :specializers (list class + (find-class 'gfw:event-source) + (find-class 'integer)))))) + +(defun dispatcher-for-select-callback (class fn) + (lispworks:with-unique-names (arg0 arg1 arg2 arg4) + (let ((gf (clos:ensure-generic-function 'gfw:event-select + :lambda-list (list arg0 arg1 arg2 arg4)))) + (c2mop:ensure-method gf + `(lambda (,arg0 ,arg1 ,arg2 ,arg4) (funcall ,fn ,arg0 ,arg1 ,arg2 ,arg4)) + :specializers (list class + (find-class 'gfw:item) + (find-class 'integer) + (find-class 'gfi:rectangle)))))) + +(defun defdispatcher (callbacks) + (let ((class (clos:ensure-class (gensym "EDCLASS") :direct-superclasses '(event-dispatcher)))) + (loop for pair in callbacks + do (cond + ((eq (car pair) 'gfw:event-activate) + (dispatcher-for-activate-callback class (cdr pair))) + ((eq (car pair) 'gfw:event-arm) + (dispatcher-for-arm-callback class (cdr pair))) + ((eq (car pair) 'gfw:event-select) + (dispatcher-for-select-callback class (cdr pair))) + (t + (error 'gfs:toolkit-error :detail (format nil "unsupported event method for callbacks: ~a" + (car pair)))))) + class)) + +(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys) + "The :callbacks parameter specifies an association list where the CAR is the \ +name of an event-* method (e.g., event-select) and the CDR is a function \ +pointer. As such, this constitutes a specification for a new event-dispatcher \ +object and associated methods." + (unless (null callbacks) + (let ((class (defdispatcher callbacks))) + (setf (dispatcher src) (make-instance (class-name class)))))) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Mon Mar 6 02:16:30 2006 @@ -35,7 +35,7 @@ (defclass layout-manager () ((style - :accessor style + :accessor style-of :initarg :style :initform nil)) (:documentation "Subclasses implement layout strategies on behalf of window objects.")) Modified: trunk/src/uitoolkit/widgets/layouts.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layouts.lisp (original) +++ trunk/src/uitoolkit/widgets/layouts.lisp Mon Mar 6 02:16:30 2006 @@ -76,7 +76,7 @@ (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) (let ((max -1) (total 0) - (vert-orient (find :vertical (gfw:style layout)))) + (vert-orient (find :vertical (style-of layout)))) (with-children (win kids) (loop for k in kids do (let ((kid-size (preferred-size k @@ -100,7 +100,7 @@ (let ((entries nil) (last-coord 0) (last-dim 0) - (vert-orient (find :vertical (gfw:style layout)))) + (vert-orient (find :vertical (style-of layout)))) (with-children (win kids) (loop for k in kids do (let ((kid-size (preferred-size k @@ -128,5 +128,5 @@ (unless (listp style) (setf style (list style))) (if (and (null (find :horizontal style)) (null (find :vertical style))) - (setf (slot-value layout 'style) '(:horizontal)) - (setf (slot-value layout 'style) style))) + (setf (style-of layout) '(:horizontal)) + (setf (style-of layout) style))) From junrue at common-lisp.net Wed Mar 8 21:42:25 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 8 Mar 2006 16:42:25 -0500 (EST) Subject: [graphic-forms-cvs] r33 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060308214225.3F6CD4D012@common-lisp.net> Author: junrue Date: Wed Mar 8 16:42:24 2006 New Revision: 33 Added: trunk/src/uitoolkit/widgets/event-source.lisp - copied, changed from r32, trunk/src/uitoolkit/widgets/event-dispatcher.lisp Removed: trunk/src/uitoolkit/widgets/event-dispatcher.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/menu-language.lisp Log: implemented and debugged :callback option for menu language Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Mar 8 16:42:24 2006 @@ -93,7 +93,7 @@ (:file "event-generics") (:file "layout-generics") (:file "widget-generics") - (:file "event-dispatcher") + (:file "event-source") (:file "widget-utils") (:file "item") (:file "widget") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Mar 8 16:42:24 2006 @@ -33,6 +33,16 @@ (in-package #:graphic-forms-system) +;;; +;;; destination for unique symbols generated by the library +;;; +(defpackage #:graphic-forms.generated + (:nicknames #:gfgen) + (:use #:common-lisp)) + +;;; +;;; package for fundamental stuff shared across the library +;;; (defpackage #:graphic-forms.intrinsics (:nicknames #:gfi) (:use #:common-lisp) @@ -69,6 +79,9 @@ ;; conditions #:disposed-error)) +;;; +;;; package for system-level functionality +;;; (defpackage #:graphic-forms.uitoolkit.system (:nicknames #:gfs) (:shadow #:atom #:boolean) @@ -91,6 +104,9 @@ #:win32-error #:win32-warning)) +;;; +;;; package for graphics functionality +;;; (defpackage #:graphic-forms.uitoolkit.graphics (:nicknames #:gfg) (:shadow #:load #:type) @@ -195,6 +211,9 @@ ;; conditions )) +;;; +;;; package for UI objects +;;; (defpackage #:graphic-forms.uitoolkit.widgets (:nicknames #:gfw) (:use #:common-lisp) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Mar 8 16:42:24 2006 @@ -48,23 +48,21 @@ (exit-hello-world)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignorable window time ignore rect)) + (declare (ignorable window time rect)) (setf (gfg:background-color gc) gfg:+color-red+) (setf (gfg:foreground-color gc) gfg:+color-green+) (gfg:draw-text gc "Hello World!" (gfi:make-point))) -(defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-select ((d hellowin-exit-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defun exit-fn (disp item time rect) + (declare (ignorable disp item time rect)) (exit-hello-world)) (defun run-hello-world-internal () - (let ((menubar nil) - (disp (make-instance 'hellowin-exit-dispatcher))) + (let ((menubar nil)) (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) (gfw:realize *hellowin* nil :style-workspace) - (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :dispatcher disp)))))) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hellowin*) menubar) (gfw:show *hellowin* t))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Mar 8 16:42:24 2006 @@ -157,10 +157,8 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) -(defclass flow-modifier-menu-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-activate ((d flow-modifier-menu-dispatcher) menu time) - (declare (ignore time)) +(defun flow-mod-callback (disp menu time) + (declare (ignore disp time)) (gfw:clear-all menu) (let ((it nil) (margin-menu (gfw:defmenusystem ((:item "Top" @@ -186,29 +184,26 @@ (gfw:check it t) (gfw:append-item menu "Wrap" nil nil))) -(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defun exit-layout-callback (disp item time rect) + (declare (ignorable disp item time rect)) (exit-layout-tester)) (defun run-layout-tester-internal () (setf *widget-counter* 0) (let ((menubar nil) - (exit-disp (make-instance 'layout-tester-exit-dispatcher)) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher - :check-test-fn #'gfw:visible-p)) - (mod-layout-menu-disp (make-instance 'flow-modifier-menu-dispatcher))) + :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" - :submenu ((:item "E&xit" :dispatcher exit-disp))) + :submenu ((:item "E&xit" + :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) @@ -218,7 +213,7 @@ (:item "Visible" :dispatcher vis-menu-disp :submenu ((:item ""))))) (:item "&Window" - :submenu ((:item "Modify Layout" :dispatcher mod-layout-menu-disp + :submenu ((:item "Modify Layout" :callback #'flow-mod-callback :submenu ((:item ""))) (:item "Select Layout" :submenu ((:item "Flow"))) Copied: trunk/src/uitoolkit/widgets/event-source.lisp (from r32, trunk/src/uitoolkit/widgets/event-dispatcher.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/event-dispatcher.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Wed Mar 8 16:42:24 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; event-dispatcher.lisp +;;;; event-source.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -33,50 +33,36 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defun dispatcher-for-activate-callback (class fn) - (lispworks:with-unique-names (arg0 arg1 arg2) - (let ((gf (clos:ensure-generic-function 'gfw:event-activate - :lambda-list (list arg0 arg1 arg2)))) - (c2mop:ensure-method gf - `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2)) - :specializers (list class - (find-class 'gfw:event-source) - (find-class 'integer)))))) - -(defun dispatcher-for-arm-callback (class fn) - (lispworks:with-unique-names (arg0 arg1 arg2) - (let ((gf (clos:ensure-generic-function 'gfw:event-arm - :lambda-list (list arg0 arg1 arg2)))) - (c2mop:ensure-method gf - `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2)) - :specializers (list class - (find-class 'gfw:event-source) - (find-class 'integer)))))) - -(defun dispatcher-for-select-callback (class fn) - (lispworks:with-unique-names (arg0 arg1 arg2 arg4) - (let ((gf (clos:ensure-generic-function 'gfw:event-select - :lambda-list (list arg0 arg1 arg2 arg4)))) - (c2mop:ensure-method gf - `(lambda (,arg0 ,arg1 ,arg2 ,arg4) (funcall ,fn ,arg0 ,arg1 ,arg2 ,arg4)) - :specializers (list class - (find-class 'gfw:item) - (find-class 'integer) - (find-class 'gfi:rectangle)))))) - -(defun defdispatcher (callbacks) - (let ((class (clos:ensure-class (gensym "EDCLASS") :direct-superclasses '(event-dispatcher)))) +(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) + (gfw:event-arm . (gfw:event-source integer)) + (gfw:event-select . (gfw:item integer gfi:rectangle)))) + +(defun make-specializer-list (disp-class arg-info) + (let ((tmp (mapcar #'find-class arg-info))) + (push disp-class tmp) + tmp)) + +(defun define-dispatcher (callbacks) + (let* ((*print-gensym* nil) + (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks - do (cond - ((eq (car pair) 'gfw:event-activate) - (dispatcher-for-activate-callback class (cdr pair))) - ((eq (car pair) 'gfw:event-arm) - (dispatcher-for-arm-callback class (cdr pair))) - ((eq (car pair) 'gfw:event-select) - (dispatcher-for-select-callback class (cdr pair))) - (t - (error 'gfs:toolkit-error :detail (format nil "unsupported event method for callbacks: ~a" - (car pair)))))) + do (let* ((method-sym (car pair)) + (fn (cdr pair)) + (arg-info (cdr (assoc method-sym +callback-info+))) + (args nil)) + `(unless (or (symbolp ,fn) (functionp ,fn)) + (error 'gfs:toolkit-error + :detail "callback must be function or symbol naming function")) + (if (null arg-info) + (error 'gfs:toolkit-error :detail (format nil + "unsupported event method for callbacks: ~a" + 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) + `(lambda ,args (funcall ,fn , at args)) + :specializers (make-specializer-list class arg-info)))) class)) (defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys) @@ -85,5 +71,5 @@ pointer. As such, this constitutes a specification for a new event-dispatcher \ object and associated methods." (unless (null callbacks) - (let ((class (defdispatcher callbacks))) + (let ((class (define-dispatcher callbacks))) (setf (dispatcher src) (make-instance (class-name class)))))) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Wed Mar 8 16:42:24 2006 @@ -41,7 +41,7 @@ (gfw:defmenusystem ((:item "&File" :submenu ((:item "&Open...") (:item "&Save..." :disabled) (:item :separator) - (:item "E&xit"))) + (:item "E&xit" :callback #'some-fn))) (:item "&Options" :submenu ((:item "&Enabled" :checked) (:item "&Tools" :submenu ((:item "&Fonts" :disabled) (:item "&Colors"))))) @@ -49,7 +49,7 @@ |# ;;; -;;; basic infrastructure +;;; base class and generic functions ;;; (defclass base-menu-generator () @@ -80,10 +80,15 @@ (and (consp form) (eq (car form) :item))) +;;; +;;; menu system form parser +;;; + (defun process-item-form (form generator-sym) (if (not (item-form-p form)) (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" form))) - (let ((cmds nil) + (let ((callback nil) + (code nil) (checked nil) (disabled nil) (disp nil) @@ -91,14 +96,20 @@ (label nil) (sep nil) (sub nil) + (cb-tmp nil) (disp-tmp nil) (image-tmp nil) (sub-tmp nil)) (loop for opt in form do (cond + ((not (null cb-tmp)) + (setf callback opt) + (setf cb-tmp nil) + (setf disp nil)) ((not (null disp-tmp)) (setf disp opt) - (setf disp-tmp nil)) + (setf disp-tmp nil) + (setf callback nil)) ((not (null image-tmp)) (setf image opt) (setf image-tmp nil)) @@ -107,6 +118,8 @@ (setf sub-tmp nil)) ((and (not (eq opt :item)) (null label)) (setf label opt)) + ((eq opt :callback) + (setf cb-tmp t)) ((eq opt :checked) (setf checked t)) ((eq opt :disabled) @@ -131,6 +144,14 @@ (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:event-activate . ,,callback))))) + (setf disp `(make-instance (define-dispatcher `((gfw:event-select . ,,callback))))))) (when disp (if sep (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators")) @@ -140,35 +161,39 @@ (if (or checked image sep (not (listp sub))) (error 'gfs:toolkit-error :detail "invalid option for submenu"))) (cond - (sep (push `(define-separator ,generator-sym) cmds)) + (sep (push `(define-separator ,generator-sym) code)) (sub (push `(define-submenu ,generator-sym ,label ,disp - ,disabled) cmds) + ,disabled) code) (loop for subform in sub - do (setf cmds (append (process-item-form subform generator-sym) cmds))) - (push `(complete-submenu ,generator-sym) cmds)) + do (setf code (append (process-item-form subform generator-sym) code))) + (push `(complete-submenu ,generator-sym) code)) (t (push `(define-item ,generator-sym ,label ,disp ,disabled ,checked - ,image) cmds))) - cmds)) + ,image) code))) + code)) + +;;; +;;; code generation +;;; (defun generate-menusystem-code (sexp generator-sym) - (let ((cmds nil)) + (let ((code nil)) (mapcar #'(lambda (var) - (setf cmds (append (process-item-form var generator-sym) cmds))) + (setf code (append (process-item-form var generator-sym) code))) sexp) - (reverse cmds))) + (reverse code))) (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)))) (put-widget (thread-context) m) - (setf (menu-stack-of gen) (list m)))) + (push m (menu-stack-of gen)))) (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) (let* ((owner (first (menu-stack-of gen))) @@ -195,9 +220,12 @@ (defmethod complete-submenu ((gen win32-menu-generator)) (pop (menu-stack-of gen))) +;;; +;;; top-level API for the menu language +;;; + (defmacro defmenusystem (sexp) - (let* ((gen (gensym)) - (cmds (generate-menusystem-code sexp gen))) + (let ((gen (gensym))) `(let ((,gen (make-instance 'win32-menu-generator))) - , at cmds + ,@(generate-menusystem-code sexp gen) (pop (menu-stack-of ,gen))))) From junrue at common-lisp.net Thu Mar 9 16:45:11 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 9 Mar 2006 11:45:11 -0500 (EST) Subject: [graphic-forms-cvs] r34 - in trunk/src: . tests/uitoolkit uitoolkit/widgets Message-ID: <20060309164511.DCDFC4100F@common-lisp.net> Author: junrue Date: Thu Mar 9 11:45:11 2006 New Revision: 34 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/thread-context.lisp Log: update menu append-item to support callback functions in addition to dispatchers Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Mar 9 11:45:11 2006 @@ -34,7 +34,7 @@ (in-package #:graphic-forms-system) ;;; -;;; destination for unique symbols generated by the library +;;; destination for unique symbols generated by GENTEMP ;;; (defpackage #:graphic-forms.generated (:nicknames #:gfgen) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Mar 9 11:45:11 2006 @@ -182,7 +182,7 @@ (gfw:append-submenu menu "Spacing" spacing-menu) (setf it (gfw:append-item menu "Fill" nil nil)) (gfw:check it t) - (gfw:append-item menu "Wrap" nil nil))) + (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2))))) (defun exit-layout-callback (disp item time rect) (declare (ignorable disp item time rect)) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Thu Mar 9 11:45:11 2006 @@ -142,6 +142,20 @@ (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) + (let ((item nil)) + (cond + ((null disp) + (setf item (make-instance 'menu-item :handle hmenu))) + ((functionp disp) + (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp))))) + ((typep disp 'gfw:event-dispatcher) + (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp))) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) + item)) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Mar 9 11:45:11 2006 @@ -132,13 +132,11 @@ (defmethod append-item ((owner menu) text image disp) (let* ((tc (thread-context)) - (item (make-instance 'menu-item :dispatcher disp)) - (id (next-menuitem-id tc)) - (hmenu (gfi:handle owner))) - (increment-menuitem-id tc) + (id (increment-menuitem-id tc)) + (hmenu (gfi:handle owner)) + (item (create-menuitem-with-callback hmenu disp))) (insert-menuitem hmenu id text (cffi:null-pointer)) (setf (item-id item) id) - (setf (slot-value item 'gfi:handle) hmenu) (put-menuitem tc item) (vector-push-extend item (items owner)) item)) @@ -147,11 +145,10 @@ (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu)) (error 'gfi:disposed-error)) (let* ((tc (thread-context)) - (id (next-menuitem-id tc)) + (id (increment-menuitem-id tc)) (hparent (gfi:handle parent)) (hmenu (gfi:handle submenu)) (item (make-instance 'menu-item :handle hparent))) - (increment-menuitem-id tc) (insert-submenu hparent id text (cffi:null-pointer) hmenu) (setf (item-id item) id) (put-menuitem tc item) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Mar 9 11:45:11 2006 @@ -129,5 +129,7 @@ (slot-value tc 'menuitems-by-id))) (defmethod increment-menuitem-id ((tc thread-context)) - "Bump up the next menu item ID." - (incf (slot-value tc 'next-menuitem-id))) + "Return the next menu item ID; also increment the internal value." + (let ((id (next-menuitem-id tc))) + (incf (slot-value tc 'next-menuitem-id)) + id)) From junrue at common-lisp.net Mon Mar 13 00:19:37 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 12 Mar 2006 19:19:37 -0500 (EST) Subject: [graphic-forms-cvs] r35 - in trunk: . src/intrinsics/datastructs src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060313001937.708F62100D@common-lisp.net> Author: junrue Date: Sun Mar 12 19:19:36 2006 New Revision: 35 Added: trunk/src/intrinsics/datastructs/datastruct.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp - copied, changed from r32, trunk/src/uitoolkit/widgets/layouts.lisp Removed: trunk/src/uitoolkit/widgets/layouts.lisp Modified: trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/tests/uitoolkit/layout-tester.lisp trunk/tests.lisp Log: flow layout unit-test code; bug fixes for vertical flow layout style Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 12 19:19:36 2006 @@ -49,6 +49,8 @@ :components ((:module "uitoolkit" :components - ((:file "hello-world") + ((:file "mock-objects") + (:file "layout-unit-tests") + (:file "hello-world") (:file "event-tester") (:file "layout-tester"))))))))) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 12 19:19:36 2006 @@ -51,7 +51,8 @@ :components ((:module "datastructs" :components - ((:file "datastruct-classes"))) + ((:file "datastruct-classes") + (:file "datastruct"))) (:module "system" :components ((:file "native-classes") @@ -106,4 +107,5 @@ (:file "menu-language") (:file "event") (:file "window") - (:file "layouts"))))))))) + (:file "layout") + (:file "flow-layout"))))))))) Added: trunk/src/intrinsics/datastructs/datastruct.lisp ============================================================================== --- (empty file) +++ trunk/src/intrinsics/datastructs/datastruct.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; datastruct.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.intrinsics) + +(defmethod print-object ((obj rectangle) stream) + (print-unreadable-object (obj stream :type t) + (format stream "location: ~a size: ~a" (location obj) (size obj)))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 19:19:36 2006 @@ -157,6 +157,18 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) +(defun set-flow-horizontal (disp item time rect) + (declare (ignorable disp item time rect)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (setf (gfw:style-of layout) (list :horizontal)) + (gfw:layout *layout-tester-win*))) + +(defun set-flow-vertical (disp item time rect) + (declare (ignorable disp item time rect)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (setf (gfw:style-of layout) (list :vertical)) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) @@ -173,8 +185,10 @@ (:item "Bottom" :submenu ((:item "Decrease") (:item "Increase")))))) - (orient-menu (gfw:defmenusystem ((:item "Horizontal") - (:item "Vertical")))) + (orient-menu (gfw:defmenusystem ((:item "Horizontal" + :callback #'set-flow-horizontal) + (:item "Vertical" + :callback #'set-flow-vertical)))) (spacing-menu (gfw:defmenusystem ((:item "Decrease") (:item "Increase"))))) (gfw:append-submenu menu "Margin" margin-menu) Added: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,81 @@ +;;;; +;;;; 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 *minsize1* (gfi:make-size :width 20 :height 10)) +(defvar *flow-layout-kids1* (list (make-instance 'mock-widget :min-size *minsize1*) + (make-instance 'mock-widget :min-size *minsize1*) + (make-instance 'mock-widget :min-size *minsize1*))) + +(defun validate-layout-points (actual-entries expected-pnts) + (mapc #'(lambda (pnt entry) + (let ((pnt2 (gfi:location (cdr entry)))) + (assert-true (and (= (gfi:point-x pnt) (gfi:point-x pnt2)) + (= (gfi:point-y pnt) (gfi:point-y pnt2)))))) + expected-pnts + actual-entries)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; wrap: disabled + ;; fill: disabled + ;; container: visible + ;; kids: uniform + ;; + (let* ((size (gfw::flow-container-size '(:horizontal) t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout '(:horizontal) t *flow-layout-kids1* -1 -1)) + (expected-pnts nil)) + (push (gfi:make-point :x 40 :y 0) expected-pnts) + (push (gfi:make-point :x 20 :y 0) expected-pnts) + (push (gfi:make-point :x 0 :y 0) expected-pnts) + (assert-equal 60 (gfi:size-width size)) + (assert-equal 10 (gfi:size-height size)) + (validate-layout-points actual expected-pnts))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; wrap: disabled + ;; fill: disabled + ;; container: visible + ;; kids: uniform + ;; + (let* ((size (gfw::flow-container-size '(:vertical) t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout '(:vertical) t *flow-layout-kids1* -1 -1)) + (expected-pnts nil)) + (push (gfi:make-point :x 0 :y 20) expected-pnts) + (push (gfi:make-point :x 0 :y 10) expected-pnts) + (push (gfi:make-point :x 0 :y 0) expected-pnts) + (assert-equal 20 (gfi:size-width size)) + (assert-equal 30 (gfi:size-height size)) + (validate-layout-points actual expected-pnts))) Added: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,79 @@ +;;;; +;;;; mock-objects.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) + +(defconstant +max-widget-size+ 5000) + +;;; +;;; stand-ins for widgets that would be children of windows, to be organized +;;; via layout managers +;;; + +(defclass mock-widget (gfw:widget) + ((visibility + :accessor visibility-of + :initform t) + (actual-size + :accessor actual-size-of + :initarg :actual-size + :initform (gfi:make-size)) + (max-size + :accessor max-size-of + :initarg :max-size + :initform (gfi:make-size :width +max-widget-size+ :height +max-widget-size+)) + (min-size + :accessor min-size-of + :initarg :min-size + :initform (gfi:make-size)))) + +(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys) + (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) + +(defmethod gfw:minimum-size ((widget mock-widget)) + (gfi:make-size :width (gfi:size-width (min-size-of widget)) + :height (gfi:size-height (min-size-of widget)))) + +(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) + (let ((size (gfi:make-size)) + (min-size (min-size-of widget))) + (if (< width-hint 0) + (setf (gfi:size-width size) (gfi:size-width min-size)) + (setf (gfi:size-width size) width-hint)) + (if (< height-hint 0) + (setf (gfi:size-height size) (gfi:size-height min-size)) + (setf (gfi:size-height size) height-hint)) + size)) + +(defmethod gfw:visible-p ((widget mock-widget)) + (visibility-of widget)) Added: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,109 @@ +;;;; +;;;; flow-layout.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) + +;;; +;;; helper functions +;;; + +(defun flow-container-size (style win-visible kids width-hint height-hint) + (let ((max -1) + (total 0) + (vert-orient (find :vertical style))) + (loop for kid in kids + do (let ((size (preferred-size kid + (if vert-orient width-hint -1) + (if vert-orient -1 height-hint)))) + (when (or (visible-p kid) (not win-visible)) + (if vert-orient + (progn + (incf total (gfi:size-height size)) + (if (< max (gfi:size-width size)) + (setf max (gfi:size-width size)))) + (progn + (incf total (gfi:size-width size)) + (if (< max (gfi:size-height size)) + (setf max (gfi:size-height size)))))))) + (if vert-orient + (gfi:make-size :width max :height total) + (gfi:make-size :width total :height max)))) + +(defun flow-container-layout (style win-visible kids width-hint height-hint) + (let ((entries nil) + (last-coord 0) + (last-dim 0) + (vert-orient (find :vertical style))) + (loop for kid in kids + do (let ((size (preferred-size kid + (if vert-orient width-hint -1) + (if vert-orient -1 height-hint))) + (pnt (gfi:make-point))) + (when (or (visible-p kid) (not win-visible)) + (if vert-orient + (progn + (setf (gfi:point-y pnt) (+ last-coord last-dim)) + (if (>= width-hint 0) + (setf (gfi:size-width size) width-hint)) + (setf last-coord (gfi:point-y pnt)) + (setf last-dim (gfi:size-height size))) + (progn + (setf (gfi:point-x pnt) (+ last-coord last-dim)) + (if (>= height-hint 0) + (setf (gfi:size-height size) height-hint)) + (setf last-coord (gfi:point-x pnt)) + (setf last-dim (gfi:size-width size)))) + (push (cons kid (make-instance 'gfi:rectangle + :size size + :location pnt)) + entries)))) + (reverse entries))) + +;;; +;;; methods +;;; + +(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) + (with-children (win kids) + (flow-container-size (style-of layout) (visible-p win) kids width-hint height-hint))) + +(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) + (with-children (win kids) + (flow-container-layout (style-of layout) (visible-p win) kids width-hint height-hint))) + +(defmethod initialize-instance :after ((layout flow-layout) &key style) + (unless (listp style) + (setf style (list style))) + (if (and (null (find :horizontal style)) (null (find :vertical style))) + (setf (style-of layout) '(:horizontal)) + (setf (style-of layout) style))) Copied: trunk/src/uitoolkit/widgets/layout.lisp (from r32, trunk/src/uitoolkit/widgets/layouts.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/layouts.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 19:19:36 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; layouts.lisp +;;;; layout.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -45,6 +45,7 @@ (hdwp nil)) (when (and (layout-p win) layout) (setf kids (compute-layout layout win width-hint height-hint)) +(loop for x in kids do (format t "~a~%" (cdr x))) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) @@ -68,65 +69,3 @@ +window-pos-flags+))))) (unless (gfi:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp))))) - -;;; -;;; flow-layout methods -;;; - -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((max -1) - (total 0) - (vert-orient (find :vertical (style-of layout)))) - (with-children (win kids) - (loop for k in kids - do (let ((kid-size (preferred-size k - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint)))) - (when (or (visible-p k) (not (visible-p win))) - (if (not vert-orient) - (progn - (incf total (gfi:size-width kid-size)) - (if (< max (gfi:size-height kid-size)) - (setf max (gfi:size-height kid-size)))) - (progn - (incf total (gfi:size-height kid-size)) - (if (< max (gfi:size-width kid-size)) - (setf max (gfi:size-width kid-size))))))))) - (if vert-orient - (gfi:make-size :width max :height total) - (gfi:make-size :width total :height max)))) - -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((entries nil) - (last-coord 0) - (last-dim 0) - (vert-orient (find :vertical (style-of layout)))) - (with-children (win kids) - (loop for k in kids - do (let ((kid-size (preferred-size k - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint))) - (pnt (gfi:make-point))) - (when (or (visible-p k) (not (visible-p win))) - (if (not vert-orient) - (progn - (setf (gfi:point-x pnt) (+ last-coord last-dim)) - (if (>= height-hint 0) - (setf (gfi:size-height kid-size) height-hint)) - (setf last-coord (gfi:point-x pnt)) - (setf last-dim (gfi:size-width kid-size))) - (progn - (setf (gfi:point-y pnt) (+ last-coord last-dim)) - (if (>= width-hint 0) - (setf (gfi:size-width kid-size) width-hint)) - (setf last-coord (gfi:point-y pnt)) - (setf last-dim (gfi:size-height kid-size)))) - (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))) - (reverse entries))) - -(defmethod initialize-instance :after ((layout flow-layout) &key style) - (unless (listp style) - (setf style (list style))) - (if (and (null (find :horizontal style)) (null (find :vertical style))) - (setf (style-of layout) '(:horizontal)) - (setf (style-of layout) style))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Mar 12 19:19:36 2006 @@ -33,15 +33,15 @@ (in-package #:graphic-forms-system) -(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp")) +(defvar *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) -(load (compile-file *lisp-unit-srcfile*)) +(load (compile-file *lisp-unit-file*)) (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit)) -(defun load-adhoc-tests () +(defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests)) From junrue at common-lisp.net Mon Mar 13 02:06:21 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 12 Mar 2006 21:06:21 -0500 (EST) Subject: [graphic-forms-cvs] r36 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060313020621.D49F059057@common-lisp.net> Author: junrue Date: Sun Mar 12 21:06:21 2006 New Revision: 36 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: enhance append-submenu so it can take callback or dispatcher Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 21:06:21 2006 @@ -157,6 +157,12 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) +(defun check-flow-orient-item (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) + (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) (let ((layout (gfw:layout-manager *layout-tester-win*))) @@ -191,9 +197,9 @@ :callback #'set-flow-vertical)))) (spacing-menu (gfw:defmenusystem ((:item "Decrease") (:item "Increase"))))) - (gfw:append-submenu menu "Margin" margin-menu) - (gfw:append-submenu menu "Orientation" orient-menu) - (gfw:append-submenu menu "Spacing" spacing-menu) + (gfw:append-submenu menu "Margin" margin-menu nil) + (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) + (gfw:append-submenu menu "Spacing" spacing-menu nil) (setf it (gfw:append-item menu "Fill" nil nil)) (gfw:check it t) (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2))))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 21:06:21 2006 @@ -87,7 +87,7 @@ :size size :location pnt)) entries)))) - (reverse entries))) + (nreverse entries))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 21:06:21 2006 @@ -45,7 +45,6 @@ (hdwp nil)) (when (and (layout-p win) layout) (setf kids (compute-layout layout win width-hint height-hint)) -(loop for x in kids do (format t "~a~%" (cdr x))) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Mar 12 21:06:21 2006 @@ -211,9 +211,9 @@ (vector-push-extend it (items owner)))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) + (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) (parent (first (menu-stack-of gen))) - (item (append-submenu parent label submenu))) + (item (append-submenu parent label submenu dispatcher))) (push submenu (menu-stack-of gen)) (enable item (not disabled)))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sun Mar 12 21:06:21 2006 @@ -141,7 +141,7 @@ (vector-push-extend item (items owner)) item)) -(defmethod append-submenu ((parent menu) text (submenu menu)) +(defmethod append-submenu ((parent menu) text (submenu menu) disp) (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu)) (error 'gfi:disposed-error)) (let* ((tc (thread-context)) @@ -154,6 +154,16 @@ (put-menuitem tc item) (vector-push-extend item (items parent)) (put-widget tc submenu) + (cond + ((null disp)) + ((functionp disp) + (let ((class (define-dispatcher `((event-activate . ,disp))))) + (setf (dispatcher submenu) (make-instance (class-name class))))) + ((typep disp 'gfw:event-dispatcher) + (setf (dispatcher submenu) disp)) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) item)) (defun menu-cleanup-callback (menu item) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Mar 12 21:06:21 2006 @@ -48,7 +48,7 @@ (defgeneric append-item (object text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) -(defgeneric append-submenu (object text submenu) +(defgeneric append-submenu (object text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) (defgeneric background-color (object) From junrue at common-lisp.net Mon Mar 13 05:40:49 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 13 Mar 2006 00:40:49 -0500 (EST) Subject: [graphic-forms-cvs] r37 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060313054049.BEEAC58343@common-lisp.net> Author: junrue Date: Mon Mar 13 00:40:49 2006 New Revision: 37 Added: trunk/docs/manual/ trunk/docs/manual/Makefile trunk/docs/manual/graphic-forms-reference.texinfo trunk/docs/manual/style.css Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: stub out reference manual Added: trunk/docs/manual/Makefile ============================================================================== --- (empty file) +++ trunk/docs/manual/Makefile Mon Mar 13 00:40:49 2006 @@ -0,0 +1,47 @@ +# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# +# Makefile +# +# 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. +# + +# +# TODO: upgrade MSYS version of makeinfo so "--css-include=style.css" works +# +docs: + makeinfo --html graphic-forms-reference.texinfo + +clean: + find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; + rm -rf graphic-forms-reference + +# +# TODO: implement an upload target +# Added: trunk/docs/manual/graphic-forms-reference.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/graphic-forms-reference.texinfo Mon Mar 13 00:40:49 2006 @@ -0,0 +1,155 @@ +\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*- + at c %**start of header + at setfilename graphic-forms-reference.info + at settitle Graphic-Forms Programming Reference + at exampleindent 2 + + at c @documentencoding utf-8 + + at c ============================= Macros ============================= + + at macro Function {args} + at defun \args\ + at end defun + at end macro + + at macro Macro {args} + at defmac \args\ + at end defmac + at end macro + + at macro Accessor {args} + at deffn {Accessor} \args\ + at end deffn + at end macro + + at macro GenericFunction {args} + at deffn {Generic Function} \args\ + at end deffn + at end macro + + at macro Variable {args} + at defvr {Special Variable} \args\ + at end defvr + at end macro + + at macro Condition {args} + at deftp {Condition Type} \args\ + at end deftp + at end macro + + at macro GFI + at acronym{GFW} + at end macro + + at macro GFG + at acronym{GFW} + at end macro + + at macro GFS + at acronym{GFW} + at end macro + + at macro GFW + at acronym{GFW} + at end macro + + at macro impnote {text} + at quotation + at strong{Implementor's note:} @emph{\text\} + at end quotation + at end macro + + at c Info "requires" that x-refs end in a period or comma, or ) in the + at c case of @pxref. So the following implements that requirement for + at c the "See also" subheadings that permeate this manual, but only in + at c Info mode. + at ifinfo + at macro seealso {name} + at ref{\name\}. + at end macro + at end ifinfo + + at ifnotinfo + at alias seealso = ref + at end ifnotinfo + + at c ==========================End Macros ============================= + + at c Show types, functions, and concepts in the same index. + at syncodeindex tp cp + at syncodeindex fn cp + + at copying +Copyright @copyright{} 2006, Jack D. Unrue @* + + at quotation +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. + + at sc{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 +DISCLAIMED. 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.} + at end quotation + at end copying + at c %**end of header + + at titlepage + at title Graphic-Forms Programming Reference + at c @subtitle Version 0.2.0 + at c @author Jack D. Unrue + + at page + at vskip 0pt plus 1filll + at insertcopying + at end titlepage + + at contents + + at ifnottex + at node Top + at top Graphic-Forms Programming Reference + at insertcopying + at end ifnottex + + at menu +* Introduction:: +* Known Issues:: + at end menu + + at c =================================================================== + at c CHAPTER: Introduction + + at node Introduction + at chapter Introduction + +This will be introductory discussion of the Graphic-Forms library. + + at c =================================================================== + at c CHAPTER: Known Issues + + at node Known Issues + at chapter Known Issues + +This will be a list of known issues in the library. + + at bye Added: trunk/docs/manual/style.css ============================================================================== --- (empty file) +++ trunk/docs/manual/style.css Mon Mar 13 00:40:49 2006 @@ -0,0 +1,48 @@ +body {font-family: century schoolbook, serif; + line-height: 1.3; + padding-left: 5em; padding-right: 1em; + padding-bottom: 1em; max-width: 60em;} +table {border-collapse: collapse} +span.roman { font-family: century schoolbook, serif; font-weight: normal; } +h1, h2, h3, h4, h5, h6 {font-family: Helvetica, sans-serif} +/*h4 {padding-top: 0.75em;}*/ +dfn {font-family: inherit; font-variant: italic; font-weight: bolder } +kbd {font-family: monospace; text-decoration: underline} +/*var {font-family: Helvetica, sans-serif; font-variant: slanted}*/ +var {font-variant: slanted;} +td {padding-right: 1em; padding-left: 1em} +sub {font-size: smaller} +.node {padding: 0; margin: 0} + +.lisp { font-family: monospace; + background-color: #F4F4F4; border: 1px solid #AAA; + padding-top: 0.5em; padding-bottom: 0.5em; } + +/* coloring */ + +.lisp-bg { background-color: #F4F4F4 ; color: black; } +.lisp-bg:hover { background-color: #F4F4F4 ; color: black; } + +.symbol { font-weight: bold; color: #770055; background-color : transparent; border: 0px; margin: 0px;} +a.symbol:link { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:active { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:visited { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +a.symbol:hover { font-weight: bold; color : #229955; background-color : transparent; text-decoration: none; border: 0px; margin: 0px; } +.special { font-weight: bold; color: #FF5000; background-color: inherit; } +.keyword { font-weight: bold; color: #770000; background-color: inherit; } +.comment { font-weight: normal; color: #007777; background-color: inherit; } +.string { font-weight: bold; color: #777777; background-color: inherit; } +.character { font-weight: bold; color: #0055AA; background-color: inherit; } +.syntaxerror { font-weight: bold; color: #FF0000; background-color: inherit; } +span.paren1 { font-weight: bold; color: #777777; } +span.paren1:hover { color: #777777; background-color: #BAFFFF; } +span.paren2 { color: #777777; } +span.paren2:hover { color: #777777; background-color: #FFCACA; } +span.paren3 { color: #777777; } +span.paren3:hover { color: #777777; background-color: #FFFFBA; } +span.paren4 { color: #777777; } +span.paren4:hover { color: #777777; background-color: #CACAFF; } +span.paren5 { color: #777777; } +span.paren5:hover { color: #777777; background-color: #CAFFCA; } +span.paren6 { color: #777777; } +span.paren6:hover { color: #777777; background-color: #FFBAFF; } 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 Mon Mar 13 00:40:49 2006 @@ -53,8 +53,9 @@ ;; container: visible ;; kids: uniform ;; - (let* ((size (gfw::flow-container-size '(:horizontal) t *flow-layout-kids1* -1 -1)) - (actual (gfw::flow-container-layout '(:horizontal) t *flow-layout-kids1* -1 -1)) + (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal))) + (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) (expected-pnts nil)) (push (gfi:make-point :x 40 :y 0) expected-pnts) (push (gfi:make-point :x 20 :y 0) expected-pnts) @@ -70,8 +71,9 @@ ;; container: visible ;; kids: uniform ;; - (let* ((size (gfw::flow-container-size '(:vertical) t *flow-layout-kids1* -1 -1)) - (actual (gfw::flow-container-layout '(:vertical) t *flow-layout-kids1* -1 -1)) + (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical))) + (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) (expected-pnts nil)) (push (gfi:make-point :x 0 :y 20) expected-pnts) (push (gfi:make-point :x 0 :y 10) expected-pnts) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 13 00:40:49 2006 @@ -37,10 +37,10 @@ ;;; helper functions ;;; -(defun flow-container-size (style win-visible kids width-hint height-hint) +(defun flow-container-size (layout win-visible kids width-hint height-hint) (let ((max -1) (total 0) - (vert-orient (find :vertical style))) + (vert-orient (find :vertical (style-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid (if vert-orient width-hint -1) @@ -59,11 +59,11 @@ (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) -(defun flow-container-layout (style win-visible kids width-hint height-hint) +(defun flow-container-layout (layout win-visible kids width-hint height-hint) (let ((entries nil) (last-coord 0) (last-dim 0) - (vert-orient (find :vertical style))) + (vert-orient (find :vertical (style-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid (if vert-orient width-hint -1) @@ -95,11 +95,11 @@ (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) - (flow-container-size (style-of layout) (visible-p win) kids width-hint height-hint))) + (flow-container-size layout (visible-p win) kids width-hint height-hint))) (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) - (flow-container-layout (style-of layout) (visible-p win) kids width-hint height-hint))) + (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) &key style) (unless (listp style) From junrue at common-lisp.net Tue Mar 14 04:37:44 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 13 Mar 2006 23:37:44 -0500 (EST) Subject: [graphic-forms-cvs] r38 - in trunk/src: tests/uitoolkit uitoolkit/widgets Message-ID: <20060314043744.E37EF2E17F@common-lisp.net> Author: junrue Date: Mon Mar 13 23:37:44 2006 New Revision: 38 Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: implemented wrap style for flow layout; refactored flow layout unit tests Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 13 23:37:44 2006 @@ -165,14 +165,29 @@ (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) - (let ((layout (gfw:layout-manager *layout-tester-win*))) - (setf (gfw:style-of layout) (list :horizontal)) + (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (style (gfw:style-of layout))) + (setf style (remove :vertical style)) + (push :horizontal style) + (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) (defun set-flow-vertical (disp item time rect) (declare (ignorable disp item time rect)) - (let ((layout (gfw:layout-manager *layout-tester-win*))) - (setf (gfw:style-of layout) (list :vertical)) + (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (style (gfw:style-of layout))) + (setf style (remove :horizontal style)) + (push :vertical style) + (setf (gfw:style-of layout) style) + (gfw:layout *layout-tester-win*))) + +(defun set-flow-layout-wrap (disp item time rect) + (declare (ignorable disp item time rect)) + (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (style (gfw:style-of layout))) + (if (find :wrap style) + (setf (gfw:style-of layout) (remove :wrap style)) + (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) (defun flow-mod-callback (disp menu time) @@ -200,9 +215,8 @@ (gfw:append-submenu menu "Margin" margin-menu nil) (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) (gfw:append-submenu menu "Spacing" spacing-menu nil) - (setf it (gfw:append-item menu "Fill" nil nil)) - (gfw:check it t) - (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2))))) + (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (gfw:check it (find :wrap (gfw:style-of (gfw:layout-manager *layout-tester-win*)))))) (defun exit-layout-callback (disp item time rect) (declare (ignorable disp item time rect)) 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 Mon Mar 13 23:37:44 2006 @@ -34,50 +34,90 @@ (in-package :graphic-forms.uitoolkit.tests) (defvar *minsize1* (gfi:make-size :width 20 :height 10)) -(defvar *flow-layout-kids1* (list (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*))) - -(defun validate-layout-points (actual-entries expected-pnts) - (mapc #'(lambda (pnt entry) - (let ((pnt2 (gfi:location (cdr entry)))) - (assert-true (and (= (gfi:point-x pnt) (gfi:point-x pnt2)) - (= (gfi:point-y pnt) (gfi:point-y pnt2)))))) - expected-pnts - actual-entries)) +(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *minsize1*) + (make-instance 'mock-widget :min-size *minsize1*) + (make-instance 'mock-widget :min-size *minsize1*))) + +(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 (gfi:location actual)) + (sz-a (gfi:size actual))) + (assert-equal (gfi:point-x pnt-a) (first expected)) + (assert-equal (gfi:point-y pnt-a) (second expected)) + (assert-equal (gfi:size-width sz-a) (third expected)) + (assert-equal (gfi:size-height sz-a) (fourth expected)))) + expected-rects + actual-rects))) (define-test flow-layout-test1 ;; orient: horizontal ;; wrap: disabled - ;; fill: disabled - ;; container: visible + ;; 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-kids1* -1 -1)) - (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) - (expected-pnts nil)) - (push (gfi:make-point :x 40 :y 0) expected-pnts) - (push (gfi:make-point :x 20 :y 0) expected-pnts) - (push (gfi:make-point :x 0 :y 0) expected-pnts) + (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 (gfi:size-width size)) (assert-equal 10 (gfi:size-height size)) - (validate-layout-points actual expected-pnts))) + (validate-layout-rects data expected-rects))) (define-test flow-layout-test2 ;; orient: vertical ;; wrap: disabled - ;; fill: disabled - ;; container: visible + ;; 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-kids1* -1 -1)) - (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1)) - (expected-pnts nil)) - (push (gfi:make-point :x 0 :y 20) expected-pnts) - (push (gfi:make-point :x 0 :y 10) expected-pnts) - (push (gfi:make-point :x 0 :y 0) expected-pnts) + (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 (gfi:size-width size)) (assert-equal 30 (gfi:size-height size)) - (validate-layout-points actual expected-pnts))) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test3 + ;; orient: horizontal + ;; wrap: enabled + ;; 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 + ;; wrap: enabled + ;; 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 + ;; wrap: enabled + ;; 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 + ;; wrap: enabled + ;; 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))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 13 23:37:44 2006 @@ -59,35 +59,52 @@ (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) -(defun flow-container-layout (layout win-visible kids width-hint height-hint) - (let ((entries nil) - (last-coord 0) - (last-dim 0) - (vert-orient (find :vertical (style-of layout)))) +(defun flow-container-layout (layout visible kids width-hint height-hint) + (let* ((flows nil) + (curr-flow nil) + (max-size -1) + (next-coord 0) + (wrap-coord 0) + (style (style-of layout)) + (vert-orient (find :vertical style)) + (wrap (find :wrap style))) (loop for kid in kids - do (let ((size (preferred-size kid - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint))) + do (let ((size (preferred-size kid -1 -1)) (pnt (gfi:make-point))) - (when (or (visible-p kid) (not win-visible)) + (when (or (visible-p kid) (not visible)) (if vert-orient (progn - (setf (gfi:point-y pnt) (+ last-coord last-dim)) - (if (>= width-hint 0) - (setf (gfi:size-width size) width-hint)) - (setf last-coord (gfi:point-y pnt)) - (setf last-dim (gfi:size-height size))) + (when (and wrap + (>= height-hint 0) + (> (+ next-coord (gfi:size-height size)) height-hint)) + (push (reverse curr-flow) flows) + (setf curr-flow nil) + (setf next-coord 0) + (incf wrap-coord max-size) + (setf max-size -1)) + (setf (gfi:point-x pnt) wrap-coord) + (setf (gfi:point-y pnt) next-coord) + (if (< max-size (gfi:size-width size)) + (setf max-size (gfi:size-width size))) + (incf next-coord (gfi:size-height size))) (progn - (setf (gfi:point-x pnt) (+ last-coord last-dim)) - (if (>= height-hint 0) - (setf (gfi:size-height size) height-hint)) - (setf last-coord (gfi:point-x pnt)) - (setf last-dim (gfi:size-width size)))) - (push (cons kid (make-instance 'gfi:rectangle - :size size - :location pnt)) - entries)))) - (nreverse entries))) + (when (and wrap + (>= width-hint 0) + (> (+ next-coord (gfi:size-width size)) width-hint)) + (push (reverse curr-flow) flows) + (setf curr-flow nil) + (setf next-coord 0) + (incf wrap-coord max-size) + (setf max-size -1)) + (setf (gfi:point-x pnt) next-coord) + (setf (gfi:point-y pnt) wrap-coord) + (if (< max-size (gfi:size-height size)) + (setf max-size (gfi:size-height size))) + (incf next-coord (gfi:size-width size)))) + (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow)))) + (unless (null curr-flow) + (push (reverse curr-flow) flows)) + (loop for flow in (nreverse flows) append flow))) ;;; ;;; methods @@ -105,5 +122,5 @@ (unless (listp style) (setf style (list style))) (if (and (null (find :horizontal style)) (null (find :vertical style))) - (setf (style-of layout) '(:horizontal)) - (setf (style-of layout) style))) + (push :horizontal style)) + (setf (style-of layout) style)) From junrue at common-lisp.net Tue Mar 14 05:01:20 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 14 Mar 2006 00:01:20 -0500 (EST) Subject: [graphic-forms-cvs] r39 - in trunk/src: . tests/uitoolkit uitoolkit/widgets Message-ID: <20060314050120.3252C3300B@common-lisp.net> Author: junrue Date: Tue Mar 14 00:01:18 2006 New Revision: 39 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: renamed window layout accessor Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 14 00:01:18 2006 @@ -398,7 +398,7 @@ #:key-down-p #:key-toggled-p #:layout - #:layout-manager + #:layout-of #:layout-p #:lines-visible-p #:location Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 00:01:18 2006 @@ -159,13 +159,13 @@ (defun check-flow-orient-item (disp menu time) (declare (ignore disp time)) - (let ((layout (gfw:layout-manager *layout-tester-win*))) + (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) - (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :vertical style)) (push :horizontal style) @@ -174,7 +174,7 @@ (defun set-flow-vertical (disp item time rect) (declare (ignorable disp item time rect)) - (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (setf style (remove :horizontal style)) (push :vertical style) @@ -183,7 +183,7 @@ (defun set-flow-layout-wrap (disp item time rect) (declare (ignorable disp item time rect)) - (let* ((layout (gfw:layout-manager *layout-tester-win*)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) (style (gfw:style-of layout))) (if (find :wrap style) (setf (gfw:style-of layout) (remove :wrap style)) @@ -216,7 +216,7 @@ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) (gfw:append-submenu menu "Spacing" spacing-menu nil) (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) - (gfw:check it (find :wrap (gfw:style-of (gfw:layout-manager *layout-tester-win*)))))) + (gfw:check it (find :wrap (gfw:style-of (gfw:layout-of *layout-tester-win*)))))) (defun exit-layout-callback (disp item time rect) (declare (ignorable disp item time rect)) @@ -233,7 +233,7 @@ (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout-manager (make-instance 'gfw:flow-layout))) + :layout (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Tue Mar 14 00:01:18 2006 @@ -40,7 +40,7 @@ (defun perform-layout (win width-hint height-hint) "Calls compute-layout for a window and then handles the actual moving and resizing of its children." - (let ((layout (layout-manager win)) + (let ((layout (layout-of win)) (kids nil) (hdwp nil)) (when (and (layout-p win) layout) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Mar 14 00:01:18 2006 @@ -85,8 +85,8 @@ ((layout-p :reader layout-p :initform t) - (layout-manager - :accessor layout-manager - :initarg :layout-manager + (layout + :accessor layout-of + :initarg :layout :initform nil)) (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows).")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Mar 14 00:01:18 2006 @@ -262,9 +262,9 @@ (call-next-method)) (defmethod preferred-size ((win window) width-hint height-hint) - (let ((mgr (layout-manager win))) - (if (and (layout-p win) mgr) - (let ((new-client-sz (compute-size mgr win width-hint height-hint))) + (let ((layout (layout-of win))) + (if (and (layout-p win) layout) + (let ((new-client-sz (compute-size layout win width-hint height-hint))) (compute-outer-size win new-client-sz)) (size win)))) From junrue at common-lisp.net Tue Mar 14 06:20:03 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 14 Mar 2006 01:20:03 -0500 (EST) Subject: [graphic-forms-cvs] r40 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060314062003.D540B4F006@common-lisp.net> Author: junrue Date: Tue Mar 14 01:20:02 2006 New Revision: 40 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented widget and menu item enabling/disabling; implemented flow layout spacing Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 14 01:20:02 2006 @@ -448,6 +448,7 @@ #:show-selection #:shutdown #:size + #:spacing-of #:startup #:step-increment #:style-of Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 01:20:02 2006 @@ -36,6 +36,7 @@ (defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") (defconstant +label-text+ "Test Label") +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -157,7 +158,7 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*)))) -(defun check-flow-orient-item (disp menu time) +(defun check-flow-orient-items (disp menu time) (declare (ignore disp time)) (let ((layout (gfw:layout-of *layout-tester-win*))) (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) @@ -190,6 +191,26 @@ (setf (gfw:style-of layout) (push :wrap style))) (gfw:layout *layout-tester-win*))) +(defun enable-flow-spacing-items (disp menu time) + (declare (ignore disp time)) + (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*)))) + (gfw:enable (gfw:item-at menu 0) (> spacing 0)))) + +(defun decrease-flow-spacing (disp item time rect) + (declare (ignore disp item time rect)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) + (spacing (gfw:spacing-of layout))) + (unless (zerop spacing) + (decf spacing +spacing-delta+) + (setf (gfw:spacing-of layout) spacing) + (gfw:layout *layout-tester-win*)))) + +(defun increase-flow-spacing (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:spacing-of layout) +spacing-delta+) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) @@ -210,11 +231,13 @@ :callback #'set-flow-horizontal) (:item "Vertical" :callback #'set-flow-vertical)))) - (spacing-menu (gfw:defmenusystem ((:item "Decrease") - (:item "Increase"))))) + (spacing-menu (gfw:defmenusystem ((:item "Decrease" + :callback #'decrease-flow-spacing) + (:item "Increase" + :callback #'increase-flow-spacing))))) (gfw:append-submenu menu "Margin" margin-menu nil) - (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) - (gfw:append-submenu menu "Spacing" spacing-menu nil) + (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) + (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) (gfw:check it (find :wrap (gfw:style-of (gfw:layout-of *layout-tester-win*)))))) @@ -233,7 +256,8 @@ (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout (make-instance 'gfw:flow-layout))) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing-delta+))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" 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 Tue Mar 14 01:20:02 2006 @@ -53,6 +53,8 @@ (define-test flow-layout-test1 ;; orient: horizontal ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: unrestricted width and height ;; kids: uniform ;; @@ -67,6 +69,8 @@ (define-test flow-layout-test2 ;; orient: vertical ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: unrestricted width and height ;; kids: uniform ;; @@ -81,6 +85,8 @@ (define-test flow-layout-test3 ;; orient: horizontal ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: restricted width, unrestricted height ;; kids: uniform ;; @@ -92,6 +98,8 @@ (define-test flow-layout-test4 ;; orient: vertical ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: unrestricted width, restricted height ;; kids: uniform ;; @@ -103,6 +111,8 @@ (define-test flow-layout-test5 ;; orient: horizontal ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: restricted width and height ;; kids: uniform ;; @@ -114,6 +124,8 @@ (define-test flow-layout-test6 ;; orient: vertical ;; wrap: enabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 ;; container: restricted width and height ;; kids: uniform ;; @@ -121,3 +133,61 @@ (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 + ;; 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 (gfi:size-width size)) + (assert-equal 10 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test8 + ;; orient: vertical + ;; 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 (gfi:size-width size)) + (assert-equal 38 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test9 + ;; orient: horizontal + ;; 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 + ;; 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))) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Mar 14 01:20:02 2006 @@ -128,6 +128,19 @@ (hwnd HANDLE)) (defcfun + ("EnableMenuItem" enable-menu-item) + BOOL + (hmenu HANDLE) + (id UINT) + (flag UINT)) + +(defcfun + ("EnableWindow" enable-window) + BOOL + (hwnd HANDLE) + (enable BOOL)) + +(defcfun ("EndDeferWindowPos" end-defer-window-pos) BOOL (posinfo HANDLE)) @@ -303,6 +316,11 @@ (erase BOOL)) (defcfun + ("IsWindowEnabled" is-window-enabled) + BOOL + (hwnd HANDLE)) + +(defcfun ("IsWindowVisible" is-window-visible) BOOL (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Tue Mar 14 01:20:02 2006 @@ -55,6 +55,10 @@ (incf total (gfi:size-width size)) (if (< max (gfi:size-height size)) (setf max (gfi:size-height size)))))))) + (if (< (spacing-of layout) 0) + (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) + (unless (null kids) + (incf total (* (spacing-of layout) (1- (length kids))))) (if vert-orient (gfi:make-size :width max :height total) (gfi:make-size :width total :height max)))) @@ -65,9 +69,12 @@ (max-size -1) (next-coord 0) (wrap-coord 0) + (spacing (spacing-of layout)) (style (style-of layout)) (vert-orient (find :vertical style)) (wrap (find :wrap style))) + (if (< spacing 0) + (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) (loop for kid in kids do (let ((size (preferred-size kid -1 -1)) (pnt (gfi:make-point))) @@ -80,13 +87,13 @@ (push (reverse curr-flow) flows) (setf curr-flow nil) (setf next-coord 0) - (incf wrap-coord max-size) + (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) wrap-coord) (setf (gfi:point-y pnt) next-coord) (if (< max-size (gfi:size-width size)) (setf max-size (gfi:size-width size))) - (incf next-coord (gfi:size-height size))) + (incf next-coord (+ (gfi:size-height size) spacing))) (progn (when (and wrap (>= width-hint 0) @@ -94,13 +101,13 @@ (push (reverse curr-flow) flows) (setf curr-flow nil) (setf next-coord 0) - (incf wrap-coord max-size) + (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) next-coord) (setf (gfi:point-y pnt) wrap-coord) (if (< max-size (gfi:size-height size)) (setf max-size (gfi:size-height size))) - (incf next-coord (gfi:size-width size)))) + (incf next-coord (+ (gfi:size-width size) spacing)))) (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow)))) (unless (null curr-flow) (push (reverse curr-flow) flows)) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Tue Mar 14 01:20:02 2006 @@ -40,5 +40,9 @@ :initform nil)) (:documentation "Subclasses implement layout strategies on behalf of window objects.")) -(defclass flow-layout (layout-manager) () +(defclass flow-layout (layout-manager) + ((spacing + :accessor spacing-of + :initarg :spacing + :initform 0)) (:documentation "Window children are arranged in a row or column.")) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Tue Mar 14 01:20:02 2006 @@ -37,6 +37,30 @@ ;;; helper functions ;;; +(defun get-menuitem-state (hmenu mid) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer)) + (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "get-menu-item-info failed")) + gfs::state))) + (defun get-menuitem-text (hmenu mid) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type @@ -58,7 +82,7 @@ (setf gfs::cch 0) (setf gfs::hbmpitem (cffi:null-pointer)) (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfs::win32-error :detail "get-menu-item-info failed")) + (error 'gfs:win32-error :detail "get-menu-item-info failed")) (incf gfs::cch) (let ((str-ptr (cffi:foreign-alloc :char :count gfs::cch)) (result "")) @@ -66,7 +90,7 @@ (progn (setf gfs::tdata str-ptr) (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) - (error 'gfs::win32-error :detail "get-menu-item-info failed")) + (error 'gfs:win32-error :detail "get-menu-item-info failed")) (setf result (cffi:foreign-string-to-lisp str-ptr)) (cffi:foreign-free str-ptr))) result)))) @@ -184,9 +208,17 @@ (setf (item-id it) 0) (setf (slot-value it 'gfi:handle) nil))) -(defmethod enable ((item menu-item) flag) - ;; FIXME: need to implement -) +(defmethod enable ((it 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 (gfi:handle it) (item-id it) bits))) + +(defmethod enabled-p ((it menu-item)) + (= (logand (get-menuitem-state (gfi:handle it) (item-id it)) + gfs::+mfs-enabled+) + gfs::+mfs-enabled+)) (defmethod item-owner ((it menu-item)) (let ((hmenu (gfi:handle it))) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Mar 14 01:20:02 2006 @@ -105,6 +105,21 @@ (error 'gfs:win32-error :detail "destroy-window failed")))) (setf (slot-value w 'gfi:handle) nil)) +(defmethod enable :before ((w widget) flag) + (declare (ignore flag)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod enable ((w widget) flag) + (gfs::enable-window (gfi:handle w) (if (null flag) 0 1))) + +(defmethod enabled-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod enabled-p ((w widget)) + (not (zerop (gfs::is-window-enabled (gfi:handle w))))) + (defmethod location :before ((w widget)) (if (gfi:disposed-p w) (error 'gfi:disposed-error))) From junrue at common-lisp.net Wed Mar 15 00:18:51 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 14 Mar 2006 19:18:51 -0500 (EST) Subject: [graphic-forms-cvs] r41 - in trunk/src: . tests/uitoolkit uitoolkit/widgets Message-ID: <20060315001851.9FFC06102D@common-lisp.net> Author: junrue Date: Tue Mar 14 19:18:51 2006 New Revision: 41 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp Log: implemented flow layout margins Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 14 19:18:51 2006 @@ -312,6 +312,7 @@ #:background-color #:background-pattern #:border-width + #:bottom-margin-of #:caret #:check #:check-all @@ -400,6 +401,7 @@ #:layout #:layout-of #:layout-p + #:left-margin-of #:lines-visible-p #:location #:lock @@ -431,6 +433,7 @@ #:replace-selection #:resizable-p #:retrieve-span + #:right-margin-of #:run-default-message-loop #:scroll #:select @@ -459,6 +462,7 @@ #:thumb-size #:tooltip-text #:top-index + #:top-margin-of #:traverse #:traverse-order #:trim-sizes Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Mar 14 19:18:51 2006 @@ -36,6 +36,7 @@ (defconstant +btn-text-before+ "Push Me") (defconstant +btn-text-after+ "Again!") (defconstant +label-text+ "Test Label") +(defconstant +margin-delta+ 4) (defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -211,22 +212,102 @@ (incf (gfw:spacing-of layout) +spacing-delta+) (gfw:layout *layout-tester-win*))) +(defun enable-left-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:left-margin-of layout) 0)))) + +(defun enable-top-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:top-margin-of layout) 0)))) + +(defun enable-right-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:right-margin-of layout) 0)))) + +(defun enable-bottom-flow-margin-items (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (gfw:enable (gfw:item-at menu 0) (> (gfw:bottom-margin-of layout) 0)))) + +(defun inc-left-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:left-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun inc-top-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:top-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun inc-right-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:right-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun inc-bottom-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (incf (gfw:bottom-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-left-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:left-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-top-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:top-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-right-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:right-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + +(defun dec-bottom-flow-margin (disp item time rect) + (declare (ignore disp item time rect)) + (let ((layout (gfw:layout-of *layout-tester-win*))) + (decf (gfw:bottom-margin-of layout) +margin-delta+) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) (let ((it nil) - (margin-menu (gfw:defmenusystem ((:item "Top" - :submenu ((:item "Decrease") - (:item "Increase"))) - (:item "Left" - :submenu ((:item "Decrease") - (:item "Increase"))) + (margin-menu (gfw:defmenusystem ((:item "Left" + :callback #'enable-left-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-left-flow-margin) + (:item "Increase" + :callback #'inc-left-flow-margin))) + (:item "Top" + :callback #'enable-top-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-top-flow-margin) + (:item "Increase" + :callback #'inc-top-flow-margin))) (:item "Right" - :submenu ((:item "Decrease") - (:item "Increase"))) + :callback #'enable-right-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-right-flow-margin) + (:item "Increase" + :callback #'inc-right-flow-margin))) (:item "Bottom" - :submenu ((:item "Decrease") - (:item "Increase")))))) + :callback #'enable-bottom-flow-margin-items + :submenu ((:item "Decrease" + :callback #'dec-bottom-flow-margin) + (:item "Increase" + :callback #'inc-bottom-flow-margin)))))) (orient-menu (gfw:defmenusystem ((:item "Horizontal" :callback #'set-flow-horizontal) (:item "Vertical" @@ -257,7 +338,8 @@ :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout (make-instance 'gfw:flow-layout - :spacing +spacing-delta+))) + :spacing +spacing-delta+ + :margins +margin-delta+))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" 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 Tue Mar 14 19:18:51 2006 @@ -191,3 +191,41 @@ (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 + ;; 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 (gfi:size-width size)) + (assert-equal 13 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test12 + ;; orient: vertical + ;; 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 (gfi:size-width size)) + (assert-equal 33 (gfi:size-height size)) + (validate-layout-rects data expected-rects))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Tue Mar 14 19:18:51 2006 @@ -55,26 +55,28 @@ (incf total (gfi:size-width size)) (if (< max (gfi:size-height size)) (setf max (gfi:size-height size)))))))) - (if (< (spacing-of layout) 0) - (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) (unless (null kids) (incf total (* (spacing-of layout) (1- (length kids))))) (if vert-orient - (gfi:make-size :width max :height total) - (gfi:make-size :width total :height max)))) + (progn + (incf max (+ (left-margin-of layout) (right-margin-of layout))) + (incf total (+ (top-margin-of layout) (bottom-margin-of layout))) + (gfi:make-size :width max :height total)) + (progn + (incf total (+ (left-margin-of layout) (right-margin-of layout))) + (incf max (+ (top-margin-of layout) (bottom-margin-of layout))) + (gfi:make-size :width total :height max))))) (defun flow-container-layout (layout visible kids width-hint height-hint) (let* ((flows nil) (curr-flow nil) - (max-size -1) - (next-coord 0) - (wrap-coord 0) (spacing (spacing-of layout)) (style (style-of layout)) (vert-orient (find :vertical style)) - (wrap (find :wrap style))) - (if (< spacing 0) - (error 'gfs:toolkit-error :detail "layout spacing must be non-negative")) + (wrap (find :wrap style)) + (max-size -1) + (next-coord (if vert-orient (top-margin-of layout) (left-margin-of layout))) + (wrap-coord (if vert-orient (left-margin-of layout) (top-margin-of layout)))) (loop for kid in kids do (let ((size (preferred-size kid -1 -1)) (pnt (gfi:make-point))) @@ -83,10 +85,13 @@ (progn (when (and wrap (>= height-hint 0) - (> (+ next-coord (gfi:size-height size)) height-hint)) + (> (+ next-coord + (gfi:size-height size) + (bottom-margin-of layout)) + height-hint)) (push (reverse curr-flow) flows) (setf curr-flow nil) - (setf next-coord 0) + (setf next-coord (top-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) wrap-coord) @@ -97,10 +102,13 @@ (progn (when (and wrap (>= width-hint 0) - (> (+ next-coord (gfi:size-width size)) width-hint)) + (> (+ next-coord + (gfi:size-width size) + (right-margin-of layout)) + width-hint)) (push (reverse curr-flow) flows) (setf curr-flow nil) - (setf next-coord 0) + (setf next-coord (left-margin-of layout)) (incf wrap-coord (+ max-size spacing)) (setf max-size -1)) (setf (gfi:point-x pnt) next-coord) @@ -125,9 +133,22 @@ (with-children (win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key style) +(defmethod initialize-instance :after ((layout flow-layout) + &key style margins horz-margins vert-margins + &allow-other-keys) (unless (listp style) (setf style (list style))) (if (and (null (find :horizontal style)) (null (find :vertical style))) (push :horizontal style)) - (setf (style-of layout) style)) + (setf (style-of layout) 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)) + (unless (null horz-margins) + (setf (left-margin-of layout) horz-margins) + (setf (right-margin-of layout) horz-margins)) + (unless (null vert-margins) + (setf (top-margin-of layout) vert-margins) + (setf (bottom-margin-of layout) vert-margins))) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Tue Mar 14 19:18:51 2006 @@ -44,5 +44,21 @@ ((spacing :accessor spacing-of :initarg :spacing + :initform 0) + (left-margin + :accessor left-margin-of + :initarg :left-margin + :initform 0) + (top-margin + :accessor top-margin-of + :initarg :top-margin + :initform 0) + (right-margin + :accessor right-margin-of + :initarg :right-margin + :initform 0) + (bottom-margin + :accessor bottom-margin-of + :initarg :bottom-margin :initform 0)) (:documentation "Window children are arranged in a row or column.")) From junrue at common-lisp.net Wed Mar 15 01:19:46 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 14 Mar 2006 20:19:46 -0500 (EST) Subject: [graphic-forms-cvs] r42 - trunk/docs/website Message-ID: <20060315011946.EB12F72084@common-lisp.net> Author: junrue Date: Tue Mar 14 20:19:46 2006 New Revision: 42 Added: trunk/docs/website/style.css Log: check in stylesheet for project website Added: trunk/docs/website/style.css ============================================================================== --- (empty file) +++ trunk/docs/website/style.css Tue Mar 14 20:19:46 2006 @@ -0,0 +1,54 @@ + +.header { + font-size: medium; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 5px; + border-color:#002244; + padding: 1mm 1mm 1mm 5mm; +} + +.footer { + font-size: small; + font-style: italic; + text-align: right; + background-color:#336699; + color:#ffffff; + border-style:solid; + border-width: 2px; + border-color:#002244; + padding: 1mm 1mm 1mm 1mm; +} + +.footer a:link { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:visited { + font-weight:bold; + color:#ffffff; + text-decoration:underline; +} + +.footer a:hover { + font-weight:bold; + color:#002244; + text-decoration:underline; } + +.check {font-size: x-small; + text-align:right;} + +.check a:link { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:visited { font-weight:bold; + color:#a0a0ff; + text-decoration:underline; } + +.check a:hover { font-weight:bold; + color:#000000; + text-decoration:underline; } From junrue at common-lisp.net Wed Mar 15 19:40:07 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 15 Mar 2006 14:40:07 -0500 (EST) Subject: [graphic-forms-cvs] r43 - in trunk/docs: manual website Message-ID: <20060315194007.E8A794708F@common-lisp.net> Author: junrue Date: Wed Mar 15 14:40:07 2006 New Revision: 43 Added: trunk/docs/manual/glossary.texinfo trunk/docs/manual/overview.texinfo trunk/docs/manual/packages.texinfo trunk/docs/manual/reference.texinfo trunk/docs/website/docs.html trunk/docs/website/download.html trunk/docs/website/screenshots.html Removed: trunk/docs/manual/graphic-forms-reference.texinfo Modified: trunk/docs/manual/Makefile trunk/docs/website/index.html trunk/docs/website/style.css Log: documentation updates Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Wed Mar 15 14:40:07 2006 @@ -32,15 +32,12 @@ # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # -# -# TODO: upgrade MSYS version of makeinfo so "--css-include=style.css" works -# docs: - makeinfo --html graphic-forms-reference.texinfo + makeinfo --html --css-include=style.css reference.texinfo clean: find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; - rm -rf graphic-forms-reference + rm -rf reference # # TODO: implement an upload target Added: trunk/docs/manual/glossary.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/glossary.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,29 @@ + + 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 c =================================================================== + at c CHAPTER: Glossary + + at node Glossary + at chapter Glossary + +Terms and definitions. + + at table @samp + at item control +A control is a thing. + + at item dialog +A dialog is something else. + + at item menu +A collection of menu items. + + at end table + + at cindex control + at cindex dialog + at cindex menu Added: trunk/docs/manual/overview.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/overview.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,79 @@ + + 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 c =================================================================== + at c CHAPTER: Overview + + at node Overview + at chapter Overview + +Graphic-Forms is a user interface library implemented in Common Lisp +focusing on the Windows at registeredsymbol{} platform. Graphic-Forms is +licensed under the terms of the BSD License. + +Graphic-Forms has two primary goals: + + at itemize @bullet + at item +in the short term, provide a toolkit encapsulating the underlying +window system primitives, custom controls and dialogs, and +platform-specific features + + at item +in the longer-term, implement an application framework on +top of the toolkit -- as an analogy, consider the relationship between +SWT and JFace in the Eclipse framework. + at end itemize + +Support for multiple Common Lisp implementations is planned; see the +project website for up-to-date information on supported vendors and +current known issues. + +Why implement another UI toolkit? The niche for Graphic-Forms is that +it emphasizes the use of Windows at registeredsymbol{} features without +comprising functionality due to portability constraints. Applications +that need portability across windowing systems are already served by +projects such as McCLIM and LTK in the open-source world or the +toolkits provided by commercial vendors. Or you might consider helping +new portable UI projects such as wxCL. This project is aimed +specifically at Windows at registeredsymbol{} developers. + +The remainder of this chapter provides basic information for +programmers that want to use Graphic-Forms in their projects as well +as maintainers/contributors. + +The main project website: @* + at indicateurl{http://common-lisp.net/project/graphic-forms} + + + at section Dependencies + +The libraries that Graphic-Forms relies upon. + + + at section Mailing Lists and Bug Reports + +Announcements mailing list: @* + at indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce} + +Developer mailing list (for both users and maintainers): @* + at indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel} + +Source control log mailing list: @* + at indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs} + +The bug tracking system: @* + at indicateurl{http://sourceforge.net/tracker/?group_id=20959&atid=120959} + + + at section Submitting Patches + +Please use the SourceForge patch tracking mechanism to contribute patches: + + + at section Running the Library Tests + +How to run unit-tests and ad-hoc tests. Added: trunk/docs/manual/packages.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/packages.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,28 @@ + + 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 c =================================================================== + at c CHAPTER: Packages + + at node Packages + at chapter Packages + +General comments about the packages. + + at section Intrinsics + at cindex Intrinsics Package + + at section Graphics + at cindex Graphics Package + + at section System + at cindex System Package + + at section Tests + at cindex Tests Package + + at section Widgets + at cindex Widgets Package Added: trunk/docs/manual/reference.texinfo ============================================================================== --- (empty file) +++ trunk/docs/manual/reference.texinfo Wed Mar 15 14:40:07 2006 @@ -0,0 +1,160 @@ +\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*- + at c %**start of header + + 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 setfilename reference.info + at settitle Graphic-Forms Programming Reference + at exampleindent 2 + + at c ============================= Macros ============================= + + at macro Function {args} + at defun \args\ + at end defun + at end macro + + at macro Macro {args} + at defmac \args\ + at end defmac + at end macro + + at macro Accessor {args} + at deffn {Accessor} \args\ + at end deffn + at end macro + + at macro GenericFunction {args} + at deffn {Generic Function} \args\ + at end deffn + at end macro + + at macro Variable {args} + at defvr {Special Variable} \args\ + at end defvr + at end macro + + at macro Condition {args} + at deftp {Condition Type} \args\ + at end deftp + at end macro + + at macro GFI + at acronym{GFW} + at end macro + + at macro GFG + at acronym{GFW} + at end macro + + at macro GFS + at acronym{GFW} + at end macro + + at macro GFW + at acronym{GFW} + at end macro + + at macro impnote {text} + at quotation + at strong{Implementor's note:} @emph{\text\} + at end quotation + at end macro + + at c Info "requires" that x-refs end in a period or comma, or ) in the + at c case of @pxref. So the following implements that requirement for + at c the "See also" subheadings that permeate this manual, but only in + at c Info mode. + at ifinfo + at macro seealso {name} + at ref{\name\}. + at end macro + at end ifinfo + + at ifnotinfo + at alias seealso = ref + at end ifnotinfo + + at c ==========================End Macros ============================= + + at c Coallesce all the index types into one master index. + at syncodeindex fn cp + at syncodeindex ky cp + at syncodeindex tp cp + at syncodeindex vr cp + + at copying +Copyright @copyright{} 2006, Jack D. Unrue @* + + at quotation +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. + + at sc{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 +DISCLAIMED. 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.} + at end quotation + at end copying + at c %**end of header + + at titlepage + at title Graphic-Forms Programming Reference + at c @subtitle Version 0.2.0 + at c @author Jack D. Unrue + + at page + at vskip 0pt plus 1filll + at insertcopying + at end titlepage + + at ifnottex + at node Top + at top Graphic-Forms Programming Reference + at insertcopying + at end ifnottex + + at majorheading Major Topics List + + at menu +* Overview:: Notes on using Graphic-Forms and how to get help. +* Glossary:: Terms and definitions. +* Packages:: Summary of the library packages. +* Master Index:: + at end menu + + at contents + + at include overview.texinfo + at include glossary.texinfo + at include packages.texinfo + + at c =================================================================== + at c Index + + at node Master Index + at unnumbered Master Index + at printindex cp + + at bye Added: trunk/docs/website/docs.html ============================================================================== --- (empty file) +++ trunk/docs/website/docs.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,24 @@ + + + + + Graphic-Forms Documentation + + + + + + +

Programming Reference

+ +

FAQ

+ +

Articles

+ + + + + Added: trunk/docs/website/download.html ============================================================================== --- (empty file) +++ trunk/docs/website/download.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,38 @@ + + + + + Graphic-Forms Source Control + + + + + + +

Graphic-Forms is distributed in source code form. Please choose from + one of the following options: + +

+

+ + + + + Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Mar 15 14:40:07 2006 @@ -1,18 +1,27 @@ - -Graphic-Forms project - - - + + Graphic-Forms project + + + - +

Graphic-Forms

A user interface toolkit for the Windows® platform.

+ + +

Introduction

Graphic-Forms is a user interface library implemented in @@ -44,45 +53,38 @@ in the open-source world or the toolkits provided by commercial vendors. Or you might consider helping new portable UI projects such as wxCL. This - project is aimed specifically at Windows® developers. + project is aimed specifically at Windows® developers.

-

Current Status

+

Status

-

The Subversion repository will be populated with an initial code - drop in the near future. Additional documentation will be - made available at that time, as will screenshots.

+

The first release will be version 0.2.0 and should be + available shortly.

-

NOTE: This library is in the early implementation stage. Brave souls who +

This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and - behavior changes in the preliminary releases leading up to the 1.0 release.

+ behavior changes in the preliminary releases leading up to the 1.0 release.

-

Mailing Lists

+

Mailing Lists

-

Download

- -

This project has not released any files.

- -

Revision Control

- -

You can -browse the Subversion repository or download the current development tree via - anonymous svn, as described here.

- - + + + Added: trunk/docs/website/screenshots.html ============================================================================== --- (empty file) +++ trunk/docs/website/screenshots.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,20 @@ + + + + + Graphic-Forms Screenshots + + + + + + +

Screenshots coming soon...stay tuned!

+ + + + + Modified: trunk/docs/website/style.css ============================================================================== --- trunk/docs/website/style.css (original) +++ trunk/docs/website/style.css Wed Mar 15 14:40:07 2006 @@ -24,19 +24,24 @@ .footer a:link { font-weight:bold; color:#ffffff; - text-decoration:underline; } .footer a:visited { font-weight:bold; color:#ffffff; - text-decoration:underline; } -.footer a:hover { +:link.footerleft { font-weight:bold; - color:#002244; - text-decoration:underline; } + float: left; + color:#ffffff; +} + +:visited.footerleft { + font-weight:bold; + float: left; + color:#ffffff; +} .check {font-size: x-small; text-align:right;} @@ -52,3 +57,52 @@ .check a:hover { font-weight:bold; color:#000000; text-decoration:underline; } + +div.NavBar { + padding: 4px 0px 4px 0px; + float: right; + font-weight:bold; +} + +.barfirst { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +.barcenter { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +.barlast { + padding: 0px 5px 0px 5px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +:hover.barfirst { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} + +:hover.barcenter { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} + +:hover.barlast { + padding: 0px 5px 0px 5px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} From junrue at common-lisp.net Thu Mar 16 01:24:53 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 15 Mar 2006 20:24:53 -0500 (EST) Subject: [graphic-forms-cvs] r44 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060316012453.E33CE1C002@common-lisp.net> Author: junrue Date: Wed Mar 15 20:24:52 2006 New Revision: 44 Added: trunk/src/tests/uitoolkit/windlg.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented thread context cleanup; implemented +style-popup+ window style; implemented draw-filled-rectangle method Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Wed Mar 15 20:24:52 2006 @@ -53,4 +53,5 @@ (:file "layout-unit-tests") (:file "hello-world") (:file "event-tester") - (:file "layout-tester"))))))))) + (:file "layout-tester") + (:file "windlg"))))))))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Mar 15 20:24:52 2006 @@ -33,38 +33,35 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defparameter *hellowin* nil) - -(defun exit-hello-world () - (let ((w *hellowin*)) - (setf *hellowin* nil) - (gfi:dispose w)) - (gfw:shutdown 0)) - (defclass hellowin-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d hellowin-events) widget time) (declare (ignore widget time)) - (exit-hello-world)) + (gfw:shutdown 0)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignorable window time rect)) + (declare (ignore window time rect)) + (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + :size (gfw:client-size window))) + (setf (gfg:background-color gc) gfg:+color-white+) + (gfg:draw-filled-rectangle gc rect) (setf (gfg:background-color gc) gfg:+color-red+) (setf (gfg:foreground-color gc) gfg:+color-green+) (gfg:draw-text gc "Hello World!" (gfi:make-point))) (defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) - (exit-hello-world)) + (gfw:shutdown 0)) (defun run-hello-world-internal () - (let ((menubar nil)) - (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize *hellowin* nil :style-workspace) + (let ((menubar nil) + (window nil)) + (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize window nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar *hellowin*) menubar) - (gfw:show *hellowin* t))) + (setf (gfw:menu-bar window) menubar) + (gfw:show window t))) (defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal)) Added: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed Mar 15 20:24:52 2006 @@ -0,0 +1,88 @@ +;;;; +;;;; windlg.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 main-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d main-win-events) window time) + (declare (ignore time)) + (gfi:dispose window) + (gfw:shutdown 0)) + +(defclass test-win-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d test-win-events) window time) + (declare (ignore time)) + (gfi:dispose window)) + +(defmethod gfw:event-paint ((d test-win-events) window time gc rect) + (declare (ignore time)) + (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) + :size (gfw:client-size window))) + (setf (gfg:background-color gc) gfg:+color-white+) + (gfg:draw-filled-rectangle gc rect)) + +(defun create-borderless-win ()) + +(defun create-miniframe-win ()) + +(defun create-popup-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) + (gfw:realize window nil :style-popup) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) + (setf (gfw:text window) "Popup") + (gfw:show window t))) + +(defun exit-callback (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:shutdown 0)) + +(defun run-windlg-internal () + (let ((menubar nil) + (window nil)) + (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize window nil :style-workspace) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-callback))) + (:item "&Windows" + :submenu ((:item "&Borderless" :callback #'create-borderless-win) + (:item "&Mini Frame" :callback #'create-miniframe-win) + (:item "&Popup" :callback #'create-popup-win)))))) + (setf (gfw:menu-bar window) menubar) + (gfw:show window t))) + +(defun run-windlg () + (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Mar 15 20:24:52 2006 @@ -60,6 +60,28 @@ (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) +(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfi:rectangle)) + (if (gfi:disposed-p gc) + (error 'gfi:disposed-error)) + (let ((hdc (gfi:handle gc)) + (pnt (gfi:location rect)) + (size (gfi:size rect))) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) + rect-ptr gfs::rect) + (setf gfs::top (gfi:point-y pnt)) + (setf gfs::left (gfi:point-x pnt)) + (setf gfs::bottom (+ (gfi:point-y pnt) (gfi:size-height size))) + (setf gfs::right (+ (gfi:point-x pnt) (gfi:size-width size))) + (gfs::ext-text-out hdc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::+eto-opaque+ + rect-ptr + "" + 0 + (cffi:null-pointer)))))) + (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Wed Mar 15 20:24:52 2006 @@ -93,6 +93,18 @@ (params LPTR)) (defcfun + ("ExtTextOutA" ext-text-out) + BOOL + (hdc HANDLE) + (x INT) + (y INT) + (options UINT) + (rect LPRECT) + (str :string) + (count UINT) + (dx LPTR)) + +(defcfun ("GetBkColor" get-bk-color) COLORREF (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 Wed Mar 15 20:24:52 2006 @@ -173,6 +173,15 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +eto-opaque+ #x0002) +(defconstant +eto-clipped+ #x0004) +(defconstant +eto-glyph_index+ #x0010) +(defconstant +eto-rtlreading+ #x0080) +(defconstant +eto-numericslocal+ #x0400) +(defconstant +eto-numericslatin+ #x0800) +(defconstant +eto-ignorelanguage+ #x1000) +(defconstant +eto-pdy+ #x2000) + (defconstant +ga-parent+ 1) (defconstant +ga-root+ 2) (defconstant +ga-rootowner+ 3) @@ -634,6 +643,7 @@ (defconstant +ws-minimizebox+ #x00020000) (defconstant +ws-maximizebox+ #x00010000) (defconstant +ws-popupwindow+ #x80880000) +(defconstant +ws-overlappedwindow+ #x00CF0000) (defconstant +ws-ex-dlgmodalframe+ #x00000001) (defconstant +ws-ex-noparentnotify+ #x00000004) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Mar 15 20:24:52 2006 @@ -56,6 +56,9 @@ #+clisp (defun thread-context () *the-thread-context*) +#+clisp (defun dispose-thread-context () + (setf *the-thread-context* nil)) + #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) (when (null tc) @@ -63,6 +66,9 @@ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) tc)) +#+lispworks (defun dispose-thread-context () + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) + (defmethod call-child-visitor-func ((tc thread-context) parent child) "Call the closure at the top of the child window visitor function stack." (let ((fn (first (slot-value tc 'child-visitor-stack)))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 15 20:24:52 2006 @@ -49,7 +49,8 @@ (run-default-message-loop))))) (defun shutdown (exit-code) - (gfs::post-quit-message exit-code)) + (gfs::post-quit-message exit-code) + (dispose-thread-context)) (defun clear-all (w) (let ((count (gfw:item-count w))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Mar 15 20:24:52 2006 @@ -154,53 +154,50 @@ (declare (ignore win)) (let ((std-flags 0) (ex-flags 0)) - (mapcar #'(lambda (sym) - (cond - ;; styles that can be combined - ;; - ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :style-max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :style-no-title) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-windowedge+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ - gfs::+ws-clipsiblings+ - gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) - ((eq sym :style-workspace) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-clipsiblings+ - gfs::+ws-clipchildren+ - gfs::+ws-caption+ - gfs::+ws-sysmenu+ - gfs::+ws-thickframe+ - gfs::+ws-minimizebox+ - gfs::+ws-maximizebox+)) - (setf ex-flags 0)))) - (flatten style)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; + ((eq sym :style-hscroll) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) +#| + ((eq sym :style-max) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + ((eq sym :style-min) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + ((eq sym :style-resize) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) + ((eq sym :style-sysmenu) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + ((eq sym :style-title) + (setf std-flags (logior std-flags gfs::+ws-caption+))) + ((eq sym :style-top) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + ((eq sym :style-vscroll) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) + + ;; pre-packaged combinations of window styles + ;; + ((eq sym :style-popup) + (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) + (setf ex-flags gfs::+ws-ex-toolwindow+)) + ((eq sym :style-splash) + (setf std-flags (logior gfs::+ws-overlapped+ + gfs::+ws-popup+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-visible+)) + (setf ex-flags 0)) + ((eq sym :style-tool) + (setf std-flags 0) + (setf ex-flags gfs::+ws-ex-palettewindow+)) + ((eq sym :style-workspace) + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)))) + (flatten style)) (values std-flags ex-flags))) (defmethod gfi:dispose ((win window)) @@ -300,3 +297,9 @@ (let ((sz (gfi:make-size))) (outer-size win sz) sz)) + +(defmethod text ((win window)) + (get-widget-text win)) + +(defmethod (setf text) (str (win window)) + (set-widget-text win str)) From junrue at common-lisp.net Thu Mar 16 05:17:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 16 Mar 2006 00:17:32 -0500 (EST) Subject: [graphic-forms-cvs] r45 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060316051732.702BB7E02C@common-lisp.net> Author: junrue Date: Thu Mar 16 00:17:31 2006 New Revision: 45 Modified: trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: replaced +style-popup+ with +style-palette+ and associated implementation; implemented +style-miniframe+ and +style-borderless+; relocated thread context cleanup function call to a more robust location Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Thu Mar 16 00:17:31 2006 @@ -33,14 +33,17 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defvar *hello-win* nil) + (defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d hellowin-events) widget time) +(defmethod gfw:event-close ((d hellowin-events) window time) (declare (ignore widget time)) + (gfi:dispose window) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignore window time rect)) + (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:+color-white+) @@ -51,17 +54,18 @@ (defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) + (gfi:dispose *hello-win*) + (setf *hello-win* nil) (gfw:shutdown 0)) (defun run-hello-world-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize *hello-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (setf (gfw:menu-bar *hello-win*) menubar) + (gfw:show *hello-win* t))) (defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Thu Mar 16 00:17:31 2006 @@ -33,19 +33,18 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defvar *main-win* nil) + (defclass main-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d main-win-events) window time) (declare (ignore time)) + (setf *main-win* nil) (gfi:dispose window) (gfw:shutdown 0)) (defclass test-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d test-win-events) window time) - (declare (ignore time)) - (gfi:dispose window)) - (defmethod gfw:event-paint ((d test-win-events) window time gc rect) (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) @@ -53,36 +52,62 @@ (setf (gfg:background-color gc) gfg:+color-white+) (gfg:draw-filled-rectangle gc rect)) -(defun create-borderless-win ()) +(defclass test-mini-events (test-win-events) ()) -(defun create-miniframe-win ()) +(defmethod gfw:event-close ((d test-mini-events) window time) + (declare (ignore time)) + (gfi:dispose window)) + +(defclass test-borderless-events (test-win-events) ()) + +(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) + (declare (ignore time point button)) + (gfi:dispose window)) -(defun create-popup-win (disp item time rect) +(defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) - (gfw:realize window nil :style-popup) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) + (gfw:realize window *main-win* :style-borderless) + (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) + (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) + (gfw:show window t))) + +(defun create-miniframe-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-miniframe) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Mini Frame") + (gfw:show window t))) + +(defun create-palette-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-palette) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) - (setf (gfw:text window) "Popup") + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Palette") (gfw:show window t))) (defun exit-callback (disp item time rect) (declare (ignore disp item time rect)) + (gfi:dispose *main-win*) + (setf *main-win* nil) (gfw:shutdown 0)) (defun run-windlg-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize *main-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Popup" :callback #'create-popup-win)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (:item "&Palette" :callback #'create-palette-win)))))) + (setf (gfw:menu-bar *main-win*) menubar) + (gfw:show *main-win* t))) (defun run-windlg () (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Mar 16 00:17:31 2006 @@ -232,6 +232,11 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) +(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h +(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h +(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h +(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h +(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Mar 16 00:17:31 2006 @@ -75,6 +75,7 @@ msg-ptr gfs::msg) (setf (event-time (thread-context)) gfs::time) (when (zerop gm) + (dispose-thread-context) (return-from run-default-message-loop gfs::wparam)) (when (= gm -1) (warn 'gfs:win32-warning :detail "get-message failed") Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Mar 16 00:17:31 2006 @@ -49,8 +49,7 @@ (run-default-message-loop))))) (defun shutdown (exit-code) - (gfs::post-quit-message exit-code) - (dispose-thread-context)) + (gfs::post-quit-message exit-code)) (defun clear-all (w) (let ((count (gfw:item-count w))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Mar 16 00:17:31 2006 @@ -179,19 +179,28 @@ ;; pre-packaged combinations of window styles ;; - ((eq sym :style-popup) - (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) - (setf ex-flags gfs::+ws-ex-toolwindow+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) ((eq sym :style-workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ @@ -266,10 +275,11 @@ (size win)))) (defmethod realize ((win window) parent &rest style) - (if (not (null parent)) - (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future (if (not (gfi:disposed-p win)) (error 'gfs:toolkit-error :detail "object already realized")) + (unless (null parent) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) (let ((tc (thread-context))) (setf (widget-in-progress tc) win) (register-workspace-window-class) @@ -277,7 +287,7 @@ (compute-style-flags win style) (create-window +workspace-window-classname+ +default-window-title+ - (cffi:null-pointer) + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) std-style ex-style)) (clear-widget-in-progress tc) From junrue at common-lisp.net Fri Mar 17 05:42:12 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 17 Mar 2006 00:42:12 -0500 (EST) Subject: [graphic-forms-cvs] r46 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060317054212.AEC2F6713D@common-lisp.net> Author: junrue Date: Fri Mar 17 00:42:11 2006 New Revision: 46 Added: trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/text-label.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored window class to differentiate between top-level and panel windows; replaced realize generic function by moving native object creation into initialize-instance Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Mar 17 00:42:11 2006 @@ -107,5 +107,7 @@ (:file "menu-language") (:file "event") (:file "window") + (:file "top-level") + (:file "panel") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Mar 17 00:42:11 2006 @@ -91,7 +91,6 @@ ;; classes and structs ;; constants - #:+button-classname+ ;; methods, functions, macros #:detail @@ -230,6 +229,8 @@ #:layout-manager #:menu #:menu-item + #:panel + #:top-level #:widget #:widget-with-items #:window @@ -423,7 +424,6 @@ #:paste #:peer #:preferred-size - #:realize #:redraw #:redrawing-p #:remove-all Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Fri Mar 17 00:42:11 2006 @@ -190,8 +190,8 @@ (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) - (setf *event-tester-window* (make-instance 'gfw:window :dispatcher (make-instance 'event-tester-window-events))) - (gfw:realize *event-tester-window* nil :style-workspace) + (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md :submenu ((:item "&Open..." :dispatcher echo-md) (:item "&Save..." :disabled :dispatcher echo-md) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 17 00:42:11 2006 @@ -60,8 +60,8 @@ (defun run-hello-world-internal () (let ((menubar nil)) - (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize *hello-win* nil :style-workspace) + (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Fri Mar 17 00:42:11 2006 @@ -70,9 +70,19 @@ :initarg :id :initform 0))) +(defclass test-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfi:make-size :width 45 :height 45)) + +(defmethod gfw:text ((win test-panel)) + (declare (ignore win)) + "Test Panel") + (defun add-layout-tester-widget (widget-class subtype) (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w (make-instance widget-class :dispatcher be))) + (w (make-instance widget-class :parent *layout-tester-win* :dispatcher be))) (cond ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) @@ -83,11 +93,10 @@ (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+)))))) + (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :text-label) - (setf (toggle-fn be) #'(lambda () (format nil "~d ~a" (id be) +label-text+))))) - (gfw:realize w *layout-tester-win* subtype) - (setf (gfw:text w) (funcall (toggle-fn be))) + (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) (incf *widget-counter*))) (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) @@ -331,23 +340,26 @@ (let ((menubar nil) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) + (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel + :subtype :panel)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) - (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout (make-instance 'gfw:flow-layout - :spacing +spacing-delta+ - :margins +margin-delta+))) - (gfw:realize *layout-tester-win* nil :style-workspace) + (setf *layout-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'layout-tester-events) + :style '(:style-workspace) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing-delta+ + :margins +margin-delta+))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp))) + (:item "Label" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Mar 17 00:42:11 2006 @@ -57,7 +57,7 @@ :initarg :min-size :initform (gfi:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys) +(defmethod initialize-instance :after ((widget mock-widget) &key) (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) (defmethod gfw:minimum-size ((widget mock-widget)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 17 00:42:11 2006 @@ -66,16 +66,18 @@ (defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) - (gfw:realize window *main-win* :style-borderless) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) + :owner *main-win* + :style '(:style-borderless)))) (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) - (gfw:realize window *main-win* :style-miniframe) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) + :owner *main-win* + :style '(:style-miniframe)))) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") @@ -83,8 +85,9 @@ (defun create-palette-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) - (gfw:realize window *main-win* :style-palette) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) + :owner *main-win* + :style '(:style-palette)))) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") @@ -98,8 +101,8 @@ (defun run-windlg-internal () (let ((menubar nil)) - (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize *main-win* nil :style-workspace) + (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 17 00:42:11 2006 @@ -232,11 +232,6 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) -(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h -(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h -(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h -(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h -(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Mar 17 00:42:11 2006 @@ -61,6 +61,21 @@ (setf std-flags gfs::+bs-pushbox+)))) (values std-flags ex-flags))) +(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) + (if (not (listp style)) + (setf style (list style))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags btn style) + (let ((hwnd (create-window gfs::+button-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value btn 'gfi:handle) hwnd))) + (init-control btn)) + (defmethod preferred-size ((btn button) width-hint height-hint) (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) (if (>= width-hint 0) @@ -71,18 +86,6 @@ (setf (gfi:size-height sz) (+ (gfi:size-height sz) 10))) sz)) -(defmethod realize ((btn button) parent &rest style) - (multiple-value-bind (std-style ex-style) - (compute-style-flags btn style) - (let ((hwnd (create-window gfs:+button-classname+ - " " - (gfi:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) - ex-style))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value btn 'gfi:handle) hwnd)))) - (defmethod text ((btn button)) (get-widget-text btn)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Mar 17 00:42:11 2006 @@ -34,30 +34,30 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; -(defmethod preferred-size :before ((ctl control) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (if (gfi:disposed-p ctl) - (error 'gfi:disposed-error))) - -(defmethod realize :before ((ctl control) parent &rest style) - (declare (ignore style)) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error)) - (if (not (gfi:disposed-p ctl)) - (error 'gfs:toolkit-error :detail "object already realized"))) - -(defmethod realize :after ((ctl control) parent &rest style) - (declare (ignorable parent style)) - (let ((hwnd (gfi:handle ctl))) +(defun init-control (ctrl) + (let ((hwnd (gfi:handle ctrl))) (subclass-wndproc hwnd) - (put-widget (thread-context) ctl) + (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfi:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd - gfs::+wm-setfont+ - (cffi:pointer-address hfont) - 0)) + gfs::+wm-setfont+ + (cffi:pointer-address hfont) + 0)) (error 'gfs:win32-error :detail "send-message failed")))))) + +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) + +(defmethod preferred-size :before ((ctrl control) width-hint height-hint) + (declare (ignorable width-hint height-hint)) + (if (gfi:disposed-p ctrl) + (error 'gfi:disposed-error))) Added: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 17 00:42:11 2006 @@ -0,0 +1,71 @@ +;;;; +;;;; panel.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) + +(defconstant +panel-window-classname+ "GraphicFormsPanel") + +;;; +;;; helper functions +;;; + +(defun register-panel-window-class () + (register-window-class +panel-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + gfs::+color-btnface+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((win panel) &rest style) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (ex-flags 0)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; + ((eq sym :style-border) + (setf std-flags (logior std-flags gfs::+ws-border+))))) + (flatten style)) + (values std-flags ex-flags))) + +(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) + (if (null parent) + (error 'gfs:toolkit-error :detail "parent is required for panel")) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error)) + (if (not (listp style)) + (setf style (list style))) + (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/text-label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/text-label.lisp Fri Mar 17 00:42:11 2006 @@ -72,6 +72,22 @@ (setf std-flags (logior std-flags gfs::+ss-left+))))) (values std-flags ex-flags))) +(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys) + (if (not (listp style)) + (setf style (list style))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags label style) + (let ((hwnd (create-window gfs::+static-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value label 'gfi:handle) hwnd))) + (init-control label)) + + (defmethod preferred-size ((label text-label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) @@ -90,18 +106,6 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod realize ((label text-label) parent &rest style) - (multiple-value-bind (std-style ex-style) - (compute-style-flags label style) - (let ((hwnd (create-window gfs::+static-classname+ - " " - (gfi:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) - ex-style))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfi:handle) hwnd)))) - (defmethod text ((label text-label)) (get-widget-text label)) Added: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/top-level.lisp Fri Mar 17 00:42:11 2006 @@ -0,0 +1,172 @@ +;;;; +;;;; top-level.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) + +(defconstant +toplevel-window-classname+ "GraphicFormsTopLevel") + +(defconstant +default-window-title+ "New Window") + +;;; +;;; helper functions +;;; + +(defun register-toplevel-window-class () + (register-window-class +toplevel-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + gfs::+color-appworkspace+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((win top-level) &rest style) + (declare (ignore win)) + (let ((std-flags 0) + (ex-flags 0)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; +#| + ((eq sym :style-hscroll) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + ((eq sym :style-max) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + ((eq sym :style-min) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + ((eq sym :style-resize) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) + ((eq sym :style-sysmenu) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + ((eq sym :style-title) + (setf std-flags (logior std-flags gfs::+ws-caption+))) + ((eq sym :style-top) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) + ((eq sym :style-vscroll) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) +|# + + ;; pre-packaged combinations of window styles + ;; + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) + ((eq sym :style-workspace) + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)))) + (flatten style)) + (values std-flags ex-flags))) + +(defmethod gfi:dispose ((win top-level)) + (let ((m (menu-bar win))) + (unless (null m) + (visit-menu-tree m #'menu-cleanup-callback) + (remove-widget (thread-context) (gfi:handle m)))) + (call-next-method)) + +(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) + (unless (null owner) + (if (gfi:disposed-p owner) + (error 'gfi:disposed-error))) + (if (null title) + (setf title +default-window-title+)) + (if (not (listp style)) + (setf style (list style))) + (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title)) + +(defmethod menu-bar :before ((win top-level)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod menu-bar ((win top-level)) + (let ((hmenu (gfs::get-menu (gfi:handle win)))) + (if (gfi:null-handle-p hmenu) + (return-from menu-bar nil)) + (let ((m (get-widget (thread-context) hmenu))) + (if (null m) + (error 'gfs:toolkit-error :detail "no object for menu handle")) + m))) + +(defmethod (setf menu-bar) :before ((m menu) (win top-level)) + (declare (ignore m)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod (setf menu-bar) ((m menu) (win top-level)) + (let* ((hwnd (gfi:handle win)) + (hmenu (gfs::get-menu hwnd)) + (old-menu (get-widget (thread-context) hmenu))) + (unless (gfi:null-handle-p hmenu) + (gfs::destroy-menu hmenu)) + (unless (null old-menu) + (gfi:dispose old-menu)) + (gfs::set-menu hwnd (gfi:handle m)) + (gfs::draw-menu-bar hwnd))) + +(defmethod text :before ((win top-level)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod text ((win top-level)) + (get-widget-text win)) + +(defmethod (setf text) :before (str (win top-level)) + (declare (ignore str)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod (setf text) (str (win top-level)) + (set-widget-text win str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 17 00:42:11 2006 @@ -60,7 +60,7 @@ (:documentation "The caret class provides an i-beam typically representing an insertion point.")) (defclass control (widget) () - (:documentation "The base class for widgets that process user input and/or display items.")) + (:documentation "The base class for widgets having pre-defined native behavior.")) (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) @@ -76,7 +76,7 @@ :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 fine-grained items.")) + (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) @@ -89,4 +89,10 @@ :accessor layout-of :initarg :layout :initform nil)) - (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows).")) + (:documentation "Base class for user-defined widgets that serve as containers.")) + +(defclass panel (window) () + (:documentation "Base class for windows that are children of top-level windows (or other panels).")) + +(defclass top-level (window) () + (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 17 00:42:11 2006 @@ -255,9 +255,6 @@ (defgeneric preferred-size (object width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) -(defgeneric realize (object parent &rest style) - (:documentation "Realizes the object on the screen.")) - (defgeneric redraw (object) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 17 00:42:11 2006 @@ -179,6 +179,10 @@ (declare (ignore w)) nil) +(defmethod size :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod size ((w widget)) (client-size w)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 17 00:42:11 2006 @@ -33,14 +33,27 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow") - -(defconstant +default-window-title+ "New Window") - ;;; ;;; helper functions ;;; +(defun init-window (win classname register-class-fn style parent text) + (let ((tc (thread-context))) + (setf (widget-in-progress tc) win) + (funcall register-class-fn) + (multiple-value-bind (std-style ex-style) + (compute-style-flags win style) + (create-window classname + text + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) + std-style + ex-style)) + (clear-widget-in-progress tc) + (let ((hwnd (gfi:handle win))) + (if (not hwnd) ; handle slot should have been set during create-window + (error 'gfs:win32-error :detail "create-window failed")) + (put-widget tc win)))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -85,7 +98,7 @@ (pop-child-visitor-func tc))) nil) -(defun register-window-class (class-name proc-ptr st) +(defun register-window-class (class-name proc-ptr style bkgcolor) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -100,7 +113,7 @@ str-ptr wc-ptr)) (progn (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) - (setf gfs::style st) + (setf gfs::style style) (setf gfs::wndproc proc-ptr) (setf gfs::clsextra 0) (setf gfs::wndextra 0) @@ -111,7 +124,7 @@ gfs::+image-cursor+ 0 0 (logior gfs::+lr-defaultcolor+ gfs::+lr-shared+))) - (setf gfs::hbrush (cffi:make-pointer (1+ gfs::+color-appworkspace+))) + (setf gfs::hbrush (cffi:make-pointer (1+ bkgcolor))) (setf gfs::menuname (cffi:null-pointer)) (setf gfs::classname str-ptr) (setf gfs::smallicon (cffi:null-pointer)) @@ -130,16 +143,13 @@ (setf ,var (reverse ,var)) , at body))) -(defun register-workspace-window-class () - (register-window-class +workspace-window-classname+ - (cffi:get-callback 'uit_widgets_wndproc) - (logior gfs::+cs-hredraw+ gfs::+cs-vredraw+))) - ;;; ;;; methods ;;; (defmethod compute-outer-size ((win window) desired-client-size) + ;; TODO: consider reimplementing this with AdjustWindowRect + ;; (let ((client-sz (client-size win)) (outer-sz (size win)) (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) @@ -150,72 +160,6 @@ (gfi:size-height client-sz))) trim-sz)) -(defmethod compute-style-flags ((win window) &rest style) - (declare (ignore win)) - (let ((std-flags 0) - (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; - ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) -#| - ((eq sym :style-max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# - ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :style-borderless) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-border+ - gfs::+ws-popup+)) - (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :style-palette) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-popupwindow+ - gfs::+ws-caption+)) - (setf ex-flags (logior gfs::+ws-ex-toolwindow+ - gfs::+ws-ex-windowedge+))) - ((eq sym :style-miniframe) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-popup+ - gfs::+ws-thickframe+ - gfs::+ws-sysmenu+ - gfs::+ws-caption+)) - (setf ex-flags (logior gfs::+ws-ex-appwindow+ - gfs::+ws-ex-toolwindow+))) - ((eq sym :style-workspace) - (setf std-flags (logior gfs::+ws-overlappedwindow+ - gfs::+ws-clipsiblings+ - gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (flatten style)) - (values std-flags ex-flags))) - -(defmethod gfi:dispose ((win window)) - (let ((m (menu-bar win))) - (unless (null m) - (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (thread-context) (gfi:handle m)))) - (call-next-method)) - (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) (if (gfi:disposed-p win) @@ -232,37 +176,17 @@ (let ((sz (client-size win))) (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) -(defmethod location ((w window)) - (if (gfi:disposed-p w) +(defmethod location ((win window)) + (if (gfi:disposed-p win) (error 'gfi:disposed-error)) (let ((pnt (gfi:make-point))) - (outer-location w pnt) + (outer-location win pnt) pnt)) (defmethod layout ((win window)) (let ((sz (client-size win))) (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) -(defmethod menu-bar ((win window)) - (let ((hmenu (gfs::get-menu (gfi:handle win)))) - (if (gfi:null-handle-p hmenu) - (return-from menu-bar nil)) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no object for menu handle")) - m))) - -(defmethod (setf menu-bar) ((m menu) (win window)) - (let* ((hwnd (gfi:handle win)) - (hmenu (gfs::get-menu hwnd)) - (old-menu (get-widget (thread-context) hmenu))) - (unless (gfi:null-handle-p hmenu) - (gfs::destroy-menu hmenu)) - (unless (null old-menu) - (gfi:dispose old-menu)) - (gfs::set-menu hwnd (gfi:handle m)) - (gfs::draw-menu-bar hwnd))) - (defmethod pack ((win window)) (perform-layout win -1 -1) (call-next-method)) @@ -274,42 +198,12 @@ (compute-outer-size win new-client-sz)) (size win)))) -(defmethod realize ((win window) parent &rest style) - (if (not (gfi:disposed-p win)) - (error 'gfs:toolkit-error :detail "object already realized")) - (unless (null parent) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error))) - (let ((tc (thread-context))) - (setf (widget-in-progress tc) win) - (register-workspace-window-class) - (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) - (create-window +workspace-window-classname+ - +default-window-title+ - (if (null parent) (cffi:null-pointer) (gfi:handle parent)) - std-style - ex-style)) - (clear-widget-in-progress tc) - (let ((hwnd (gfi:handle win))) - (if (not hwnd) ; handle slot should have been set during create-window - (error 'gfs:win32-error :detail "create-window failed")) - (put-widget tc win)))) - (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method) (gfs::update-window (gfi:handle win))) (defmethod size ((win window)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error)) (let ((sz (gfi:make-size))) (outer-size win sz) sz)) - -(defmethod text ((win window)) - (get-widget-text win)) - -(defmethod (setf text) (str (win window)) - (set-widget-text win str)) From junrue at common-lisp.net Sat Mar 18 19:17:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 18 Mar 2006 14:17:32 -0500 (EST) Subject: [graphic-forms-cvs] r47 - trunk/docs/website Message-ID: <20060318191732.E1F5B77015@common-lisp.net> Author: junrue Date: Sat Mar 18 14:17:32 2006 New Revision: 47 Added: trunk/docs/website/sourceforge.html Modified: trunk/docs/website/docs.html trunk/docs/website/download.html trunk/docs/website/index.html trunk/docs/website/screenshots.html Log: updated for newly-created SourceForge project Modified: trunk/docs/website/docs.html ============================================================================== --- trunk/docs/website/docs.html (original) +++ trunk/docs/website/docs.html Sat Mar 18 14:17:32 2006 @@ -3,12 +3,16 @@ Graphic-Forms Documentation - - + + +
+

Graphic-Forms documentation

+
+

Programming Reference

FAQ

Modified: trunk/docs/website/download.html ============================================================================== --- trunk/docs/website/download.html (original) +++ trunk/docs/website/download.html Sat Mar 18 14:17:32 2006 @@ -3,28 +3,33 @@ Graphic-Forms Source Control - - + + +
+

Graphic-Forms downloads

+
+

Graphic-Forms is distributed in source code form. Please choose from one of the following options:

Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Sat Mar 18 14:17:32 2006 @@ -3,32 +3,32 @@ Graphic-Forms project - - + + -
-

Graphic-Forms

-

A user interface toolkit for the Windows® platform.

-
- - - - -

Introduction

- -

Graphic-Forms is a user interface library implemented in - Common Lisp focusing on the - Windows® platform. Graphic-Forms is licensed under the - terms of the - BSD License.

+
+

Graphic-Forms

+

A user interface toolkit for the Windows® platform.

+
+ + + + +

Introduction

+ +

Graphic-Forms is a user interface library implemented in + Common Lisp focusing on the + Windows® platform. Graphic-Forms is licensed under the + terms of the + BSD License.

In the near term, the goal is to provide a toolkit encapsulating the underlying Modified: trunk/docs/website/screenshots.html ============================================================================== --- trunk/docs/website/screenshots.html (original) +++ trunk/docs/website/screenshots.html Sat Mar 18 14:17:32 2006 @@ -3,12 +3,16 @@ Graphic-Forms Screenshots - - + + +

+

Graphic-Forms screenshots

+
+

Screenshots coming soon...stay tuned!

From junrue at common-lisp.net Sun Mar 19 17:42:21 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 19 Mar 2006 12:42:21 -0500 (EST) Subject: [graphic-forms-cvs] r50 - in trunk: . src src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060319174221.B3C654006@common-lisp.net> Author: junrue Date: Sun Mar 19 12:42:18 2006 New Revision: 50 Added: trunk/src/intrinsics/system/clib.lisp trunk/src/tests/uitoolkit/blackwhite20x16.bmp (contents, props changed) trunk/src/tests/uitoolkit/happy.bmp (contents, props changed) trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/truecolor16x16.bmp (contents, props changed) trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp Removed: trunk/src/uitoolkit/graphics/file-formats.lisp Modified: trunk/build.lisp trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/palette.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/tests.lisp Log: integrated ImageMagick and got rid of home-grown bmp parsing; fixed bugs in data->image and draw-image in order for image-tester to partially work -- bitmap transparency is next Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Mar 19 12:42:18 2006 @@ -39,20 +39,22 @@ (defvar *external-build-dirs* nil) -(defvar *library-root* "c:/projects/third_party/") -(defvar *project-root* "c:/projects/public/") +(defvar *library-root* "c:/projects/third_party/") +(defvar *project-root* "c:/projects/public/") -(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) +(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) -(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) -(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) -(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) -(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) -(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) - -(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") -(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) +(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) +(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") +(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) +(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) +(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) + +(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") +(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defvar *asdf-dirs* (list *cffi-dir* *closer-mop-dir* @@ -99,10 +101,6 @@ (asdf:operate 'asdf:load-op :closer-mop) (if *external-build-dirs* - (chdir *cffi-build-dir*)) - (asdf:operate 'asdf:load-op :cffi) - - (if *external-build-dirs* (chdir *pcl-ch08-build-dir*)) (asdf:operate 'asdf:load-op :macro-utilities) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 19 12:42:18 2006 @@ -50,8 +50,10 @@ ((:module "uitoolkit" :components ((:file "mock-objects") + (:file "image-unit-tests") (:file "layout-unit-tests") (:file "hello-world") (:file "event-tester") (:file "layout-tester") + (:file "image-tester") (:file "windlg"))))))))) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 19 12:42:18 2006 @@ -58,6 +58,7 @@ ((:file "native-classes") (:file "native-conditions") (:file "native-object-generics") + (:file "clib") (:file "native-object"))))) (:module "uitoolkit" :depends-on ("intrinsics") @@ -74,11 +75,12 @@ (:module "graphics" :depends-on ("system") :components - ((:file "graphics-classes") + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "graphics-classes") (:file "graphics-generics") (:file "color") (:file "palette") - (:file "file-formats") (:file "image-data") (:file "image") (:file "font") Added: trunk/src/intrinsics/system/clib.lisp ============================================================================== --- (empty file) +++ trunk/src/intrinsics/system/clib.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; clib.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.intrinsics) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(defcfun + ("strncpy" strncpy) + :pointer + (dest :pointer) + (src :pointer) + (count :unsigned-int)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 12:42:18 2006 @@ -136,7 +136,6 @@ #:average-char-width #:background-color #:background-pattern - #:bits-per-pixel #:blue-mask #:blue-shift #:clipped-p @@ -148,9 +147,8 @@ #:color-table #:copy-area #:data-obj + #:depth #:descent - #:direct - #:direct-p #:draw-arc #:draw-filled-arc #:draw-filled-oval @@ -174,8 +172,6 @@ #:green-mask #:green-shift #:height - #:image-data-type - #:image-palette #:invert #:leading #:line-cap-style @@ -183,18 +179,14 @@ #:line-join-style #:line-style #:line-width + #:load #:make-color - #:make-image-data - #:make-palette #:matrix #:maximum-char-width #:metrics #:multiply - #:pixel-color - #:pixels #:red-mask #:red-shift - #:register-image-loader #:rotate #:scale #:size Added: trunk/src/tests/uitoolkit/blackwhite20x16.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/happy.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Mar 19 12:42:18 2006 @@ -38,7 +38,7 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d hellowin-events) window time) - (declare (ignore widget time)) + (declare (ignore time)) (gfi:dispose window) (gfw:shutdown 0)) Added: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,86 @@ +;;;; +;;;; image-tester.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 *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *true-image* nil) + +(defclass image-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (gfi:dispose *happy-image*) + (setf *happy-image* nil) + (gfi:dispose *bw-image*) + (setf *bw-image* nil) + (gfi:dispose *true-image*) + (setf *true-image* nil) + (gfi:dispose *image-win*) + (setf *image-win* nil) + (gfw:shutdown 0)) + +(defmethod gfw:event-paint ((d image-events) window time gc rect) + (declare (ignore window time rect)) + (let ((pnt (gfi:make-point))) + (gfg:draw-image gc *happy-image* pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *bw-image* pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *true-image* pnt))) + +(defun exit-image-fn (disp item time rect) + (declare (ignorable disp item time rect)) + (gfi:dispose *image-win*) + (setf *image-win* nil) + (gfw:shutdown 0)) + +(defun run-image-tester-internal () + (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 '(:style-workspace))) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) + (setf (gfw:menu-bar *image-win*) menubar) + (gfw:show *image-win* t))) + +(defun run-image-tester () + (gfw:startup "Image Tester" #'run-image-tester-internal)) Added: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,73 @@ +;;;; +;;;; image-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) + +(defun image-data-tester (path) + (let ((d1 (make-instance 'gfg:image-data)) + (d2 nil) + (d3 nil) + (im (make-instance 'gfg:image)) + (hbmp (cffi:null-pointer))) + (unwind-protect + (progn + (gfg:load d1 path) + (cffi:with-foreign-string (ptr path) + (setf hbmp (gfs::load-image nil + ptr + gfs::+image-bitmap+ + 0 0 + (logior gfs::+lr-loadfromfile+ + gfs::+lr-createdibsection+)))) + (if (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "load-image failed")) + (setf d2 (gfg::image->data hbmp)) + (assert-equal (gfg:depth d1) (gfg:depth d2) path) + (let ((size1 (gfg:size d1)) + (size2 (gfg:size d2))) + (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) + (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (gfg:load im path) + (setf d3 (gfg:data-obj im)) + (assert-equal (gfg:depth d1) (gfg:depth d3) path) + (let ((size1 (gfg:size d1)) + (size2 (gfg:size d3))) + (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) + (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (unless (gfi:disposed-p im) + (gfi:dispose im)) + (unless (gfi:null-handle-p hbmp) + (gfs::delete-object hbmp)))))) + +(define-test image-data-loading-test + (mapc #'image-data-tester '("blackwhite20x16.bmp" "happy.bmp" "truecolor16x16.bmp"))) Added: trunk/src/tests/uitoolkit/truecolor16x16.bmp ============================================================================== 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 Sun Mar 19 12:42:18 2006 @@ -37,61 +37,47 @@ (defstruct color (red 0) (green 0) - (blue 0))) + (blue 0)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defstruct font-metrics (ascent 0) (descent 0) (leading 0) (avg-char-width 0) - (max-char-width 0))) + (max-char-width 0)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro ascent (metrics) - `(gfg::font-metrics-ascent ,metrics))) + `(gfg::font-metrics-ascent ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro descent (metrics) - `(gfg::font-metrics-descent ,metrics))) + `(gfg::font-metrics-descent ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro leading (metrics) - `(gfg::font-metrics-leading ,metrics))) + `(gfg::font-metrics-leading ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro height (metrics) `(+ (gfg::font-metrics-ascent ,metrics) (gfg::font-metrics-descent ,metrics) - (gfg::font-metrics-leading ,metrics)))) + (gfg::font-metrics-leading ,metrics))) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro average-char-width (metrics) - `(gfg::font-metrics-avg-char-width ,metrics))) + `(gfg::font-metrics-avg-char-width ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro maximum-char-width (metrics) - `(gfg::font-metrics-max-char-width ,metrics))) + `(gfg::font-metrics-max-char-width ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct image-data - (pixels nil) ; vector of bytes - (bits-per-pixel 0) ; number of bits per pixel - (palette nil) ; palette - (size (gfi:make-size)) ; width and height of image in pixels - (type 'bmp))) ; symbol corresponding to file extension (e.g., 'bmp) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro bits-per-pixel (data) - `(gfg::image-data-bits-per-pixel ,data))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro image-palette (data) - `(gfg::image-data-palette ,data))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro pixels (data) - `(gfg::image-data-pixels ,data))) + (defstruct palette + (red-mask 0) + (green-mask 0) + (blue-mask 0) + (red-shift 0) + (green-shift 0) + (blue-shift 0) + (direct nil) + (table nil))) ; vector of COLOR structs + +(defclass image-data (gfi:native-object) () + (:documentation "This class maintains image attributes, color, and pixel data.")) (defclass font (gfi:native-object) () (:documentation "This class encapsulates a realized native font.")) @@ -106,17 +92,6 @@ :initform (make-color))) (:documentation "This class represents an image of a particular type (BMP, PNG, etc.).")) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct palette - (red-mask 0) - (green-mask 0) - (blue-mask 0) - (red-shift 0) - (green-shift 0) - (blue-shift 0) - (direct nil) - (table nil))) ; vector of COLOR structs - (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) @@ -126,10 +101,6 @@ (defmacro direct (data flag) `(setf (gfg::palette-direct ,data) ,flag)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro direct-p (data) - `(null (gfg::palette-direct ,data)))) - (defmacro green-mask (data) `(gfg::palette-green-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 19 12:42:18 2006 @@ -90,20 +90,20 @@ ;; TODO: support addressing elements within bitmap as if it were an array ;; (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - oldhbm) + (oldhbm (cffi:null-pointer))) (if (gfi:null-handle-p memdc) (error 'gfs:win32-error :detail "create-compatible-dc failed")) (setf oldhbm (gfs::select-object memdc (gfi:handle im))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (gfs::bit-blt (gfi:handle gc) - (gfi:point-x pnt) - (gfi:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) - memdc - 0 0 - gfs::+blt-srccopy+)) + (gfi:point-x pnt) + (gfi:point-y pnt) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) + memdc + 0 0 + gfs::+blt-srccopy+)) (gfs::select-object memdc oldhbm) (gfs::delete-dc memdc))) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 19 12:42:18 2006 @@ -57,6 +57,9 @@ (defgeneric data-obj (object) (:documentation "Returns the data structure representing the raw form of the object.")) +(defgeneric depth (object) + (:documentation "Returns the bits-per-pixel depth of the object.")) + (defgeneric draw-arc (object rect start-angle arc-angle) (:documentation "Draws the outline of a circular or elliptical arc within the specified rectangular area.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sun Mar 19 12:42:18 2006 @@ -33,110 +33,12 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defvar *loaders-by-type* (make-hash-table :test #'equal)) - -;;; -;;; image loader functions -;;; - -(defmacro bmp-pixel-row-length (im-width im-bit-count) - `(ash (logand (+ (* ,im-width ,im-bit-count) 31) (lognot 31)) -3)) - -(defun bmp-loader (path victim) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in)) - (pix-bits nil)) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: 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) (make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (image-data-palette victim) (make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bmp-pixel-row-length (biWidth info) (biBitCount info)))) - (setf pix-bits (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence pix-bits in)) - - ;; populate and return image-data object - ;; - (setf (image-data-pixels victim) pix-bits) - (setf (image-data-bits-per-pixel victim) (biBitCount info)) - (setf (size victim) (gfi:make-size :width (biWidth info) :height (biHeight info))) - (setf (image-data-type victim) 'bmp) - victim))) - -#| -(define-binary-type raw-data (size width) - (:reader (in) - (let ((buf (make-array size :element-type '(unsigned-byte width)))) - (read-sequence buf in) - buf)) - (:writer (out) - (write-sequence buf out))) -|# - -#| -(defun bmp-loader (path) - (let (hwnd) - (cffi:with-foreign-string (ptr (namestring path)) - (setf hwnd (gfs::load-image nil - ptr - gfs::+image-bitmap+ - 0 0 - gfs::+lr-loadfromfile+))) - (if (gfi:null-handle-p hwnd) - (error 'gfs:win32-error :detail "load-image failed")) - hwnd)) -|# - -(setf (gethash "bmp" *loaders-by-type*) #'bmp-loader) - ;;; ;;; helper functions ;;; -(defun register-image-loader (file-type loader-fn) - "Associate a new (or replacement) loader function with the specified file type. \ -Returns the previous loader function, if any." - (unless (typep file-type 'string) - (error 'gfs:toolkit-error :detail "file-type must be a string")) - (unless (typep loader-fn 'function) - (error 'gfs:toolkit-error :detail "loader-fn must be a function")) - (let ((old-fn (gethash file-type *loaders-by-type*))) - (setf (gethash file-type *loaders-by-type*) loader-fn) - old-fn)) - +(defun image->data (hbmp) (declare (ignore hbmp))) +#| (defun image->data (hbmp) "Convert the native bitmap handle to an image-data." (let ((mem-dc (gfs::create-compatible-dc (cffi:null-pointer))) @@ -222,6 +124,7 @@ (cffi:foreign-free raw-bits)) (gfs::delete-dc mem-dc)) data)) +|# (defun data->image (data) "Convert the image-data object to a bitmap and return the native handle." @@ -239,20 +142,20 @@ gfs::biclrimp gfs::bmicolors) bi-ptr gfs::bitmapinfo) - (let* ((sz (size data)) - (colors (palette-table (image-palette data))) - (bit-count (bits-per-pixel data)) - (row-len (bmp-pixel-row-length (gfi:size-width sz) bit-count)) - (byte-count (* row-len (gfi:size-height sz))) - (data-bits (pixels data)) - (pix-bits (cffi:null-pointer)) + (let* ((handle (gfi:handle data)) + (sz (size data)) + (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) + (bit-count (depth data)) (hbmp (cffi:null-pointer)) - (mem-dc (gfs::create-compatible-dc (cffi:null-pointer)))) + (screen-dc (gfs::get-dc (cffi:null-pointer)))) +(format t "bi-size: ~a~%" (cffi:foreign-type-size 'gfs::bitmapinfoheader)) +(format t "bit-count: ~a~%" bit-count) +(format t "size: ~a ~a~%" (gfi:size-width sz) (gfi:size-height sz)) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) (setf gfs::biwidth (gfi:size-width sz)) - (setf gfs::biheight (gfi:size-height sz)) + (setf gfs::biheight (- 0 (gfi:size-height sz))) (setf gfs::biplanes 1) - (setf gfs::bibitcount bit-count) + (setf gfs::bibitcount 32) ;; 32bpp even if original image file is not (setf gfs::bicompression gfs::+bi-rgb+) (setf gfs::bisizeimage 0) (setf gfs::bixpels 0) @@ -260,73 +163,111 @@ (setf gfs::biclrused 0) (setf gfs::biclrimp 0) - (unwind-protect - (progn - - ;; populate the RGBQUADs - ;; - (dotimes (i (length colors)) - (let ((clr (aref colors i))) - (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen - gfs::rgbred gfs::rgbreserved) - (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i) - gfs::rgbquad) - (setf gfs::rgbblue (color-blue clr)) - (setf gfs::rgbgreen (color-green clr)) - (setf gfs::rgbred (color-red clr)) - (setf gfs::rgbreserved 0)))) - - ;; populate the pixel data - ;; - (setf pix-bits (cffi:foreign-alloc :unsigned-char :count byte-count)) - (dotimes (i byte-count) - (setf (cffi:mem-aref pix-bits :unsigned-char i) (aref data-bits i))) + ;; 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 (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) - ;; create the bitmap - ;; - (setf hbmp (gfs::create-di-bitmap mem-dc - bi-ptr - 0 ; gfs::+cbm-init+ - pix-bits - bi-ptr - gfs::+dib-rgb-colors+)) - (if (gfi:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-di-bitmap failed"))) - (unless (cffi:null-pointer-p pix-bits) - (cffi:foreign-free pix-bits)) - (gfs::delete-dc mem-dc)) - hbmp)))) + ;; update the RGBQUADs + ;; + (let ((tmp (get-image-pixels handle 0 0 (gfi:size-width sz) (gfi:size-height sz))) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i pix-count) + (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved) + (cffi:mem-aref tmp 'gfg::pixel-packet i) + gfg::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)))))) + hbmp))))) ;;; ;;; methods ;;; -(defmethod load ((d image-data) path) +(defmethod depth ((data image-data)) + (let ((handle (gfi:handle data))) + (if (null handle) + (error 'gfi:disposed-error)) + (cffi:foreign-slot-value handle 'magick-image 'depth))) + +(defmethod gfi:dispose ((data image-data)) + (let ((victim (gfi:handle data))) + (if (null victim) + (error 'gfi:disposed-error)) + (destroy-image victim)) + (setf (slot-value data 'gfi:handle) nil)) + +(defmethod load ((data image-data) path) (setf path (cond - ((typep path 'pathname) path) - ((typep path 'string) - (parse-namestring path)) + ((typep path 'pathname) (namestring path)) + ((typep path 'string) path) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - (let* ((ptype (pathname-type path)) - (fn (gethash ptype *loaders-by-type*))) - (if (null fn) - (error 'gfs:toolkit-error - :detail (format nil "no loader registered for type: ~a" ptype))) - (funcall fn path d) - d)) - -(defmethod size ((obj image-data)) - (image-data-size obj)) - -(defmethod (setf size) (sz (obj image-data)) - (setf (image-data-size obj) sz)) - -(defmethod print-object ((obj image-data) stream) - (print-unreadable-object (obj stream :type t) - (format stream "type: ~a " (image-data-type obj)) - (format stream "width: ~a " (gfi:size-width (image-data-size obj))) - (format stream "height: ~a " (gfi:size-height (image-data-size obj))) - (format stream "bits per pixel: ~a " (bits-per-pixel obj)) - (format stream "pixel count: ~a " (length (pixels obj))) - (format stream "palette: ~a" (image-palette obj)))) + (let ((handle (gfi:handle data))) + (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) + (destroy-image handle) + (setf (slot-value data 'gfi: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-string-to-lisp (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 data 'gfi:handle) handle)))) + +(defmethod size ((data image-data)) + (let ((handle (gfi:handle data)) + (size (gfi:make-size))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfi:disposed-error)) + (cffi:with-foreign-slots ((rows columns) handle magick-image) + (setf (gfi:size-height size) rows) + (setf (gfi:size-width size) columns)) + size)) + +(defmethod (setf size) (size (data image-data)) + (let ((handle (gfi:handle data)) + (new-handle (cffi:null-pointer)) + (ex (acquire-exception-info))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfi:disposed-error)) + (unwind-protect + (progn + (setf new-handle (resize-image handle + (gfi:size-width size) + (gfi:size-height size) + (cffi:foreign-enum-value 'filter-types :lanczos) + 1.0 ex)) + (if (gfi:null-handle-p new-handle) + (error 'gfs:toolkit-error :detail (format nil + "could not resize: ~a" + (cffi:foreign-slot-value ex + 'exception-info + 'reason)))) + (setf (slot-value data 'gfi:handle) new-handle) + (destroy-image handle)) + (destroy-exception-info ex)))) + +(defmethod print-object ((data image-data) stream) + (if (or (null (gfi:handle data)) (cffi:null-pointer-p (gfi:handle data))) + (error 'gfi:disposed-error)) + (let ((size (size data))) + (print-unreadable-object (data stream :type t) + ;; FIXME: dump palette info, too + ;; + (format stream "width: ~a " (gfi:size-width size)) + (format stream "height: ~a " (gfi:size-height size)) + (format stream "bits per pixel: ~a " (depth data))))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 12:42:18 2006 @@ -59,13 +59,7 @@ (setf (slot-value im 'gfi:handle) (data->image id))) (defmethod load ((im image) path) - (let ((data (make-image-data))) + (let ((data (make-instance 'image-data))) (load data path) (setf (data-obj im) data) data)) - -(defmethod size ((im image)) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) - -(defmethod transparency-mask ((im image)) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) Added: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,198 @@ +;;;; +;;;; magick-core-api.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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi) + (pushnew gfsys::*imagemagick-dir* *foreign-library-directories*)) + +(define-foreign-library wsock32 (t (:default "wsock32"))) +(define-foreign-library msvcr71 (t (:default "msvcr71"))) +(define-foreign-library x11 (t (:default "x11"))) +(define-foreign-library core_rl_bzlib (t (:default "CORE_RL_bzlib_"))) +(define-foreign-library core_rl_jbig (t (:default "CORE_RL_jbig_"))) +(define-foreign-library core_rl_jpeg (t (:default "CORE_RL_jpeg_"))) +(define-foreign-library core_rl_lcms (t (:default "CORE_RL_lcms_"))) +(define-foreign-library core_rl_zlib (t (:default "CORE_RL_zlib_"))) +(define-foreign-library core_rl_png (t (:default "CORE_RL_png_"))) +(define-foreign-library core_rl_tiff (t (:default "CORE_RL_tiff_"))) +(define-foreign-library core_rl_ttf (t (:default "CORE_RL_ttf_"))) +(define-foreign-library core_rl_xlib (t (:default "CORE_RL_xlib_"))) +(define-foreign-library core_rl_magick (t (:default "CORE_RL_magick_"))) + +(use-foreign-library wsock32) +(use-foreign-library msvcr71) +(use-foreign-library x11) +(use-foreign-library core_rl_bzlib) +(use-foreign-library core_rl_jbig) +(use-foreign-library core_rl_jpeg) +(use-foreign-library core_rl_lcms) +(use-foreign-library core_rl_zlib) +(use-foreign-library core_rl_png) +(use-foreign-library core_rl_tiff) +(use-foreign-library core_rl_ttf) +(use-foreign-library core_rl_xlib) +(use-foreign-library core_rl_magick) + +;;; +;;; translated from constitute.h +;;; + +(defcfun + ("ConstituteImage" constitute-image) + :pointer ;; Image* + (columns :unsigned-long) + (rows :unsigned-long) + (map :pointer) ;; const char* + (storage storage-type) + (pixels :pointer) ;; void* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("PingImage" ping-image) + :pointer ;; Image* + (image-info :pointer) ;; ImageInfo* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("ReadImage" read-image) + :pointer ;; Image* + (image-info :pointer) ;; ImageInfo* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("WriteImage" write-image) + boolean-type + (image-info :pointer) ;; ImageInfo* + (image :pointer)) ;; Image* + +;;; +;;; translated from exception.h +;;; + +(defcfun + ("AcquireExceptionInfo" acquire-exception-info) + :pointer) + +(defcfun + ("CatchException" catch-exception) + :void + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("ClearMagickException" clear-magick-exception) + :void + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("DestroyExceptionInfo" destroy-exception-info) + :pointer ;; ExceptionInfo* + (exception :pointer)) ;; ExceptionInfo* + +;;; +;;; translated from image.h +;;; + +(defcfun + ("CloneImageInfo" clone-image-info) + :pointer ;; ImageInfo* + (orig :pointer)) ;; ImageInfo* + +(defcfun + ("DestroyImage" destroy-image) + :pointer ;; Image* + (victim :pointer)) ;; Image* + +(defcfun + ("DestroyImageInfo" destroy-image-info) + :pointer ;; ImageInfo* + (victim :pointer)) ;; ImageInfo* + +(defcfun + ("GetImagePixels" get-image-pixels) + :pointer ;; PixelPacket* + (image :pointer) ;; Image* + (x :long) + (y :long) + (width :unsigned-long) + (height :unsigned-long)) + +(defun scale-quantum-to-byte (quant) + (floor (/ quant 257))) + +;;; +;;; translated from magick.h +;;; + +(defcfun + ("DestroyMagick" destroy-magick) + :void) + +(defcfun + ("InitializeMagick" initialize-magick) + :void + (args :pointer)) ;; char* + +;;; +;;; translated from resize.h +;;; + +(defcfun + ("ResizeImage" resize-image) + :pointer ;; Image* + (orig :pointer) ;; Image* + (width :unsigned-long) + (height :unsigned-long) + (filter :int) ;; filter-type + (blur :double) + (exception :pointer)) ;; ExceptionInfo* + +;;; +;;; helper macros +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-image-path ((path info ex) &body body) + `(let ((,info (clone-image-info (cffi:null-pointer))) + (,ex (acquire-exception-info))) + (if (cffi:null-pointer-p ,info) + (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) + (unwind-protect + (cffi:with-foreign-string (str ,path) + (gfi::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) + str + (1- +magick-max-text-extent+)) + , at body)) + (destroy-image-info ,info) + (destroy-exception-info ,ex)))) Added: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,549 @@ +;;;; +;;;; magick-core-types.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) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +;;; +;;; see magick-type.h for the original C-language definitions +;;; of these types from ImageMagick Core. +;;; + +(defconstant +magick-max-text-extent+ 4096) +(defconstant +magick-signature+ #xABACADAB) + +(defconstant +undefined-channel+ #x00000000) +(defconstant +red-channel+ #x00000001) +(defconstant +gray-channel+ #x00000001) +(defconstant +cyan-channel+ #x00000001) +(defconstant +green-channel+ #x00000002) +(defconstant +magenta-channel+ #x00000002) +(defconstant +blue-channel+ #x00000004) +(defconstant +yellow-channel+ #x00000004) +(defconstant +alpha-channel+ #x00000008) +(defconstant +opacity-channel+ #x00000008) +(defconstant +matte-channel+ #x00000008) ;; deprecated +(defconstant +black-channel+ #x00000020) +(defconstant +index-channel+ #x00000020) +(defconstant +all-channels+ #x000000FF) +(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ;; (AllChannels &~ OpacityChannel) + +(defctype quantum :unsigned-short) + +(defcenum boolean-type + (:false 0) + (:true 1)) + +(defcenum class-type + :undefined + :direct + :pseudo) + +(defcenum colorspace-type + :undefined + :rgb + :gray + :transparent + :ohta + :lab + :xyz + :ycbcr + :ycc + :yiq + :ypbpr + :yuv + :cmyk + :srgb + :hsb + :hsl + :hwb + :rec601luma + :rec601ycbcr + :rec709luma + :rec709ycbcr + :log) + +(defcenum composite-operator + :undefined + :no + :add + :atop + :blend + :bump-map + :clear + :color-burn + :color-dodge + :colorize + :copy-black + :copy-blue + :copy + :copy-cyan + :copy-green + :copy-magenta + :copy-opacity + :copy-red + :copy-yellow + :darken + :dst-atop + :dst + :dst-in + :dst-out + :dst-over + :difference + :displace + :dissolve + :exclusion + :hard-light + :hue + :in + :lighten + :luminize + :minus + :modulate + :multiply + :out + :over + :overlay + :plus + :replace + :saturate + :screen + :soft-light + :src-atop + :src + :src-in + :src-out + :src-over + :subtract + :threshold + :xor-composite-op) + +(defcenum compression-type + :undefined + :no + :bzip + :fax + :group4 + :jpeg + :jpeg2000 + :lossless-jpeg + :lzw + :rle + :zip) + +(defcenum dispose-type + :unrecognized + (:undefined 0) + (:none 1) + (:background 2) + (:previous 3)) + +(defcenum endian-type + :undefined + :lsb + :msb) + +(defcenum exception-type + :undefined + (:warning 300) + (:resource-limit-warning 300) + (:type-warning 305) + (:option-warning 310) + (:delegate--warning 315) + (:missing-delegate-warning 320) + (:corrupt-image-warning 325) + (:file-open-warning 330) + (:blob-warning 335) + (:stream-warning 340) + (:cache-warning 345) + (:coder-warning 350) + (:module-warning 355) + (:draw-warning 360) + (:image-warning 365) + (:wand-warning 370) + (:xserver-warning 380) + (:monitor-warning 385) + (:registry-warning 390) + (:configure-warning 395) + (:error 400) + (:resource-limit-error 400) + (:type-error 405) + (:option-error 410) + (:delegate-error 415) + (:missing-delegate-error 420) + (:corrupt-image-error 425) + (:file-open-error 430) + (:blob-error 435) + (:stream-error 440) + (:cache-error 445) + (:coder-error 450) + (:module-error 455) + (:draw-error 460) + (:image-error 465) + (:wand-error 470) + (:xserver-error 480) + (:monitor-error 485) + (:registry-error 490) + (:configure-error 495) + (:fatal-error 700) + (:resource-limit-fatal-error 700) + (:type-fatal-error 705) + (:option-fatal-error 710) + (:delegate-fatal-error 715) + (:missing-delegate-fatal-error 720) + (:corrupt-image-fatal-error 725) + (:file-open-fatal-error 730) + (:blob-fatal-error 735) + (:stream-fatal-error 740) + (:cache-fatal-error 745) + (:coder-fatal-error 750) + (:module-fatal-error 755) + (:draw-fatal-error 760) + (:image-fatal-error 765) + (:wand-fatal-error 770) + (:xserver-fatal-error 780) + (:monitor-fatal-error 785) + (:registry-fatal-error 790) + (:configure-fatal-error 795)) + +(defcenum filter-types + :undefined + :point + :box + :triangle + :hermite + :hanning + :hamming + :blackman + :gaussian + :quadratic + :cubic + :catrom + :mitchell + :lanczos + :bessel + :sinc) + +(defcenum gravity-type + :undefined + (:forget 0) + (:north-west 1) + (:north 2) + (:north-east 3) + (:west 4) + (:center 5) + (:east 6) + (:south-west 7) + (:south 8) + (:south-east 9) + (:static 10)) + +(defcenum image-type + :undefined + :bi-level + :gray-scale + :gray-scale-matte + :palette + :palette-matte + :true-color + :true-color-matte + :color-separation + :color-separation-matte + :optimize) + +(defcenum interlace-type + :undefined + :no + :line + :plane + :partition) + +(defcenum orientation-type + :undefined + :top-left + :top-right + :bottom-right + :bottom-left + :left-top + :right-top + :right-bottom + :left-bottom) + +(defcenum preview-type + :undefined + :rotate + :shear + :roll + :hue + :saturation + :brightness + :gamma + :spiff + :dull + :gray-scale + :quantize + :despeckle + :reduce-noise + :add-noise + :sharpen + :blur + :threshold + :edge-detect + :spread + :solarize + :shade + :raise + :segment + :swirl + :implode + :wave + :oil-paint + :charcoal-drawing + :jpeg) + +(defcenum rendering-intent + :undefined + :saturation + :perceptual + :absolute + :relative) + +(defcenum resolution-type + :undefined + :pixels-per-inch + :pixels-per-centimeter) + + ;; from constitute.h + ;; +(defcenum storage-type + :undefined + :char + :double + :float + :integer + :long + :quantum + :short) + +(defcenum timer-state + :undefined + :stopped + :running) + +(defcstruct error-info + (mean-error-per-pixel :double) + (normalized-mean-error :double) + (normalized-maximum-error :double)) + +(defcstruct exception-info + (severity exception-type) + (error-number :int) + (reason :string) + (description :string) + (exceptions :pointer) ;; void* + (relinquish boolean-type) + (semaphore :pointer) ;; Semaphore* + (signature :unsigned-long)) + +(defcstruct primary-info + (x :double) + (y :double) + (z :double)) + +(defcstruct chromaticity-info + (red-primary primary-info) + (green-primary primary-info) + (blue-primary primary-info) + (white-point primary-info)) + +(defcstruct pixel-packet + (blue quantum) + (green quantum) + (red quantum) + (opacity quantum)) + +(defcstruct profile-info + (name :string) + (length :unsigned-long) + (info :pointer) ;; char* + (signature :unsigned-long)) + +(defcstruct rectangle-info + (width :unsigned-long) + (height :unsigned-long) + (x :long) + (y :long)) + +(defcstruct timer + (start :double) + (stop :double) + (total :double)) + +(defcstruct timer-info + (user timer) + (elapsed timer) + (state timer-state) + (signature :unsigned-long)) + +(defcstruct magick-image + (storage-class class-type) + (color-space colorspace-type) + (compression compression-type) + (quality :long) + (orientation orientation-type) + (taint boolean-type) + (matte boolean-type) + (columns :unsigned-long) + (rows :unsigned-long) + (depth :unsigned-long) + (colors :unsigned-long) + (colormap :pointer) ;; PixelPacket* + (background-color pixel-packet) + (border-color pixel-packet) + (matte-color pixel-packet) + (gamma :double) + (chromaticity chromaticity-info) + (render-intent rendering-intent) + (profiles :pointer) ;; void* + (units resolution-type) + (montage :pointer) ;; char* + (directory :pointer) ;; char* + (geometry :pointer) ;; char* + (offset :long) + (x-resolution :double) + (y-resolution :double) + (page rectangle-info) + (extract-info rectangle-info) + (tile-info rectangle-info) ;; deprecated + (bias :double) + (blur :double) + (fuzz :double) + (filter filter-types) + (interlace interlace-type) + (endian endian-type) + (gravity gravity-type) + (compose composite-operator) + (dispose dispose-type) + (clip-mask :pointer) ;; Image* + (scene :unsigned-long) + (delay :unsigned-long) + (ticks-per-second :unsigned-long) + (iterations :unsigned-long) + (total-colors :unsigned-long) + (start-loop :long) + (error error-info) + (timer timer-info) + (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args) + (client-data :pointer) ;; void* + (cache :pointer) ;; void* + (attributes :pointer) ;; void* + (ascii85 :pointer) ;; _Ascii85Info_* + (blob :pointer) ;; _BlobInfo_* + (filename :char :count 4096) + (magick-filename :char :count 4096) + (magick :char :count 4096) + (exception exception-info) + (debug boolean-type) + (reference-count :long) + (semaphore :pointer) ;; SemaphoreInfo* + (color-profile profile-info) + (iptc-profile profile-info) + (generic-profile :pointer) ;; ProfileInfo* + (generic-profiles :unsigned-long) ;; deprecated (and ProfileInfo too?) + (signature :unsigned-long) + (previous :pointer) ;; Image* + (list :pointer) ;; Image* + (next :pointer)) ;; Image* + +(defcstruct magick-image-info + (compression compression-type) + (orientation orientation-type) + (temporary boolean-type) + (adjoin boolean-type) + (affirm boolean-type) + (antialias boolean-type) + (size :pointer) ;; char* + (extract :pointer) ;; char* + (page :pointer) ;; char* + (scenes :pointer) ;; char* + (scene :unsigned-long) + (number-scenes :unsigned-long) + (depth :unsigned-long) + (interlace interlace-type) + (endian endian-type) + (units resolution-type) + (quality :unsigned-long) + (sampling-factor :pointer) ;; char* + (server-name :pointer) ;; char* + (font :pointer) ;; char* + (texture :pointer) ;; char* + (density :pointer) ;; char* + (point-size :double) + (fuzz :double) + (background-color pixel-packet) + (border-color pixel-packet) + (matte-color pixel-packet) + (dither boolean-type) + (monochrome boolean-type) + (colors :unsigned-long) + (colorspace colorspace-type) + (type image-type) + (prevu-type preview-type) + (group :long) + (ping boolean-type) + (verbose boolean-type) + (view :pointer) ;; char* + (authenticate :pointer) ;; char* + (channel :unsigned-int) ;; ChannelType + (attributes :pointer) ;; Image* + (options :pointer) ;; void* + (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args) + (client-data :pointer) ;; void* + (cache :pointer) ;; void* + (stream :pointer) ;; size_t (*StreamHandler)(args) + (file :pointer) ;; FILE* + (blob :pointer) ;; void* + (length :unsigned-int) + (magick :char :count 4096) + (unique :char :count 4096) + (zero :char :count 4096) + (filename :char :count 4906) + (debug boolean-type) + (tile :pointer) ;; deprecated + (subimage :unsigned-long) + (subrange :unsigned-long) + (pen pixel-packet) + (signature :unsigned-long)) + \ No newline at end of file Modified: trunk/src/uitoolkit/graphics/palette.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/palette.lisp (original) +++ trunk/src/uitoolkit/graphics/palette.lisp Sun Mar 19 12:42:18 2006 @@ -33,11 +33,13 @@ (in-package :graphic-forms.uitoolkit.graphics) +#| (defun pixel-color (pal pixel-val) "Returns the color struct corresponding to the given pixel value; the inverse of the pixel function." (if (direct-p pal) (error 'toolkit-error :detail "not yet implemented") (aref (palette-table pal) pixel-val))) +|# (defun dump-colors (pal) (let* ((tmp (palette-table pal)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 12:42:18 2006 @@ -73,6 +73,16 @@ (usage UINT)) (defcfun + ("CreateDIBSection" create-dib-section) + HANDLE + (hdc HANDLE) + (bmi LPTR) + (usage UINT) + (values LPTR) ;; VOID ** + (section HANDLE) + (offset DWORD)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Mar 19 12:42:18 2006 @@ -35,11 +35,13 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) + (gfg::initialize-magick (cffi:null-pointer)) (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn) (run-default-message-loop)) #+lispworks (defun startup (thread-name start-fn) + (gfg::initialize-magick (cffi:null-pointer)) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) (mp:process-run-function thread-name @@ -49,6 +51,7 @@ (run-default-message-loop))))) (defun shutdown (exit-code) + (gfg::destroy-magick) (gfs::post-quit-message exit-code)) (defun clear-all (w) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Mar 19 12:42:18 2006 @@ -44,4 +44,5 @@ (defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*)) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (chdir *gf-tests-dir*)) From junrue at common-lisp.net Sun Mar 19 21:35:28 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 19 Mar 2006 16:35:28 -0500 (EST) Subject: [graphic-forms-cvs] r51 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system Message-ID: <20060319213528.C10B85903A@common-lisp.net> Author: junrue Date: Sun Mar 19 16:35:26 2006 New Revision: 51 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: initial transparency work Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 16:35:26 2006 @@ -195,8 +195,10 @@ #:transform #:transform-coordinates #:translate - #:transparency-color + #:transparency + #:transparency-of #:transparency-mask + #:with-transparency #:xor-mode-p ;; conditions Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 16:35:26 2006 @@ -40,29 +40,54 @@ (defclass image-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d image-events) window time) - (declare (ignore window time)) +(defun dispose-images () (gfi:dispose *happy-image*) (setf *happy-image* nil) (gfi:dispose *bw-image*) (setf *bw-image* nil) (gfi:dispose *true-image*) - (setf *true-image* nil) + (setf *true-image* nil)) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) - (let ((pnt (gfi:make-point))) + (let ((pnt (gfi:make-point)) + (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) + (gfg:with-transparency (*happy-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *happy-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:draw-image gc *true-image* pnt))) + (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *bw-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 20) + (gfg:draw-image gc *true-image* pnt) + (incf (gfi:point-x pnt) 20) + (gfg:with-transparency (*true-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) + (incf (gfi:point-x pnt) 20) + (gfg:draw-image gc *true-image* pnt)))) (defun exit-image-fn (disp item time rect) (declare (ignorable disp item time rect)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) @@ -77,6 +102,7 @@ (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) + (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Sun Mar 19 16:35:26 2006 @@ -33,13 +33,13 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) -(defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) -(defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) -(defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) -(defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) + (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) + (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) + (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) + (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) + (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 19 16:35:26 2006 @@ -87,10 +87,10 @@ (defclass image (gfi:native-object) ((transparency - :accessor transparency-color - :initarg :transparency-color - :initform (make-color))) - (:documentation "This class represents an image of a particular type (BMP, PNG, etc.).")) + :accessor transparency-of + :initarg :transparency + :initform nil)) + (:documentation "This class wraps a native image object.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 19 16:35:26 2006 @@ -82,30 +82,42 @@ 0 (cffi:null-pointer)))))) +;;; +;;; TODO: support addressing elements within bitmap as if it were an array +;;; (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - ;; TODO: support addressing elements within bitmap as if it were an array - ;; - (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - (oldhbm (cffi:null-pointer))) - (if (gfi:null-handle-p memdc) - (error 'gfs:win32-error :detail "create-compatible-dc failed")) - (setf oldhbm (gfs::select-object memdc (gfi:handle im))) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (gfs::bit-blt (gfi:handle gc) - (gfi:point-x pnt) - (gfi:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) - memdc - 0 0 - gfs::+blt-srccopy+)) - (gfs::select-object memdc oldhbm) - (gfs::delete-dc memdc))) + (let* ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc gc-dc)) + (tr-color (transparency-of im)) + (op gfs::+blt-srccopy+)) + (unwind-protect + (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) + (when (not (null tr-color)) + (setf op gfs::+blt-srcpaint+) + (gfs::select-object memdc (gfi:handle (transparency-mask im))) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+)) + (gfs::select-object memdc himage) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 op))) + (gfs::delete-dc memdc)))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 19 16:35:26 2006 @@ -175,7 +175,7 @@ (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) (defgeneric transparency-mask (object) - (:documentation "Returns an image-data object specifying the transparency mask for the image.")) + (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) (defgeneric xor-mode-p (object) (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sun Mar 19 16:35:26 2006 @@ -145,12 +145,8 @@ (let* ((handle (gfi:handle data)) (sz (size data)) (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) - (bit-count (depth data)) (hbmp (cffi:null-pointer)) (screen-dc (gfs::get-dc (cffi:null-pointer)))) -(format t "bi-size: ~a~%" (cffi:foreign-type-size 'gfs::bitmapinfoheader)) -(format t "bit-count: ~a~%" bit-count) -(format t "size: ~a ~a~%" (gfi:size-width sz) (gfi:size-height sz)) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) (setf gfs::biwidth (gfi:size-width sz)) (setf gfs::biheight (- 0 (gfi:size-height sz))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 16:35:26 2006 @@ -34,9 +34,18 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper functions +;;; helper macros ;;; +(defmacro with-transparency ((image color) &body body) + (let ((orig-color (gensym))) + `(let ((,orig-color (transparency-of ,image))) + (unwind-protect + (progn + (setf (transparency-of ,image) ,color) + , at body) + (setf (transparency-of ,image) ,orig-color))))) + ;;; ;;; methods ;;; @@ -45,7 +54,6 @@ (let ((hgdi (gfi:handle im))) (unless (gfi:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (transparency-color im) nil) (setf (slot-value im 'gfi:handle) nil)) (defmethod data-obj ((im image)) @@ -63,3 +71,30 @@ (load data path) (setf (data-obj im) data) data)) + +(defmethod transparency-mask ((im image)) + (if (gfi:disposed-p im) + (error 'gfi:disposed-error)) + (let ((hbmp (gfi:handle im)) + (tr-color (transparency-of im)) + (hmask (cffi:null-pointer))) + (if (null tr-color) + (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (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 (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (unwind-protect + (progn + (gfs::select-object memdc1 hbmp) + (gfs::select-object memdc2 hmask) + (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) + (gfs::delete-dc memdc1) + (gfs::delete-dc memdc2))))) + (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 16:35:26 2006 @@ -41,8 +41,9 @@ ;;; of these types from ImageMagick Core. ;;; -(defconstant +magick-max-text-extent+ 4096) -(defconstant +magick-signature+ #xABACADAB) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +magick-max-text-extent+ 4096) + (defconstant +magick-signature+ #xABACADAB)) (defconstant +undefined-channel+ #x00000000) (defconstant +red-channel+ #x00000001) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 16:35:26 2006 @@ -53,11 +53,27 @@ (rop DWORD)) (defcfun + ("CreateBitmap" create-bitmap) + HANDLE + (width INT) + (height INT) + (planes UINT) + (bpp UINT) + (pixels LPTR)) + +(defcfun ("CreateBitmapIndirect" create-bitmap-indirect) HANDLE (lpbm LPTR)) (defcfun + ("CreateCompatibleBitmap" create-compatible-bitmap) + HANDLE + (hdc HANDLE) + (width INT) + (height INT)) + +(defcfun ("CreateCompatibleDC" create-compatible-dc) HANDLE (hdc HANDLE)) From junrue at common-lisp.net Mon Mar 20 05:18:26 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:18:26 -0500 (EST) Subject: [graphic-forms-cvs] r52 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets Message-ID: <20060320051826.22EFE4814D@common-lisp.net> Author: junrue Date: Mon Mar 20 00:18:25 2006 New Revision: 52 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/happy.bmp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/truecolor16x16.bmp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: basic transparency working, need to allow caller to select the pixel that defines transparent color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:18:25 2006 @@ -94,8 +94,9 @@ ;; methods, functions, macros #:detail + #:with-compatible-dcs #:with-hfont-selected - #:with-retrieved-hdc + #:with-retrieved-dc ;; conditions #:toolkit-error Modified: trunk/src/tests/uitoolkit/happy.bmp ============================================================================== Binary files. 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 Mon Mar 20 00:18:25 2006 @@ -58,11 +58,11 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (color (gfg:make-color :red 0 :green 255 :blue 255))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* tr-color) + (gfg:with-transparency (*happy-image* color) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -80,7 +80,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* tr-color) + (gfg:with-transparency (*true-image* color) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) Modified: trunk/src/tests/uitoolkit/truecolor16x16.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:18:25 2006 @@ -90,25 +90,42 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((gc-dc (gfi:handle gc)) + (let* ((color (transparency-of im)) + (gc-dc (gfi:handle gc)) (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc gc-dc)) - (tr-color (transparency-of im)) - (op gfs::+blt-srccopy+)) - (unwind-protect - (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) - (when (not (null tr-color)) - (setf op gfs::+blt-srcpaint+) - (gfs::select-object memdc (gfi:handle (transparency-mask im))) - (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (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) + (if (not (null color)) + (let ((hmask (gfi:handle (transparency-mask im))) + (hcopy (clone-bitmap himage)) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (gfs::select-object memdc hmask) + (gfs::select-object memdc2 hcopy) + (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) + (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::bit-blt memdc2 + 0 0 + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc2 + 0 0 gfs::+blt-srcpaint+)) + (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc (gfi:point-x pnt) @@ -116,8 +133,8 @@ gfs::width gfs::height memdc - 0 0 op))) - (gfs::delete-dc memdc)))) + 0 0 gfs::+blt-srccopy+))))) + (gfs::delete-dc memdc))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Mar 20 00:18:25 2006 @@ -46,8 +46,6 @@ (data nil) (sz nil) (byte-count 0)) - (when (gfi:null-handle-p mem-dc) - (error 'gfs:win32-error :detail "create-compatible-dc failed")) (unwind-protect (progn (cffi:with-foreign-object (bc-ptr 'gfs::bitmapcoreheader) @@ -218,8 +216,9 @@ (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-string-to-lisp (cffi:foreign-slot-value ex 'exception-info 'reason))))) + (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 data 'gfi:handle) handle)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:18:25 2006 @@ -34,7 +34,7 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper macros +;;; helper macros and functions ;;; (defmacro with-transparency ((image color) &body body) @@ -46,6 +46,21 @@ , at body) (setf (transparency-of ,image) ,orig-color))))) +(defun clone-bitmap (horig) + (let ((hclone (cffi:null-pointer)) + (nptr (cffi:null-pointer))) + (gfs:with-compatible-dcs (nptr memdc-src memdc-dest) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (setf hclone (gfs::create-compatible-bitmap (gfs::get-dc (cffi:null-pointer)) + gfs::width + gfs::height)) + (gfs::select-object memdc-dest hclone) + (gfs::select-object memdc-src horig) + (gfs::bit-blt memdc-dest 0 0 gfs::width gfs::height memdc-src 0 0 gfs::+blt-srccopy+)))) + hclone)) + ;;; ;;; methods ;;; @@ -76,25 +91,19 @@ (if (gfi:disposed-p im) (error 'gfi:disposed-error)) (let ((hbmp (gfi:handle im)) - (tr-color (transparency-of im)) - (hmask (cffi:null-pointer))) - (if (null tr-color) - (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (hmask (cffi:null-pointer)) + (nptr (cffi:null-pointer)) + (old-bg 0)) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfi:handle im) (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 (gfi:null-handle-p hmask) (error 'gfs:win32-error :detail "create-bitmap failed")) - (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) - (unwind-protect - (progn - (gfs::select-object memdc1 hbmp) - (gfs::select-object memdc2 hmask) - (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) - (gfs::delete-dc memdc1) - (gfs::delete-dc memdc2))))) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 20 00:18:25 2006 @@ -164,6 +164,13 @@ (buffer LPTR)) (defcfun + ("GetPixel" get-pixel) + COLORREF + (hdc HANDLE) + (x INT) + (y INT)) + +(defcfun ("GetStockObject" get-stock-object) HANDLE (type INT)) @@ -180,6 +187,22 @@ (lpm LPTR)) (defcfun + ("MaskBlt" mask-blt) + BOOL + (hdest HANDLE) + (xdest INT) + (ydest INT) + (width INT) + (height INT) + (hsrc HANDLE) + (xsrc INT) + (ysrc INT) + (hmask HANDLE) + (xmask INT) + (ymask INT) + (rop DWORD)) + +(defcfun ("SelectObject" select-object) HANDLE (hdc HANDLE) @@ -219,3 +242,6 @@ COLORREF (hdc HANDLE) (color COLORREF)) + +(defun makerop4 (fore back) + (logior (logand (ash back 8) #xFF000000) fore)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Mar 20 00:18:25 2006 @@ -47,7 +47,7 @@ (unless (gfi:null-handle-p ,hfont-old) (gfs::select-object ,hdc ,hfont-old)))))) -(defmacro with-retrieved-hdc ((hwnd hdc-var) &body body) +(defmacro with-retrieved-dc ((hwnd hdc-var) &body body) `(let ((,hdc-var nil)) (unwind-protect (progn @@ -56,3 +56,12 @@ (error 'gfs:win32-error :detail "get-dc failed")) , at body) (gfs::release-dc ,hwnd ,hdc-var)))) + +(defmacro with-compatible-dcs ((orig-dc &rest hdc-vars) &body body) + `(let ,(loop for var in hdc-vars + collect `(,var (gfs::create-compatible-dc ,orig-dc))) + (unwind-protect + (progn + , at body) + ,@(loop for var2 in hdc-vars + collect `(gfs::delete-dc ,var2))))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Mar 20 00:18:25 2006 @@ -136,7 +136,7 @@ (sz (gfi:make-size)) (hfont nil)) (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) - (gfs:with-retrieved-hdc (hwnd hdc) + (gfs:with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs:with-hfont-selected (hdc hfont) (when (> len 0) From junrue at common-lisp.net Mon Mar 20 05:34:03 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:34:03 -0500 (EST) Subject: [graphic-forms-cvs] r53 - in trunk/src: . tests/uitoolkit uitoolkit/graphics Message-ID: <20060320053403.E9D7449034@common-lisp.net> Author: junrue Date: Mon Mar 20 00:34:03 2006 New Revision: 53 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.lisp Log: image transparency is now specified as a point in the image rather than a color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:34:03 2006 @@ -197,7 +197,7 @@ #:transform-coordinates #:translate #:transparency - #:transparency-of + #:transparency-pixel-of #:transparency-mask #:with-transparency #:xor-mode-p Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 00:34:03 2006 @@ -58,11 +58,12 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (color (gfg:make-color :red 0 :green 255 :blue 255))) + (pixel-pnt1 (gfi:make-point)) + (pixel-pnt2 (gfi:make-point :x 0 :y 15))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* color) + (gfg:with-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -71,7 +72,7 @@ (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:with-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) (incf (gfi:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) @@ -80,7 +81,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* color) + (gfg:with-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) @@ -103,6 +104,7 @@ (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) + (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Mar 20 00:34:03 2006 @@ -86,9 +86,9 @@ (:documentation "This class represents the context associated with drawing primitives.")) (defclass image (gfi:native-object) - ((transparency - :accessor transparency-of - :initarg :transparency + ((transparency-pixel + :accessor transparency-pixel-of + :initarg :transparency-pixel :initform nil)) (:documentation "This class wraps a native image object.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:34:03 2006 @@ -90,14 +90,13 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((color (transparency-of im)) - (gc-dc (gfi:handle gc)) - (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (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) - (if (not (null color)) + (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:34:03 2006 @@ -37,14 +37,14 @@ ;;; helper macros and functions ;;; -(defmacro with-transparency ((image color) &body body) - (let ((orig-color (gensym))) - `(let ((,orig-color (transparency-of ,image))) +(defmacro with-transparency ((image pnt) &body body) + (let ((orig-pnt (gensym))) + `(let ((,orig-pnt (transparency-pixel-of ,image))) (unwind-protect (progn - (setf (transparency-of ,image) ,color) + (setf (transparency-pixel-of ,image) ,pnt) , at body) - (setf (transparency-of ,image) ,orig-color))))) + (setf (transparency-pixel-of ,image) ,orig-pnt))))) (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) @@ -90,20 +90,23 @@ (defmethod transparency-mask ((im image)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let ((hbmp (gfi:handle im)) + (let ((pixel-pnt (transparency-pixel-of im)) + (hbmp (gfi:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer)) (old-bg 0)) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (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 (gfi:null-handle-p hmask) - (error 'gfs:win32-error :detail "create-bitmap failed")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) - (gfs::select-object memdc2 hmask) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::set-bk-color memdc1 old-bg)))) - (make-instance 'image :handle hmask))) + (unless (null pixel-pnt) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (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 (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 + (gfs::get-pixel memdc1 (gfi:point-x pixel-pnt) (gfi:point-y pixel-pnt)))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) + (make-instance 'image :handle hmask)))) From junrue at common-lisp.net Mon Mar 20 05:38:50 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:38:50 -0500 (EST) Subject: [graphic-forms-cvs] r54 - trunk Message-ID: <20060320053850.9B01149034@common-lisp.net> Author: junrue Date: Mon Mar 20 00:38:50 2006 New Revision: 54 Modified: trunk/build.lisp Log: got rid of dependencies on practicals code from PCL Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Mar 20 00:38:50 2006 @@ -48,8 +48,6 @@ (defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) (defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") (defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) -(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) -(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) (defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) (defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") @@ -59,22 +57,16 @@ (defvar *asdf-dirs* (list *cffi-dir* *closer-mop-dir* *lw-compat-dir* - *pcl-ch08-dir* - *pcl-ch24-dir* *gf-dir*)) (defvar *library-build-root* (concatenate 'string *library-root* "build/")) (defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) (defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/")) (defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/")) -(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/")) -(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/")) (defvar *build-dirs* (list *cffi-build-dir* *closer-mop-build-dir* *lw-compat-build-dir* - *pcl-ch08-build-dir* - *pcl-ch24-build-dir* *gf-build-dir*)) #+lispworks (defmacro chdir (path) @@ -101,13 +93,5 @@ (asdf:operate 'asdf:load-op :closer-mop) (if *external-build-dirs* - (chdir *pcl-ch08-build-dir*)) - (asdf:operate 'asdf:load-op :macro-utilities) - - (if *external-build-dirs* - (chdir *pcl-ch24-build-dir*)) - (asdf:operate 'asdf:load-op :binary-data) - - (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) From junrue at common-lisp.net Mon Mar 20 05:51:29 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:51:29 -0500 (EST) Subject: [graphic-forms-cvs] r55 - in trunk/src: . tests/uitoolkit uitoolkit/graphics Message-ID: <20060320055129.3471D4C001@common-lisp.net> Author: junrue Date: Mon Mar 20 00:51:28 2006 New Revision: 55 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: changed color constants to be defvars not defconstants Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:51:28 2006 @@ -124,11 +124,11 @@ #:transform ;; constants - #:+color-black+ - #:+color-blue+ - #:+color-green+ - #:+color-red+ - #:+color-white+ + #:*color-black* + #:*color-blue* + #:*color-green* + #:*color-red* + #:*color-white* ;; methods, functions, macros #:alpha Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 00:51:28 2006 @@ -48,8 +48,8 @@ (defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) (declare (ignorable time rect)) - (setf (gfg:background-color gc) gfg:+color-white+) - (setf (gfg:foreground-color gc) gfg:+color-blue+) + (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 00:51:28 2006 @@ -46,10 +46,10 @@ (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) - (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect) - (setf (gfg:background-color gc) gfg:+color-red+) - (setf (gfg:foreground-color gc) gfg:+color-green+) + (setf (gfg:background-color gc) gfg:*color-red*) + (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfi:make-point))) (defun exit-fn (disp item time rect) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 00:51:28 2006 @@ -49,7 +49,7 @@ (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) - (setf (gfg:background-color gc) gfg:+color-white+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Mon Mar 20 00:51:28 2006 @@ -34,12 +34,6 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) - (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) - (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) - (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) - (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) @@ -48,6 +42,12 @@ (setf (ldb (byte 8 16) ,result) (color-blue ,color)) ,result)))) +(defvar *color-black* (make-color :red 0 :green 0 :blue 0)) +(defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) +(defvar *color-green* (make-color :red 0 :green #xFF :blue 0)) +(defvar *color-red* (make-color :red #xFF :green 0 :blue 0)) +(defvar *color-white* (make-color :red #xFF :green #xFF :blue #xFF)) + (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)))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:51:28 2006 @@ -99,11 +99,13 @@ (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) (gfs::select-object memdc hmask) (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) - (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::set-bk-color memdc2 (color-as-rgb black)) + (gfs::set-text-color memdc2 (color-as-rgb white)) (gfs::bit-blt memdc2 0 0 gfs::width From junrue at common-lisp.net Mon Mar 20 06:03:15 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 01:03:15 -0500 (EST) Subject: [graphic-forms-cvs] r56 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060320060315.9E06D5300E@common-lisp.net> Author: junrue Date: Mon Mar 20 01:03:14 2006 New Revision: 56 Added: trunk/src/uitoolkit/widgets/label.lisp - copied, changed from r46, trunk/src/uitoolkit/widgets/text-label.lisp Removed: trunk/src/uitoolkit/widgets/text-label.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: reverted back to single label class which will distinguish text vs image via style flags Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Mar 20 01:03:14 2006 @@ -101,7 +101,7 @@ (:file "item") (:file "widget") (:file "control") - (:file "text-label") + (:file "label") (:file "button") (:file "widget-with-items") (:file "menu") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 01:03:14 2006 @@ -394,6 +394,7 @@ #:items #:key-down-p #:key-toggled-p + #:label #:layout #:layout-of #:layout-p Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 01:03:14 2006 @@ -342,7 +342,7 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) - (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label + (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher Copied: trunk/src/uitoolkit/widgets/label.lisp (from r46, trunk/src/uitoolkit/widgets/text-label.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Mar 20 01:03:14 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; text-label.lisp +;;;; label.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label text-label) &rest style) +(defmethod compute-style-flags ((label label) &rest style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) @@ -72,7 +72,7 @@ (setf std-flags (logior std-flags gfs::+ss-left+))))) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) @@ -88,7 +88,7 @@ (init-control label)) -(defmethod preferred-size ((label text-label) width-hint height-hint) +(defmethod preferred-size ((label label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) @@ -106,8 +106,8 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod text ((label text-label)) +(defmethod text ((label label)) (get-widget-text label)) -(defmethod (setf text) (str (label text-label)) +(defmethod (setf text) (str (label label)) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Mar 20 01:03:14 2006 @@ -65,11 +65,8 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) -(defclass image-label (control) () - (:documentation "This class represents non-selectable controls that display an image.")) - -(defclass text-label (control) () - (:documentation "This class represents non-selectable controls that display a string.")) +(defclass label (control) () + (:documentation "This class represents non-selectable controls that display a string or image.")) (defclass widget-with-items (widget) ((items From junrue at common-lisp.net Mon Mar 20 06:52:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 01:52:48 -0500 (EST) Subject: [graphic-forms-cvs] r57 - in trunk: docs/website src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060320065248.A0DE15D087@common-lisp.net> Author: junrue Date: Mon Mar 20 01:52:46 2006 New Revision: 57 Modified: trunk/docs/website/index.html trunk/src/packages.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/widgets/menu-language.lisp Log: last round of fixes before screenshot upload; renamed menu language macro to defmenu Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Mar 20 01:52:46 2006 @@ -15,7 +15,7 @@