- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

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

17 Mar '06

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

1 0

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

16 Mar '06

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)

1 0

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

16 Mar '06

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

1 0

[graphic-forms-cvs] r43 - in trunk/docs: manual website
by junrue＠common-lisp.net 15 Mar '06

15 Mar '06

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 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Glossary + +@node Glossary +@chapter Glossary + +Terms and definitions. + +@table @samp +@item control +A control is a thing. + +@item dialog +A dialog is something else. + +@item menu +A collection of menu items. + +@end table + +@cindex control +@cindex dialog +@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 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Overview + +@node Overview +@chapter Overview + +Graphic-Forms is a user interface library implemented in Common Lisp +focusing on the Windows@registeredsymbol{} platform. Graphic-Forms is +licensed under the terms of the BSD License. + +Graphic-Forms has two primary goals: + +@itemize @bullet +@item +in the short term, provide a toolkit encapsulating the underlying +window system primitives, custom controls and dialogs, and +platform-specific features + +@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. +@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@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@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: @* +@indicateurl{http://common-lisp.net/project/graphic-forms} + + +@section Dependencies + +The libraries that Graphic-Forms relies upon. + + +@section Mailing Lists and Bug Reports + +Announcements mailing list: @* +@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce} + +Developer mailing list (for both users and maintainers): @* +@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel} + +Source control log mailing list: @* +@indicateurl{http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs} + +The bug tracking system: @* +@indicateurl{http://sourceforge.net/tracker/?group_id=20959&atid=120959} + + +@section Submitting Patches + +Please use the SourceForge patch tracking mechanism to contribute patches: + + +@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 @@ + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@c =================================================================== +@c CHAPTER: Packages + +@node Packages +@chapter Packages + +General comments about the packages. + +@section Intrinsics +@cindex Intrinsics Package + +@section Graphics +@cindex Graphics Package + +@section System +@cindex System Package + +@section Tests +@cindex Tests Package + +@section Widgets +@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 -*- +@c %**start of header + +@c This file is part of the documentation source for +@c the Graphic-Forms library. +@c +@c Copyright (c) 2006, Jack D. Unrue + +@setfilename reference.info +@settitle Graphic-Forms Programming Reference +@exampleindent 2 + +@c ============================= Macros ============================= + +@macro Function {args} +@defun \args\ +@end defun +@end macro + +@macro Macro {args} +@defmac \args\ +@end defmac +@end macro + +@macro Accessor {args} +@deffn {Accessor} \args\ +@end deffn +@end macro + +@macro GenericFunction {args} +@deffn {Generic Function} \args\ +@end deffn +@end macro + +@macro Variable {args} +@defvr {Special Variable} \args\ +@end defvr +@end macro + +@macro Condition {args} +@deftp {Condition Type} \args\ +@end deftp +@end macro + +@macro GFI +@acronym{GFW} +@end macro + +@macro GFG +@acronym{GFW} +@end macro + +@macro GFS +@acronym{GFW} +@end macro + +@macro GFW +@acronym{GFW} +@end macro + +@macro impnote {text} +@quotation +@strong{Implementor's note:} @emph{\text\} +@end quotation +@end macro + +@c Info "requires" that x-refs end in a period or comma, or ) in the +@c case of @pxref. So the following implements that requirement for +@c the "See also" subheadings that permeate this manual, but only in +@c Info mode. +@ifinfo +@macro seealso {name} +@ref{\name\}. +@end macro +@end ifinfo + +@ifnotinfo +@alias seealso = ref +@end ifnotinfo + +@c ==========================End Macros ============================= + +@c Coallesce all the index types into one master index. +@syncodeindex fn cp +@syncodeindex ky cp +@syncodeindex tp cp +@syncodeindex vr cp + +@copying +Copyright @copyright{} 2006, Jack D. Unrue <jdunrue at gmail.com> @* + +@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. + +@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.} +@end quotation +@end copying +@c %**end of header + +@titlepage +@title Graphic-Forms Programming Reference +@c @subtitle Version 0.2.0 +@c @author Jack D. Unrue + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@ifnottex +@node Top +@top Graphic-Forms Programming Reference +@insertcopying +@end ifnottex + +@majorheading Major Topics List + +@menu +* Overview:: Notes on using Graphic-Forms and how to get help. +* Glossary:: Terms and definitions. +* Packages:: Summary of the library packages. +* Master Index:: +@end menu + +@contents + +@include overview.texinfo +@include glossary.texinfo +@include packages.texinfo + +@c =================================================================== +@c Index + +@node Master Index +@unnumbered Master Index +@printindex cp + +@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 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms Documentation</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> + +<body> + + <h3><a href="reference/index.html">Programming Reference</a></h3> + + <h3>FAQ</h3> + + <h3>Articles</h3> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + +</body> +</html> Added: trunk/docs/website/download.html ============================================================================== --- (empty file) +++ trunk/docs/website/download.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,38 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms Source Control</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> + +<body> + + <p>Graphic-Forms is distributed in source code form. Please choose from + one of the following options: + + <ul> + <li> + <a href="http://sourceforge.net/project/showfiles.php?group_id=1355">Download</a> + a release tarball. + </li> + <li> + <a href="http://common-lisp.net/faq.shtml">Download</a> + the current development tree via anonymous Subversion. + Note: <i><project-name></i> is <i>graphic-forms</i>. + </li> + <li> + <a href="http://common-lisp.net/websvn/listing.php?repname=graphic-forms&path=%2F&sc…">Browse</a> + the Subversion repository. + </li> + </ul> + </p> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + +</body> +</html> 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 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> -<head> -<title>Graphic-Forms project</title> - <link rel="stylesheet" type="text/css" href="style.css"> - <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> - </head> +<head> + <title>Graphic-Forms project</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> - <body> +<body> <div class="header"> <h1>Graphic-Forms</h1> <h2>A user interface toolkit for the Windows® platform.</h2> </div> + <div class="NavBar"> + <a class="barfirst" href="http://awayrepl.blogspot.com/">News</a> + <a class="barcenter" href="screenshots.html">Screenshots</a> + <a class="barcenter" href="download.html">Download</a> + <a class="barcenter" href="docs.html">Documentation</a> + <a class="barlast" href="http://sourceforge.net/tracker/?group_id=1355&atid=101355">Bug Database</a> +</div> + + <h3>Introduction</h3> <p>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 <a href="http://www.wxcl-project.org">wxCL</a>. <i>This - project</i> is aimed specifically at Windows® developers. + project</i> is aimed specifically at Windows® developers.</p> - <h3>Current Status</h3> + <h3>Status</h3> - <p>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.</p> + <p>The first release will be version 0.2.0 and should be + available shortly.</p> - <p>NOTE: This library is in the early implementation stage. Brave souls who + <p>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.<p> + behavior changes in the preliminary releases leading up to the 1.0 release.</p> - <h3>Mailing Lists</h3> + <h3 id="mailinglists">Mailing Lists</h3> <ul> <li> <a href="http://www.common-lisp.net/mailman/listinfo/graphic-forms-devel"> graphic-forms-devel</a><br>for both developers and users</li> <li> <a href="http://www.common-lisp.net/mailman/listinfo/graphic-forms-cvs"> - graphic-forms-cvs</a><br>CVS log feed</li> + graphic-forms-cvs</a><br>Subversion log feed</li> <li> <a href="http://www.common-lisp.net/mailman/listinfo/graphic-forms-announce"> graphic-forms-announce</a><br>for announcements</li> - </ul> - <h3>Download</h3> - - <p>This project has not released any files.</p> - - <h3>Revision Control</h3> - - <p>You can <a href="http://common-lisp.net/websvn/listing.php?repname=graphic-forms&path=%2F&sc…"> -browse the Subversion repository</a> or download the current development tree via - anonymous svn, as described <a href="http://common-lisp.net/faq.shtml">here</a>.</p> - - <div class="footer"> - Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> - </div> + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + + </body> </html> Added: trunk/docs/website/screenshots.html ============================================================================== --- (empty file) +++ trunk/docs/website/screenshots.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,20 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + +<head> + <title>Graphic-Forms Screenshots</title> + <link rel="stylesheet" type="text/css" href="style.css"> + <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"> +</head> + +<body> + + <p>Screenshots coming soon...stay tuned!</p> + + <div class="footer"> + <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> + Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + </div> + +</body> +</html> 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; +}

1 0

[graphic-forms-cvs] r42 - trunk/docs/website
by junrue＠common-lisp.net 15 Mar '06

15 Mar '06

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; }

1 0

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

15 Mar '06

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

1 0

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

14 Mar '06

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

1 0

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

14 Mar '06

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

1 0

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

14 Mar '06

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

1 0

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

13 Mar '06

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 -*- +@c %**start of header +@setfilename graphic-forms-reference.info +@settitle Graphic-Forms Programming Reference +@exampleindent 2 + +@c @documentencoding utf-8 + +@c ============================= Macros ============================= + +@macro Function {args} +@defun \args\ +@end defun +@end macro + +@macro Macro {args} +@defmac \args\ +@end defmac +@end macro + +@macro Accessor {args} +@deffn {Accessor} \args\ +@end deffn +@end macro + +@macro GenericFunction {args} +@deffn {Generic Function} \args\ +@end deffn +@end macro + +@macro Variable {args} +@defvr {Special Variable} \args\ +@end defvr +@end macro + +@macro Condition {args} +@deftp {Condition Type} \args\ +@end deftp +@end macro + +@macro GFI +@acronym{GFW} +@end macro + +@macro GFG +@acronym{GFW} +@end macro + +@macro GFS +@acronym{GFW} +@end macro + +@macro GFW +@acronym{GFW} +@end macro + +@macro impnote {text} +@quotation +@strong{Implementor's note:} @emph{\text\} +@end quotation +@end macro + +@c Info "requires" that x-refs end in a period or comma, or ) in the +@c case of @pxref. So the following implements that requirement for +@c the "See also" subheadings that permeate this manual, but only in +@c Info mode. +@ifinfo +@macro seealso {name} +@ref{\name\}. +@end macro +@end ifinfo + +@ifnotinfo +@alias seealso = ref +@end ifnotinfo + +@c ==========================End Macros ============================= + +@c Show types, functions, and concepts in the same index. +@syncodeindex tp cp +@syncodeindex fn cp + +@copying +Copyright @copyright{} 2006, Jack D. Unrue <jdunrue at gmail.com> @* + +@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. + +@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.} +@end quotation +@end copying +@c %**end of header + +@titlepage +@title Graphic-Forms Programming Reference +@c @subtitle Version 0.2.0 +@c @author Jack D. Unrue + +@page +@vskip 0pt plus 1filll +@insertcopying +@end titlepage + +@contents + +@ifnottex +@node Top +@top Graphic-Forms Programming Reference +@insertcopying +@end ifnottex + +@menu +* Introduction:: +* Known Issues:: +@end menu + +@c =================================================================== +@c CHAPTER: Introduction + +@node Introduction +@chapter Introduction + +This will be introductory discussion of the Graphic-Forms library. + +@c =================================================================== +@c CHAPTER: Known Issues + +@node Known Issues +@chapter Known Issues + +This will be a list of known issues in the library. + +@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)

1 0