graphic-forms-cvs

graphic-forms-cvs@common-lisp.net

461 discussions

[graphic-forms-cvs] r36 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 13 Mar '06

13 Mar '06

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)

1 0

[graphic-forms-cvs] r35 - in trunk: . src/intrinsics/datastructs src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 13 Mar '06

13 Mar '06

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))

1 0

[graphic-forms-cvs] r34 - in trunk/src: . tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 09 Mar '06

09 Mar '06

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))

1 0

[graphic-forms-cvs] r33 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 08 Mar '06

08 Mar '06

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 ,@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))) - ,@cmds + ,@(generate-menusystem-code sexp gen) (pop (menu-stack-of ,gen)))))

1 0

[graphic-forms-cvs] r32 - in trunk: . src src/uitoolkit/widgets
by junrue＠common-lisp.net 06 Mar '06

06 Mar '06

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)))

1 0

[graphic-forms-cvs] r31 - trunk
by junrue＠common-lisp.net 06 Mar '06

06 Mar '06

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")

1 0

[graphic-forms-cvs] r30 - trunk/src/third-party
by junrue＠common-lisp.net 06 Mar '06

06 Mar '06

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

1 0

[graphic-forms-cvs] r29 - trunk
by junrue＠common-lisp.net 05 Mar '06

05 Mar '06

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

1 0

[graphic-forms-cvs] r28 - in trunk/src/third-party: . lw-compat
by junrue＠common-lisp.net 05 Mar '06

05 Mar '06

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 (,,@temps) + ,,@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 + ,@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 ,@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) + ,@body))

1 0

[graphic-forms-cvs] r27 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 04 Mar '06

04 Mar '06

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))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs