May 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r121 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 07 May '06

07 May '06

Author: junrue Date: Sun May 7 18:39:06 2006 New Revision: 121 Modified: trunk/src/uitoolkit/widgets/timer.lisp Log: make gfs:dispose a synonym for gfw:enable nil for timers Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sun May 7 18:39:06 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) +;;; +;;; helper functions +;;; + (defun clamp-delay-values (init-delay delay) "Adjust delay settings based on system-defined limits." ;; @@ -67,9 +71,16 @@ (error 'gfs:win32-error :detail "set-timer failed"))) clamped)) +;;; +;;; methods +;;; + (defmethod (setf delay-of) :around (value (self timer)) (setf (slot-value self 'delay) (reset-timer-to-delay self value))) +(defmethod gfs:dispose ((self timer)) + (enable self nil)) + (defmethod initialize-instance :after ((self timer) &key) (if (null (delay-of self)) (error 'gfs:toolkit-error :detail ":delay value required"))

1 0

[graphic-forms-cvs] r120 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 07 May '06

07 May '06

Author: junrue Date: Sun May 7 17:21:43 2006 New Revision: 120 Modified: trunk/README.txt trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/timer.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: rewrote timer such that TimerProc is no longer used; rename running-p method to enabled-p Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun May 7 17:21:43 2006 @@ -1,5 +1,5 @@ -Graphic-Forms README for version 0.3.0 +Graphic-Forms README for version 0.4.0 Copyright (c) 2006, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing @@ -47,32 +47,25 @@ features in general that are not yet implemented, this section lists known problems in this release: -1. The following bug filed against CLISP 2.38 - - http://sourceforge.net/tracker/index.php?func=detail&aid=1463994&group_id=1… - - may result in intermittent GPFs when windows with layout managers are - resized or when timer objects are enabled. - -2. Image loading currently requires installation of the ImageMagick +1. Image loading currently requires installation of the ImageMagick library as described in the next section. I have tested with Windows BMP files (and this is what the image-tester application displays). ImageMagick itself supports many image formats, but Graphic-Forms has not been tested with all of them. Therefore, images may not display properly, expecially when a transparency is selected. -3. The event-tester application's menu definition specifies that the +2. The event-tester application's menu definition specifies that the Test Menu | Submenu | Item A item should be disabled but it does not get disabled. However, the GFW:ENABLE function does otherwise work correctly for menu items. -4. The src/demos/unblocked directory contains a start at a demo +3. The src/demos/unblocked directory contains a start at a demo program (a simple game where one clicks on block shapes to score points, where the rest of the blocks fall down to fill in the gaps). This demo program is not yet finished, but the source code can still serve as sample code. -5. The text-extent generic function currently does not return +4. The text-extent generic function currently does not return the correct text height. As a workaround, get the text metrics for the desired font and base height calculations on that value. The text-extent function does return the correct width. Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun May 7 17:21:43 2006 @@ -870,10 +870,6 @@ Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn -@deffn GenericFunction running-p self -Returns T if the object is in event generation mode; nil otherwise. -@end deffn - @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Sun May 7 17:21:43 2006 @@ -126,7 +126,7 @@ @titlepage @title Graphic-Forms Programming Reference -@c @subtitle Version 0.3 +@c @subtitle Version 0.4 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top -@top Graphic-Forms Programming Reference (version 0.3) +@top Graphic-Forms Programming Reference (version 0.4) @insertcopying @end ifnottex Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun May 7 17:21:43 2006 @@ -445,7 +445,6 @@ #:retrieve-span #:right-margin-of #:run-default-message-loop - #:running-p #:scroll #:select #:select-all Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun May 7 17:21:43 2006 @@ -505,46 +505,13 @@ (by-pos BOOL) (item-info LPTR)) -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| (defcfun ("SetTimer" set-timer) UINT (hwnd HANDLE) (id UINT) (elapse UINT) - (callback :pointer)) ;; TIMERPROC -|# - -#+lispworks -(fli:define-foreign-function - (set-timer "SetTimer") - ((hwnd :pointer) - (id :unsigned-int) - (elapse :unsigned-int) - (func :pointer)) - :result-type :unsigned-int) - -#+clisp -(ffi:def-call-out set-timer - (:name "SetTimer") - (:library "user32.dll") - (:language :stdc) - (:arguments (hwnd ffi:c-pointer) - (id ffi:uint) - (elapse ffi:uint) - (func (ffi:c-function - (:arguments - (hwnd ffi:c-pointer) - (msg ffi:uint) - (id ffi:uint) - (time ffi:long)) - (:return-type nil) - (:language :stdc-stdcall)))) - (:return-type ffi:uint)) + (callback :pointer)) ;; TIMERPROC (requires _stdcall, do not use yet) ;;; SetWindowLong is deprecated in favor of SetWindowLongPtr ;;; which can be used to write code compatible to both Win32 Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 7 17:21:43 2006 @@ -407,11 +407,11 @@ 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam) - (declare (ignore hwnd lparam)) + (declare (ignore lparam)) (let* ((tc (thread-context)) (timer (get-timer tc wparam))) (if (null timer) - (gfs::kill-timer (cffi:null-pointer) wparam) + (gfs::kill-timer hwnd wparam) (progn (if (<= (delay-of timer) 0) (enable timer nil) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun May 7 17:21:43 2006 @@ -45,9 +45,11 @@ (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-menuitem-id :initform 10000 :reader next-menuitem-id) + (next-timer-id :initform 1 :reader next-timer-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) (timers-by-id :initform (make-hash-table :test #'equal)) + (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) (wip :initform nil)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) @@ -56,20 +58,46 @@ #+clisp (defvar *the-thread-context* nil) #+clisp (defun thread-context () + (when (null *the-thread-context*) + (setf *the-thread-context* (make-instance 'thread-context)) + (init-utility-hwnd *the-thread-context*)) *the-thread-context*) #+clisp (defun dispose-thread-context () + (let ((hwnd (utility-hwnd *the-thread-context*))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))) (setf *the-thread-context* nil)) #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) (when (null tc) (setf tc (make-instance 'thread-context)) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) + (init-utility-hwnd tc)) tc)) #+lispworks (defun dispose-thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) + +(defmethod init-utility-hwnd ((tc thread-context)) + (register-toplevel-noerasebkgnd-window-class) + (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here + "" ; because of circular dependency + (cffi:null-pointer) + (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-popup+) + 0))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value tc 'utility-hwnd) hwnd))) (defmethod call-child-visitor-func ((tc thread-context) parent child) "Call the closure at the top of the child window visitor function stack." @@ -163,3 +191,9 @@ (if (eql k (id-of timer)) (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id))) + +(defmethod increment-timer-id ((tc thread-context)) + "Return the next timer ID; also increment the internal value." + (let ((id (next-timer-id tc))) + (incf (slot-value tc 'next-timer-id)) + id)) Modified: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/timer.lisp (original) +++ trunk/src/uitoolkit/widgets/timer.lisp Sun May 7 17:21:43 2006 @@ -33,39 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -#+lispworks -(fli:define-foreign-callable - ("timer_proc" :result-type :void :calling-convention :stdcall) - ((hwnd :pointer) - (msg :unsigned-int) - (id :unsigned-int) - (time :long)) - (process-message hwnd gfs::+wm-timer+ id time)) - -#+lispworks -(defun gf-set-timer (delay) - (gfs::set-timer (cffi:null-pointer) - 0 delay - (fli:make-pointer :symbol-name "timer_proc"))) - -#+clisp -(defun timer_proc (hwnd msg id time) - (declare (ignore msg)) - (process-message hwnd gfs::+wm-timer+ id time) - nil) - -#+clisp -(defun gf-set-timer (delay) - (gfs::set-timer nil 0 delay #'timer_proc)) - -(defun reset-timer-to-delay (timer delay) - (remove-timer (thread-context) timer) - (let ((id (gf-set-timer delay))) - (if (zerop id) - (error 'gfs:win32-error :detail "set-timer failed")) - (setf (slot-value timer 'id) id) - (put-timer (thread-context) timer))) - (defun clamp-delay-values (init-delay delay) "Adjust delay settings based on system-defined limits." ;; @@ -85,18 +52,23 @@ (setf delay gfs::+user-timer-maximum+)) (values init-delay delay)) -(defmethod (setf delay-of) :around (value (self timer)) - (multiple-value-bind (init-delay delay) - (clamp-delay-values 0 value) +(defun reset-timer-to-delay (timer delay) + (if (and (> (id-of timer) 0) (= (delay-of timer) delay)) + (return-from reset-timer-to-delay nil)) + (multiple-value-bind (init-delay clamped) + (clamp-delay-values 0 delay) (declare (ignore init-delay)) - (if (/= delay (slot-value self 'delay)) - (setf (slot-value self 'delay) delay) - (let ((tc (thread-context)) - (new-id (gf-set-timer delay))) - (unless (or (not (running-p self)) (= new-id (id-of self))) - (remove-timer tc self) - (put-timer tc self)) - (setf (slot-value self 'id-of) new-id))))) + (let ((tc (thread-context)) + (id (id-of timer))) + (when (zerop id) + (setf (slot-value timer 'id) (increment-timer-id tc)) + (put-timer tc timer)) + (if (zerop (gfs::set-timer (utility-hwnd tc) (id-of timer) clamped (cffi:null-pointer))) + (error 'gfs:win32-error :detail "set-timer failed"))) + clamped)) + +(defmethod (setf delay-of) :around (value (self timer)) + (setf (slot-value self 'delay) (reset-timer-to-delay self value))) (defmethod initialize-instance :after ((self timer) &key) (if (null (delay-of self)) @@ -118,8 +90,8 @@ (let ((init-delay (initial-delay-of self))) (if (> init-delay 0) (reset-timer-to-delay self init-delay) - (reset-timer-to-delay self (delay-of self))))) + (setf (delay-of self) (delay-of self))))) (remove-timer (thread-context) self))) ;; kill-timer will be called on the next tick -(defmethod running-p ((self timer)) +(defmethod enabled-p ((self timer)) (get-timer (thread-context) (id-of self))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun May 7 17:21:43 2006 @@ -279,9 +279,6 @@ (defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) -(defgeneric running-p (self) - (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) - (defgeneric scroll (self dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun May 7 17:21:43 2006 @@ -36,7 +36,6 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) (gfg::initialize-magick (cffi:null-pointer)) - (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn) (run-default-message-loop)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun May 7 17:21:43 2006 @@ -33,8 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") -(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") + (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) ;;; ;;; helper functions

1 0

[graphic-forms-cvs] r119 - trunk/src/demos/unblocked
by junrue＠common-lisp.net 06 May '06

06 May '06

Author: junrue Date: Sat May 6 18:59:15 2006 New Revision: 119 Modified: trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-model.lisp Log: minor cleanup and refactoring of unblocked game model Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sat May 6 18:59:15 2006 @@ -119,7 +119,8 @@ (defun collapse-tiles (tiles) (let ((size (size-tiles tiles))) (dotimes (i (gfs:size-width size)) - (setf (aref tiles i) (collapse-column (aref tiles i)))))) + (setf (aref tiles i) (collapse-column (aref tiles i))))) + tiles) (defun clone-tiles (orig-tiles) (let* ((width (gfs:size-width (size-tiles orig-tiles))) Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sat May 6 18:59:15 2006 @@ -36,48 +36,44 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +max-tile-kinds+ 6) (defconstant +horz-tile-count+ 17) - (defconstant +vert-tile-count+ 12)) + (defconstant +vert-tile-count+ 12) + (defconstant +max-levels+ 21)) -(defun factorial (n) - (if (zerop n) - 1 - (* n (factorial (1- n))))) +(defvar *points-needed-table* (loop for level from 1 to +max-levels+ + collect (* 250 level level))) + +(defun lookup-level-reached (score) + (let ((level 1)) + (loop for entry in *points-needed-table* + until (> entry score) + do (incf level)) + level)) (cells:defmodel unblocked-game-model () ((level :accessor level - :initform (cells:c? (let* ((lvl (if cells:.cache cells:.cache 1)) - (pnts-needed (* 20 (factorial lvl)))) - (if (>= (^score) pnts-needed) - (1+ lvl) - lvl)))) + :initform (cells:c? (lookup-level-reached (^score)))) (score :accessor score - :initform (cells:c? (+ (if cells:.cache cells:.cache 0) + :initform (cells:c? (+ (or cells:.cache 0) (* 5 (length (^shape-data)))))) - (points-needed - :accessor points-needed - :initform (cells:c? (* 20 (factorial (^level))))) (shape-data :accessor shape-data :initform (cells:c-in nil)) (tiles :accessor tiles - :initform (cells:c? (let ((tmp nil) - (data (^shape-data))) - (if (null cells:.cache) - (progn - (setf tmp (init-tiles +horz-tile-count+ - +vert-tile-count+ - (1- +max-tile-kinds+))) - (collapse-tiles tmp)) - (if data - (progn - (setf tmp (clone-tiles cells:.cache)) - (loop for pnt in data do (set-tile tmp pnt 0)) - (collapse-tiles tmp)) - (setf tmp cells:.cache))) - tmp))))) + :initform (cells:c? (let ((data (^shape-data))) + (cond + ((null cells:.cache) + (collapse-tiles (init-tiles +horz-tile-count+ + +vert-tile-count+ + (1- +max-tile-kinds+)))) + (data + (let ((tmp (clone-tiles cells:.cache))) + (loop for pnt in data do (set-tile tmp pnt 0)) + (collapse-tiles tmp))) + (t + cells:.cache))))))) (defvar *game* (make-instance 'unblocked-game-model)) @@ -95,7 +91,7 @@ (level *game*)) (defun game-points-needed () - (- (points-needed *game*) (score *game*))) + (- (nth (1- (level *game*)) *points-needed-table*) (score *game*))) (defun game-score () (score *game*))

1 0

[graphic-forms-cvs] r118 - in trunk: docs/manual src src/uitoolkit/widgets
by junrue＠common-lisp.net 05 May '06

05 May '06

Author: junrue Date: Thu May 4 21:08:48 2006 New Revision: 118 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: implemented append-separator method for programmatically adding separators to menus Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 4 21:08:48 2006 @@ -668,6 +668,11 @@ the newly-created item. @end deffn +@deffn GenericFunction append-separator self +Adds a separator item to the object, and returns the newly-created +item. +@end deffn + @deffn GenericFunction append-submenu self text submenu dispatcher Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 4 21:08:48 2006 @@ -310,6 +310,7 @@ #:alignment #:ancestor-p #:append-item + #:append-separator #:append-submenu #:background-color #:background-pattern Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Thu May 4 21:08:48 2006 @@ -202,13 +202,8 @@ (check item checked))) (defmethod define-separator ((gen win32-menu-generator)) - (let* ((owner (first (menu-stack-of gen))) - (it (make-instance 'menu-item)) - (hmenu (gfs:handle owner))) - (put-menuitem (thread-context) it) - (insert-separator hmenu) - (setf (slot-value it 'gfs:handle) hmenu) - (vector-push-extend it (items owner)))) + (let ((owner (first (menu-stack-of gen)))) + (append-separator owner))) (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu May 4 21:08:48 2006 @@ -87,7 +87,7 @@ (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed"))))) -(defun insert-separator (hmenu) +(defun insert-separator (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 @@ -96,10 +96,10 @@ gfs::hbmpitem) mii-ptr gfs::menuiteminfo) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) - (setf gfs::mask gfs::+miim-ftype+) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-ftype+)) (setf gfs::type gfs::+mft-separator+) (setf gfs::state 0) - (setf gfs::id 0) + (setf gfs::id mid) (setf gfs::hsubmenu (cffi:null-pointer)) (setf gfs::hbmpchecked (cffi:null-pointer)) (setf gfs::hbmpunchecked (cffi:null-pointer)) @@ -142,6 +142,19 @@ (vector-push-extend item (items owner)) item)) +(defmethod append-separator ((owner menu)) + (if (gfs:disposed-p owner) + (error 'gfs:disposed-error)) + (let* ((tc (thread-context)) + (id (increment-menuitem-id tc)) + (howner (gfs:handle owner)) + (item (make-instance 'menu-item :handle howner))) + (insert-separator howner id) + (setf (item-id item) id) + (put-menuitem tc item) + (vector-push-extend item (items owner)) + item)) + (defmethod append-submenu ((parent menu) text (submenu menu) disp) (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu)) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 4 21:08:48 2006 @@ -48,6 +48,9 @@ (defgeneric append-item (self text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) +(defgeneric append-separator (self) + (:documentation "Add a separator item to the object, and returns the newly-created item.")) + (defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))

1 0

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

04 May '06

Author: junrue Date: Thu May 4 16:22:47 2006 New Revision: 117 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented background-color/foreground-color/font customization for labels, infrastructure is in place for other controls too Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 4 16:22:47 2006 @@ -59,6 +59,9 @@ ;; constants ;; methods, functions, macros + #:copy-point + #:copy-size + #:copy-span #:detail #:dispose #:disposed-p @@ -98,6 +101,7 @@ (:export ;; classes and structs + #:color #:font #:font-data #:font-metrics @@ -132,6 +136,9 @@ #:color-red #:color-table #:copy-area + #:copy-color + #:copy-font-data + #:copy-font-metrics #:data-obj #:depth #:descent Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu May 4 16:22:47 2006 @@ -104,6 +104,7 @@ ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here + (setf (gfg:background-color w) (gfg:background-color *layout-tester-win*)) (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp"))) (gfg:with-image-transparency (tmp-image (gfs:make-point)) (setf (gfw:image w) tmp-image)))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu May 4 16:22:47 2006 @@ -152,6 +152,11 @@ (path :string)) (defcfun + ("CreateSolidBrush" create-solid-brush) + HANDLE + (color COLORREF)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu May 4 16:22:47 2006 @@ -800,6 +800,13 @@ (defconstant +wm-initmenupopup+ #x0117) (defconstant +wm-menuselect+ #x011F) (defconstant +wm-menuchar+ #x0120) +(defconstant +wm-ctlcolormsgbox+ #x0132) +(defconstant +wm-ctlcoloredit+ #x0133) +(defconstant +wm-ctlcolorlistbox+ #x0134) +(defconstant +wm-ctlcolorbtn+ #x0135) +(defconstant +wm-ctlcolordlg+ #x0136) +(defconstant +wm-ctlcolorscrollbar+ #x0137) +(defconstant +wm-ctlcolorstatic+ #x0138) (defconstant +wm-mousefirst+ #x0200) ; for use with peek-message (defconstant +wm-mousemove+ #x0200) (defconstant +wm-lbuttondown+ #x0201) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 4 16:22:47 2006 @@ -259,6 +259,13 @@ (index INT)) (defcfun + ("GetClassNameA" get-class-name) + INT + (hwnd HANDLE) + (classname LPTSTR) + (maxcount INT)) + +(defcfun ("GetClientRect" get-client-rect) BOOL (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Thu May 4 16:22:47 2006 @@ -53,13 +53,40 @@ ;;; methods ;;; -(defmethod background-color :before ((ctrl control)) +(defmethod gfg:background-color :before ((ctrl control)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) -(defmethod background-color ((ctrl control)) - (declare (ignore ctrl)) - (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+))) +(defmethod gfg:background-color ((ctrl control)) + (or (brush-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + +(defmethod (setf gfg:background-color) :before (color (ctrl control)) + (declare (ignore color)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:background-color) (color (ctrl control)) + (let ((hbrush (brush-handle-of ctrl))) + (when (not (gfs:null-handle-p hbrush)) + (gfs::delete-object hbrush) + (setf (brush-handle-of ctrl) (cffi:null-pointer))) + (setf hbrush (gfs::create-solid-brush (gfg:color->rgb color))) + (if (gfs:null-handle-p hbrush) + (error 'gfs:win32-error :detail "create-solid-brush failed")) + (setf (brush-color-of ctrl) (gfg:copy-color color)) + (setf (brush-handle-of ctrl) hbrush)) + (redraw ctrl)) + +(defmethod gfs:dispose ((ctrl control)) + (let ((hbrush (brush-handle-of ctrl)) + (font (font-of ctrl))) + (if font + (gfs:dispose font)) + (setf (font-of ctrl) nil) + (if (not (gfs:null-handle-p hbrush)) + (gfs::delete-object hbrush)) + (setf (brush-handle-of ctrl) (cffi:null-pointer))) + (call-next-method)) (defmethod focus-p :before ((ctrl control)) (if (gfs:disposed-p ctrl) @@ -69,6 +96,38 @@ (let ((focus-hwnd (gfs::get-focus))) (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl))))) +(defmethod gfg:font :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod gfg:font ((ctrl control)) + (font-of ctrl)) + +(defmethod (setf gfg:font) :before (font (ctrl control)) + (declare (ignore color)) + (if (or (gfs:disposed-p ctrl) (gfs:disposed-p font)) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:font) (font (ctrl control)) + (setf (font-of ctrl) font) + (redraw ctrl)) + +(defmethod gfg:foreground-color :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod gfg:foreground-color ((ctrl control)) + (or (text-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+)))) + +(defmethod (setf gfg:foreground-color) :before (color (ctrl control)) + (declare (ignore color)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:foreground-color) (color (ctrl control)) + (setf (text-color-of ctrl) (gfg:copy-color color)) + (redraw ctrl)) + (defmethod give-focus :before ((ctrl control)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu May 4 16:22:47 2006 @@ -306,6 +306,27 @@ (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) +(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) + (declare (ignore hwnd)) + (let* ((tc (thread-context)) + (widget (get-widget tc (cffi:make-pointer lparam))) + (hdc (cffi:make-pointer wparam)) + (bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget)) + (ret-val 0)) + (when widget + (if (not (typep widget 'label)) + (error 'gfs:toolkit-error :detail "incorrect widget type received WM_CTLCOLORSTATIC")) + (let ((font (font-of widget))) + (if font + (gfs::select-object hdc (gfs:handle font)))) + (if bkgdcolor + (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) + (if textcolor + (gfs::set-text-color hdc (gfg:color->rgb textcolor))) + (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) + ret-val)) + (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam :right-button)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu May 4 16:22:47 2006 @@ -34,7 +34,7 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; (defun compute-image-style-flags (style) @@ -77,6 +77,20 @@ (setf flags (logior flags gfs::+ss-left+))))) flags)) +;;; +;;; methods +;;; + +(defmethod (setf gfg:background-color) (color (label label)) + (declare (ignorable color)) + (call-next-method) + (let ((image (image label)) + (pnt (pixel-point-of label))) + (when image + (if pnt + (setf (gfg:transparency-pixel-of image) pnt)) + (setf (image label) image)))) + (defmethod compute-style-flags ((label label) style &rest extra-data) (declare (ignore label)) (if (> (count-if-not #'null extra-data) 1) @@ -113,7 +127,7 @@ gfs::+ws-visible+)) (tr-pnt (gfg:transparency-pixel-of image))) (if tr-pnt - (let* ((color (background-color label)) + (let* ((color (gfg:background-color label)) (size (gfg:size image)) (bounds (make-instance 'gfs:rectangle :size size)) (tmp-image (make-instance 'gfg:image :size size)) @@ -125,7 +139,8 @@ (setf (gfg:foreground-color gc) color) (gfg:draw-filled-rectangle gc bounds) (setf (gfg:foreground-color gc) orig-color)) - (gfg:draw-image gc image (gfs:location bounds))) + (gfg:draw-image gc image (gfs:location bounds)) + (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (gfs:dispose gc)) (setf image tmp-image))) (if (/= orig-flags flags) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 4 16:22:47 2006 @@ -33,9 +33,6 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") -(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") - (defconstant +default-window-title+ "New Window") ;;; Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 4 16:22:47 2006 @@ -65,7 +65,22 @@ (defclass caret (widget) () (:documentation "The caret class provides an i-beam typically representing an insertion point.")) -(defclass control (widget) () +(defclass control (widget) + ((brush-color + :accessor brush-color-of + :initform nil) + (brush-handle + :accessor brush-handle-of + :initform (cffi:null-pointer)) + (font + :accessor font-of + :initform nil) + (text-color + :accessor text-color-of + :initform nil) + (pixel-point + :accessor pixel-point-of + :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) (defclass button (control) () Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 4 16:22:47 2006 @@ -51,9 +51,6 @@ (defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) -(defgeneric background-color (self) - (:documentation "Returns a color object corresponding to the current background color.")) - (defgeneric border-width (self) (:documentation "Returns the object's border width.")) @@ -156,9 +153,6 @@ (defgeneric focus-p (self) (:documentation "Returns T if this object has the keyboard focus; nil otherwise.")) -(defgeneric foreground-color (self) - (:documentation "Returns a color object corresponding to the current foreground color.")) - (defgeneric give-focus (self) (:documentation "Causes this object to have the keyboard focus.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu May 4 16:22:47 2006 @@ -33,6 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") +(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") + ;;; ;;; helper functions ;;; @@ -151,8 +154,15 @@ ;;; methods ;;; -(defmethod background-color ((win window)) - (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+))) +(defmethod gfg:background-color ((win window)) + (let ((hwnd (gfs:handle win)) + (color nil)) + (cffi:with-foreign-pointer-as-string (str-ptr 64) + (gfs::get-class-name hwnd str-ptr 64) + (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) + (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) + color)) (defmethod compute-outer-size ((win window) desired-client-size) ;; TODO: consider reimplementing this with AdjustWindowRect

1 0

[graphic-forms-cvs] r116 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 03 May '06

03 May '06

Author: junrue Date: Wed May 3 18:01:17 2006 New Revision: 116 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: hopefully this is the last time I have to fiddle with key event processing Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed May 3 18:01:17 2006 @@ -215,7 +215,7 @@ (ch (gfs::map-virtual-key wparam-lo 2)) (w (get-widget tc hwnd))) (setf (virtual-key tc) wparam-lo) - (when w + (when (and w (zerop ch)) (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))) 0)

1 0

[graphic-forms-cvs] r115 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 02 May '06

02 May '06

Author: junrue Date: Tue May 2 01:02:27 2006 New Revision: 115 Modified: trunk/src/uitoolkit/widgets/layout.lisp Log: corrected a compiler warning issued by LispWorks Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Tue May 2 01:02:27 2006 @@ -33,10 +33,11 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ - gfs::+swp-noownerzorder+ - gfs::+swp-noactivate+ - gfs::+swp-nocopybits+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ + gfs::+swp-noownerzorder+ + gfs::+swp-noactivate+ + gfs::+swp-nocopybits+))) ;;; ;;; methods

1 0