graphic-forms-cvs June 2006

graphic-forms-cvs@common-lisp.net

1 participants
26 discussions

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

28 Jun '06

Author: junrue Date: Wed Jun 28 17:44:07 2006 New Revision: 167 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp Log: introduced infrastructure for dispatching control notifications, and used this to implement event-focus-gain/event-focus-loss and event-modify for edit controls Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Wed Jun 28 17:44:07 2006 @@ -126,6 +126,23 @@ (call-next-method) (gfs:dispose dlg)) +(defclass edit-control-events (gfw:event-dispatcher) ()) + +(defun truncate-text (str) + (subseq str 0 (min (length str) 5))) + +(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl)))) + +(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl)))) + +(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time) + (declare (ignore time)) + (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl)))) + (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -135,6 +152,7 @@ :style '(:horizontal)) :style style :text title)) + (edit-disp (make-instance 'edit-control-events)) (left-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout :spacing 4 @@ -145,6 +163,7 @@ :parent left-panel)) (name-edit (make-instance 'gfw:edit :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :dispatcher edit-disp :parent left-panel)) (serial-label (make-instance 'gfw:label :text "Serial Number:" @@ -152,6 +171,7 @@ (serial-edit (make-instance 'gfw:edit :style '(:read-only) :text "323K DSKL3 DSKE23" + :dispatcher edit-disp :parent left-panel)) (pw-label (make-instance 'gfw:label :text "Password:" @@ -159,6 +179,7 @@ (pw-edit (make-instance 'gfw:edit :style '(:mask-characters) :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :dispatcher edit-disp :parent left-panel)) (desc-label (make-instance 'gfw:label :text "Description:" @@ -166,6 +187,7 @@ (desc-edit (make-instance 'gfw:edit :style '(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return) :text (format nil "WWWWWWWWWWWWWWWWWWWWWWWW~%W~%W~%W~%W~%W") + :dispatcher edit-disp :parent left-panel)) (btn-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Jun 28 17:44:07 2006 @@ -271,6 +271,17 @@ (defconstant +em-setimestatus+ #x00D8) (defconstant +em-getimestatus+ #x00D9) +(defconstant +en-setfocus+ #x0100) +(defconstant +en-killfocus+ #x0200) +(defconstant +en-change+ #x0300) +(defconstant +en-update+ #x0400) +(defconstant +en-errspace+ #x0500) +(defconstant +en-maxtext+ #x0501) +(defconstant +en-hscroll+ #x0601) +(defconstant +en-vscroll+ #x0602) +(defconstant +en-align-ltr-ec+ #x0700) +(defconstant +en-align-rtl-ec+ #x0701) + (defconstant +es-left+ #x0000) (defconstant +es-center+ #x0001) (defconstant +es-right+ #x0002) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Jun 28 17:44:07 2006 @@ -118,6 +118,15 @@ (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) +(defun dispatch-notification (widget wparam-hi) + (let ((disp (dispatcher widget)) + (time (event-time (thread-context)))) + (case wparam-hi + (0 (event-select disp widget time (gfs:make-rectangle))) ; FIXME: debug + (#.gfs::+en-killfocus+ (event-focus-loss disp widget time)) + (#.gfs::+en-setfocus+ (event-focus-gain disp widget time)) + (#.gfs::+en-update+ (event-modify disp widget time))))) + ;;; ;;; process-message methods ;;; @@ -156,14 +165,10 @@ ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t - (let ((w (get-widget tc (cffi:make-pointer lparam)))) - (if (null w) - (warn 'gfs:toolkit-warning :detail "no object for hwnd") - (unless (null (dispatcher w)) - (event-select (dispatcher w) - w - (event-time tc) - (gfs:make-rectangle))))))) ; FIXME + (let ((widget (get-widget tc (cffi:make-pointer lparam)))) + (when (and widget (dispatcher widget)) + ; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam) + (dispatch-notification widget wparam-hi))))) (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0)

1 0

[graphic-forms-cvs] r166 - in trunk/src/uitoolkit: system widgets
by junrue＠common-lisp.net 28 Jun '06

28 Jun '06

Author: junrue Date: Wed Jun 28 12:33:32 2006 New Revision: 166 Modified: trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/edit.lisp Log: added activation context data structure, which will be needed in the future for enabling common control theme support Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Wed Jun 28 12:33:32 2006 @@ -53,6 +53,7 @@ (defctype DWORD :unsigned-long) (defctype HANDLE :pointer) (defctype INT :int) +(defctype LANGID :short) (defctype LONG :long) (defctype LPARAM :long) (defctype LPCSTR :pointer) @@ -68,9 +69,21 @@ (defctype TCHAR :char) (defctype UINT :unsigned-int) (defctype ULONG :unsigned-long) +(defctype USHORT :unsigned-short) (defctype WORD :short) (defctype WPARAM :unsigned-int) +(defcstruct actctx + (cbsize ULONG) + (flags DWORD) + (source :string) + (arch USHORT) + (langid LANGID) + (dir :string) + (resname :string) + (appname :string) + (hmodule HANDLE)) + (defcstruct bitmap (type LONG) (width LONG) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Wed Jun 28 12:33:32 2006 @@ -105,3 +105,6 @@ (defmethod (setf text) (str (self edit)) (set-widget-text self str)) + +(defmethod text-baseline ((self edit)) + (widget-text-baseline self +vertical-edit-text-margin+))

1 0

[graphic-forms-cvs] r165 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 28 Jun '06

28 Jun '06

Author: junrue Date: Tue Jun 27 23:22:46 2006 New Revision: 165 Modified: trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: more edit control testing via windlg Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Tue Jun 27 23:22:46 2006 @@ -118,19 +118,6 @@ :initial-directory #P"c:/") (print paths))) -(defclass dlg-test-panel (gfw:panel) ()) - -(defmethod gfw:preferred-size ((win dlg-test-panel) width-hint height-hint) - (declare (ignore width-hint height-hint)) - (gfs:make-size :width 280 :height 200)) - -(defmethod gfw:event-paint ((self gfw:event-dispatcher) (panel dlg-test-panel) time gc rect) - (declare (ignore time rect)) - (let ((parent (gfw:parent panel))) - (setf (gfg:background-color gc) (gfg:background-color parent)) - (setf (gfg:foreground-color gc) (gfg:background-color parent)) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:size panel))))) - (defclass dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) @@ -144,13 +131,42 @@ :dispatcher (make-instance 'dialog-events) :layout (make-instance 'gfw:flow-layout :margins 8 - :spacing 4 + :spacing 8 :style '(:horizontal)) :style style :text title)) - (panel (make-instance 'dlg-test-panel - :style '(:border) - :parent dlg)) + (left-panel (make-instance 'gfw:panel + :layout (make-instance 'gfw:flow-layout + :spacing 4 + :style '(:vertical)) + :parent dlg)) + (name-label (make-instance 'gfw:label + :text "Name:" + :parent left-panel)) + (name-edit (make-instance 'gfw:edit + :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :parent left-panel)) + (serial-label (make-instance 'gfw:label + :text "Serial Number:" + :parent left-panel)) + (serial-edit (make-instance 'gfw:edit + :style '(:read-only) + :text "323K DSKL3 DSKE23" + :parent left-panel)) + (pw-label (make-instance 'gfw:label + :text "Password:" + :parent left-panel)) + (pw-edit (make-instance 'gfw:edit + :style '(:mask-characters) + :text "WWWWWWWWWWWWWWWWWWWWWWWW" + :parent left-panel)) + (desc-label (make-instance 'gfw:label + :text "Description:" + :parent left-panel)) + (desc-edit (make-instance 'gfw:edit + :style '(:multi-line :auto-hscroll :auto-vscroll :vertical-scrollbar :want-return) + :text (format nil "WWWWWWWWWWWWWWWWWWWWWWWW~%W~%W~%W~%W~%W") + :parent left-panel)) (btn-panel (make-instance 'gfw:panel :layout (make-instance 'gfw:flow-layout :spacing 4 @@ -170,8 +186,11 @@ :style '(:cancel-button) :text "Cancel" :parent btn-panel))) - (declare (ignore panel ok-btn cancel-btn)) + (declare (ignore name-label serial-label serial-edit pw-label desc-label ok-btn cancel-btn)) (gfw:pack dlg) + (setf (gfw:text name-edit) "" + (gfw:text pw-edit) "" + (gfw:text desc-edit) "") (gfw:center-on-owner dlg) (gfw:show dlg t) dlg)) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Jun 27 23:22:46 2006 @@ -42,7 +42,7 @@ (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags +default-child-style+) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) (style (style-of self))) (loop for sym in style do (cond Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jun 27 23:22:46 2006 @@ -42,22 +42,26 @@ (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags +default-child-style+) + (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) (style (style-of self))) (loop for sym in style do (ecase sym ;; primary edit styles ;; - (:multi-line (setf std-flags (logior +default-child-style+ - gfs::+es-multiline+))) + (:multi-line (setf std-flags (logior +default-child-style+ + gfs::+ws-tabstop+ + gfs::+es-multiline+))) ;; styles that can be combined ;; - (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) - (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) - (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) - (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) - (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) - (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) + (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) + (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) + (:no-border ) + (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) + (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) + (:vertical-scrollbar (setf std-flags (logior std-flags gfs::+ws-vscroll+))) + (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) (if (not (find :multi-line style)) (setf std-flags (logior std-flags gfs::+es-autohscroll+))) (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jun 27 23:22:46 2006 @@ -92,7 +92,7 @@ (let ((hwnd (gfs::create-window ex-style cname-ptr title-ptr - (if child-id (logior std-style gfs::+ws-tabstop+) std-style) + std-style gfs::+cw-usedefault+ gfs::+cw-usedefault+ gfs::+cw-usedefault+

1 0

[graphic-forms-cvs] r164 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 28 Jun '06

28 Jun '06

Author: junrue Date: Tue Jun 27 22:15:00 2006 New Revision: 164 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: edit controls can now be created, minimally tested via layout-tester Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Jun 27 22:15:00 2006 @@ -293,11 +293,14 @@ @item :auto-hscroll Specifies that the @code{edit control} will scroll text content to the right by 10 characters when the user types a character at the end -of the line. +of the line. For single-line @code{edit control}s, this style is set +by the library. @item :auto-vscroll Specifies that the @code{edit control} will scroll text up by a page when the user types @sc{enter} on the last line. This style keyword is only meaningful when @code{:multi-line} is also specified. +@item :horizontal-scrollbar +Specifies that a horizontal scrollbar should be displayed. @item :mask-characters Specifies that each character of text be masked by an echo character instead of the one literally typed. The character can be changed via @@ -319,6 +322,8 @@ @item :read-only Specifies that the @code{edit control}'s contents cannot be modified by the user. +@item :vertical-scrollbar +Specifies that a vertical scrollbar should be displayed. @item :want-return Specifies that a carriage return be inserted when the user types @sc{enter}. This style keyword only applies when the @code{:multi-line} @@ -327,6 +332,9 @@ default button. @end table @end deffn +@deffn Initarg :text +Supplies the initial text for the @code{edit control}. +@end deffn @end deftp @anchor{event-dispatcher} @@ -987,8 +995,13 @@ Set the size and location of this object's children. @end deffn -@deffn GenericFunction location self -Returns a @ref{point} object describing the coordinates of the +@anchor{line-count} +@deffn GenericFunction line-count self => integer +Returns the total number of lines (e.g., of text) contained by @code{self}. +@end deffn + +@deffn GenericFunction location self => @ref{point} +Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. @xref{parent}. @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Jun 27 22:15:00 2006 @@ -227,6 +227,7 @@ #:control #:dialog #:display + #:edit #:event-dispatcher #:event-source #:file-dialog @@ -414,6 +415,7 @@ #:layout-of #:layout-p #:left-margin-of + #:line-count #:lines-visible-p #:location #:lock Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Jun 27 22:15:00 2006 @@ -34,10 +34,11 @@ (in-package #:graphic-forms.uitoolkit.tests) (defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defconstant +btn-text-after+ "Again!") +(defconstant +edit-text+ "something to edit") +(defconstant +label-text+ "Label") +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -99,7 +100,7 @@ (defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w nil)) + (w nil)) (cond ((or (eql subtype :check-box) (eql subtype :push-button) @@ -112,6 +113,10 @@ :style (list subtype))) (setf (toggle-fn be) (create-button-toggler be)) (setf (gfw:text w) (funcall (toggle-fn be)))) + ((eql subtype :single-line-edit) + (setf w (make-instance widget-class + :parent *layout-tester-win* + :text (format nil "~d ~a" (id be) +edit-text+)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -389,6 +394,8 @@ (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (add-checkbox-disp (make-instance 'add-child-dispatcher :subtype :check-box)) + (add-edit-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:edit + :subtype :single-line-edit)) (add-radio-disp (make-instance 'add-child-dispatcher :subtype :radio-button)) (add-toggle-disp (make-instance 'add-child-dispatcher :subtype :toggle-button)) (add-tri-state-disp (make-instance 'add-child-dispatcher :subtype :tri-state)) @@ -411,14 +418,15 @@ :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" - :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Checkbox" :dispatcher add-checkbox-disp) + :submenu ((:item "Button" :dispatcher add-btn-disp) + (:item "Checkbox" :dispatcher add-checkbox-disp) + (:item "Edit" :dispatcher add-edit-disp) (:item "Label - Image" :dispatcher add-image-label-disp) - (:item "Label - Text" :dispatcher add-text-label-disp) - (:item "Panel" :dispatcher add-panel-disp) - (:item "Radiobutton" :dispatcher add-radio-disp) - (:item "Toggle" :dispatcher add-toggle-disp) - (:item "Tri-State" :dispatcher add-tri-state-disp))) + (:item "Label - Text" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp) + (:item "Radiobutton" :dispatcher add-radio-disp) + (:item "Toggle" :dispatcher add-toggle-disp) + (:item "Tri-State" :dispatcher add-tri-state-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Jun 27 22:15:00 2006 @@ -34,6 +34,7 @@ (in-package :graphic-forms.uitoolkit.system) (defconstant +button-classname+ "button") +(defconstant +edit-classname+ "edit") (defconstant +static-classname+ "static") (defconstant +ad-counterclockwise+ 1) @@ -47,31 +48,31 @@ (defconstant +bi-png+ 5) (defconstant +blt-blackness+ #x00000042) -(defconstant +blt-notsrcerase+ #x001100a6) +(defconstant +blt-notsrcerase+ #x001100A6) (defconstant +blt-notsrccopy+ #x00330008) (defconstant +blt-srcerase+ #x00440328) (defconstant +blt-dstinvert+ #x00550009) -(defconstant +blt-patinvert+ #x005a0049) +(defconstant +blt-patinvert+ #x005A0049) (defconstant +blt-srcinvert+ #x00660046) -(defconstant +blt-srcand+ #x008800c6) -(defconstant +blt-mergecopy+ #x00c000ca) -(defconstant +blt-mergepaint+ #x00bb0226) -(defconstant +blt-srccopy+ #x00cc0020) -(defconstant +blt-srcpaint+ #x00ee0086) -(defconstant +blt-patcopy+ #x00f00021) -(defconstant +blt-patpaint+ #x00fb0a09) -(defconstant +blt-whiteness+ #x00ff0062) +(defconstant +blt-srcand+ #x008800C6) +(defconstant +blt-mergecopy+ #x00C000CA) +(defconstant +blt-mergepaint+ #x00BB0226) +(defconstant +blt-srccopy+ #x00CC0020) +(defconstant +blt-srcpaint+ #x00EE0086) +(defconstant +blt-patcopy+ #x00F00021) +(defconstant +blt-patpaint+ #x00FB0A09) +(defconstant +blt-whiteness+ #x00FF0062) (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000) -(defconstant +bm-getcheck+ #x00f0) -(defconstant +bm-setcheck+ #x00f1) -(defconstant +bm-getstate+ #x00f2) -(defconstant +bm-setstate+ #x00f3) -(defconstant +bm-setstyle+ #x00f4) -(defconstant +bm-click+ #x00f5) -(defconstant +bm-getimage+ #x00f6) -(defconstant +bm-setimage+ #x00f7) +(defconstant +bm-getcheck+ #x00F0) +(defconstant +bm-setcheck+ #x00F1) +(defconstant +bm-getstate+ #x00F2) +(defconstant +bm-setstate+ #x00F3) +(defconstant +bm-setstyle+ #x00F4) +(defconstant +bm-click+ #x00F5) +(defconstant +bm-getimage+ #x00F6) +(defconstant +bm-setimage+ #x00F7) (defconstant +bs-solid+ 0) (defconstant +bs-null+ 1) @@ -139,7 +140,7 @@ (defconstant +cderr-memallocfailure+ #x0009) (defconstant +cderr-memlockfailure+ #x000a) (defconstant +cderr-nohook+ #x000b) -(defconstant +cderr-registermsgfail+ #x000c) +(defconstant +cderr-registermsgfail+ #x000C) (defconstant +cferr-choosefontcodes+ #x2000) (defconstant +cferr-nofonts+ #x2001) @@ -230,6 +231,46 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +em-getsel+ #x00B0) +(defconstant +em-setsel+ #x00B1) +(defconstant +em-getrect+ #x00B2) +(defconstant +em-setrect+ #x00B3) +(defconstant +em-setrectnp+ #x00B4) +(defconstant +em-scroll+ #x00B5) +(defconstant +em-linescroll+ #x00B6) +(defconstant +em-scrollcaret+ #x00B7) +(defconstant +em-getmodify+ #x00B8) +(defconstant +em-setmodify+ #x00B9) +(defconstant +em-getlinecount+ #x00BA) +(defconstant +em-lineindex+ #x00BB) +(defconstant +em-sethandle+ #x00BC) +(defconstant +em-gethandle+ #x00BD) +(defconstant +em-getthumb+ #x00BE) +(defconstant +em-linelength+ #x00C1) +(defconstant +em-replacesel+ #x00C2) +(defconstant +em-getline+ #x00C4) +(defconstant +em-limittext+ #x00C5) +(defconstant +em-canundo+ #x00C6) +(defconstant +em-undo+ #x00C7) +(defconstant +em-fmtlines+ #x00C8) +(defconstant +em-linefromchar+ #x00C9) +(defconstant +em-settabstops+ #x00CB) +(defconstant +em-setpasswordchar+ #x00CC) +(defconstant +em-emptyundobuffer+ #x00CD) +(defconstant +em-getfirstvisibleline+ #x00CE) +(defconstant +em-setreadonly+ #x00CF) +(defconstant +em-setwordbreakproc+ #x00D0) +(defconstant +em-getwordbreakproc+ #x00D1) +(defconstant +em-getpasswordchar+ #x00D2) +(defconstant +em-setmargins+ #x00D3) +(defconstant +em-getmargins+ #x00D4) +(defconstant +em-setlimittext+ #x00C5) +(defconstant +em-getlimittext+ #x00D5) +(defconstant +em-posfromchar+ #x00D6) +(defconstant +em-charfrompos+ #x00D7) +(defconstant +em-setimestatus+ #x00D8) +(defconstant +em-getimestatus+ #x00D9) + (defconstant +es-left+ #x0000) (defconstant +es-center+ #x0001) (defconstant +es-right+ #x0002) @@ -545,8 +586,8 @@ (defconstant +pderr-nodefaultprn+ #x1008) (defconstant +pderr-dndmmismatch+ #x1009) (defconstant +pderr-createicfailure+ #x100a) -(defconstant +pderr-printernotfound+ #x100b) -(defconstant +pderr-defaultdifferent+ #x100c) +(defconstant +pderr-printernotfound+ #x100B) +(defconstant +pderr-defaultdifferent+ #x100C) (defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Jun 27 22:15:00 2006 @@ -40,10 +40,10 @@ ;;; methods ;;; -(defmethod compute-style-flags ((btn button) &rest extra-data) +(defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+) - (style (style-of btn))) + (style (style-of self))) (loop for sym in style do (cond ;; primary button styles @@ -64,27 +64,26 @@ (logior std-flags gfs::+bs-pushbutton+)) (values std-flags 0))) -(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys) +(defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) - (compute-style-flags btn) + (compute-style-flags self) (let ((hwnd (create-window gfs::+button-classname+ (or text " ") (gfs:handle parent) std-style ex-style (cond - ((find :default-button (style-of btn)) + ((find :default-button (style-of self)) gfs::+idok+) - ((find :cancel-button (style-of btn)) + ((find :cancel-button (style-of self)) gfs::+idcancel+) (t (increment-widget-id (thread-context))))))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (unless (zerop (logand std-style gfs::+bs-defpushbutton+)) (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)) - (setf (slot-value btn 'gfs:handle) hwnd))) - (init-control btn)) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self)) (defmethod preferred-size ((self button) width-hint height-hint) (let ((text-size (widget-text-size self gfs::+dt-singleline+)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Jun 27 22:15:00 2006 @@ -43,11 +43,7 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (unless (zerop (gfs::send-message hwnd - gfs::+wm-setfont+ - (cffi:pointer-address hfont) - 0)) - (error 'gfs:win32-error :detail "send-message failed")))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jun 27 22:15:00 2006 @@ -33,30 +33,71 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defconstant +horizontal-edit-text-margin+ 2) +(defconstant +vertical-edit-text-margin+ 2) + ;;; ;;; methods ;;; (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) - (let ((border-flag (if (find :no-border (style-of self)) 0 gfs::+ws-border+))) - (values (loop for sym in (style-of self) - for std-flags = (logior +default-child-style+ border-flag) - then (logior std-flags - (ecase sym - ;; primary edit styles - ;; - (:multi-line (logior +default-child-style+ - gfs::+es-multiline+ - border-flag)) - - ;; styles that can be combined - ;; - (:auto-hscroll gfs::+es-autohscroll+) - (:auto-vscroll gfs::+es-autovscroll+) - (:mask-characters gfs::+es-password+) - (:no-hide-selection gfs::+es-nohidesel+) - (:read-only gfs::+es-readonly+) - (:want-return gfs::+es-wantreturn+))) - finally (return std-flags)) - 0))) + (let ((std-flags +default-child-style+) + (style (style-of self))) + (loop for sym in style + do (ecase sym + ;; primary edit styles + ;; + (:multi-line (setf std-flags (logior +default-child-style+ + gfs::+es-multiline+))) + ;; styles that can be combined + ;; + (:auto-hscroll (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (:auto-vscroll (setf std-flags (logior std-flags gfs::+es-autovscroll+))) + (:mask-characters (setf std-flags (logior std-flags gfs::+es-password+))) + (:no-hide-selection (setf std-flags (logior std-flags gfs::+es-nohidesel+))) + (:read-only (setf std-flags (logior std-flags gfs::+es-readonly+))) + (:want-return (setf std-flags (logior std-flags gfs::+es-wantreturn+))))) + (if (not (find :multi-line style)) + (setf std-flags (logior std-flags gfs::+es-autohscroll+))) + (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+)))) + +(defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) + (multiple-value-bind (std-style ex-style) + (compute-style-flags self) + (let ((hwnd (create-window gfs::+edit-classname+ + (or text "") + (gfs:handle parent) + std-style + ex-style + (increment-widget-id (thread-context))))) + (setf (slot-value self 'gfs:handle) hwnd))) + (init-control self)) + +(defmethod line-count ((self edit)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0)) + +(defmethod preferred-size ((self edit) width-hint height-hint) + (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+))) + (size (gfs:make-size)) + (b-width (* (border-width self) 2))) + (if (>= width-hint 0) + (setf (gfs:size-width size) width-hint) + (setf (gfs:size-width size) (+ b-width + (gfs:size-width text-size) + (* +horizontal-edit-text-margin+ 2)))) + (if (>= height-hint 0) + (setf (gfs:size-height size) height-hint) + (setf (gfs:size-height size) (+ b-width + (* (gfs:size-height text-size) (line-count self)) + (* +vertical-edit-text-margin+ 2)))) + size)) + +(defmethod text ((self edit)) + (get-widget-text self)) + +(defmethod (setf text) (str (self edit)) + (set-widget-text self str)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Jun 27 22:15:00 2006 @@ -115,7 +115,7 @@ (if (zerop (gfs::set-window-long hwnd gfs::+gwlp-wndproc+ (cffi:pointer-address - (cffi:get-callback 'subclassing_wndproc)))) + (cffi:get-callback 'subclassing_wndproc)))) (error 'gfs:win32-error :detail "set-window-long failed"))) ;;; Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Jun 27 22:15:00 2006 @@ -152,6 +152,7 @@ (cffi:pointer-address (gfs:handle image))))) (defmethod initialize-instance :after ((label label) &key image parent separator text &allow-other-keys) + (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) (let ((hwnd (create-window gfs::+static-classname+ @@ -160,8 +161,6 @@ (logior std-style) ex-style (increment-widget-id (thread-context))))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) (setf (slot-value label 'gfs:handle) hwnd) (if image (setf (image label) image)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Jun 27 22:15:00 2006 @@ -99,8 +99,6 @@ 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) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jun 27 22:15:00 2006 @@ -189,6 +189,9 @@ (defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) +(defgeneric line-count (self) + (:documentation "Returns the total number of lines (e.g., of text).")) + (defgeneric lines-visible-p (self) (:documentation "Returns T if the object's lines are visible; nil otherwise.")) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jun 27 22:15:00 2006 @@ -78,24 +78,34 @@ (unless (zerop count) (gfw:clear-span w (gfs:make-span :start 0 :end (1- count)))))) +(defun initialize-comctl-classes (icc-flags) + (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex) + (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex) + (setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex) + gfs::icc icc-flags)) + (if (zerop (gfs::init-common-controls ic-ptr)) + (warn 'gfs:toolkit-warning :detail "init-common-controls failed")))) + (defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id) (cffi:with-foreign-string (cname-ptr class-name) (cffi:with-foreign-string (title-ptr title) - (gfs::create-window - ex-style - cname-ptr - title-ptr - (if child-id (logior std-style gfs::+ws-tabstop+) std-style) - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - gfs::+cw-usedefault+ - parent-hwnd - (if (zerop (logand gfs::+ws-child+ std-style)) - (cffi:null-pointer) - (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) - (cffi:null-pointer) - 0)))) + (let ((hwnd (gfs::create-window ex-style + cname-ptr + title-ptr + (if child-id (logior std-style gfs::+ws-tabstop+) std-style) + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + gfs::+cw-usedefault+ + parent-hwnd + (if (zerop (logand gfs::+ws-child+ std-style)) + (cffi:null-pointer) + (cffi:make-pointer (or child-id (increment-widget-id (thread-context))))) + (cffi:null-pointer) + 0))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + hwnd)))) (defun get-widget-text (w) (if (gfs:disposed-p w)

1 0

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

27 Jun '06

Author: junrue Date: Mon Jun 26 18:28:49 2006 New Revision: 163 Added: trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/widgets/edit.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: preparation for implementing edit control Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 26 18:28:49 2006 @@ -280,6 +280,55 @@ derives from @ref{native-object}. @end deftp +@anchor{edit} +@deftp Class edit +This subclass of @ref{control} represents a rectangular area that +permits the user to enter and edit text. The @ref{event-focus-gain} +and @ref{event-focus-loss} methods of each @code{edit control}'s +@ref{event-dispatcher} are invoked when focus is given or taken +away. The @ref{event-modify} method is invoked when the user edits +content. +@deffn Initarg :style +@table @code +@item :auto-hscroll +Specifies that the @code{edit control} will scroll text content to the +right by 10 characters when the user types a character at the end +of the line. +@item :auto-vscroll +Specifies that the @code{edit control} will scroll text up by a page +when the user types @sc{enter} on the last line. This style keyword +is only meaningful when @code{:multi-line} is also specified. +@item :mask-characters +Specifies that each character of text be masked by an echo character +instead of the one literally typed. The character can be changed via +the @ref{echo-character} @sc{setf} method. +@item :multi-line +By default, @code{edit control}s are single-line text fields. By specifying +@code{:multi-line}, multiple lines of text can be supplied. When the +@code{edit control} is in a @ref{dialog}, the @sc{enter} key will invoke +the default @ref{button}'s @ref{event-dispatcher}, unless +@code{:want-return} is also specified. If @code{:auto-hscroll} is not +specified, then text will be automatically word-wrapped. +@item :no-border +By default, an @code{edit control} is rendered with a border; this style +keyword disables that feature. +@item :no-hide-selection +This specifies that any selection remain rendered even when the +@code{edit control} loses input focus. By default, the selection +is hidden when focus is lost. +@item :read-only +Specifies that the @code{edit control}'s contents cannot be modified by +the user. +@item :want-return +Specifies that a carriage return be inserted when the user types +@sc{enter}. This style keyword only applies when the @code{:multi-line} +style is also specified. Without this style, within a dialog the +act of typing @sc{enter} has the same effect as pressing the dialog's +default button. +@end table +@end deffn +@end deftp + @anchor{event-dispatcher} @deftp Class event-dispatcher This is the base class of objects responsible for processing events on @@ -732,6 +781,12 @@ Implement this to respond to a key up event. @end deffn +@anchor{event-modify} +@deffn GenericFunction event-modify dispatcher widget time +Implement this to respond to changes within a @ref{widget}, for example +when the user types text inside an @ref{edit} control. +@end deffn + @deffn GenericFunction event-mouse-double dispatcher widget time point button Implement this to respond to a mouse double-click. @end deffn @@ -883,6 +938,14 @@ from display-relative coordinates to this object's coordinate system. @end deffn +@anchor{echo-character} +@deffn GenericFunction echo-character self => character +Returns the character currently set to be used to mask text content, +such as inside an @ref{edit} control created with the @code{:password} +style keyword, or @sc{nil} if none has been set. The corresponding +@sc{setf} function sets this value. +@end deffn + @anchor{enable} @deffn GenericFunction enable self flag For widgets, this function enables or disables the object, causing it Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Jun 26 18:28:49 2006 @@ -60,6 +60,7 @@ (:file "datastructs") (:file "clib") (:file "comdlg32") + (:file "comctl32") (:file "gdi32") (:file "kernel32") (:file "user32") @@ -98,6 +99,7 @@ (:file "item") (:file "widget") (:file "control") + (:file "edit") (:file "label") (:file "button") (:file "widget-with-items") Added: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/comctl32.lisp Mon Jun 26 18:28:49 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; comctl32.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.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "comctl32.dll") + +(defcfun + ("InitCommonControlsEx" init-common-controls) + BOOL + (init LPTR)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Mon Jun 26 18:28:49 2006 @@ -230,6 +230,21 @@ (defconstant +dt-hideprefix+ #x00100000) (defconstant +dt-prefixonly+ #x00200000) +(defconstant +es-left+ #x0000) +(defconstant +es-center+ #x0001) +(defconstant +es-right+ #x0002) +(defconstant +es-multiline+ #x0004) +(defconstant +es-uppercase+ #x0008) +(defconstant +es-lowercase+ #x0010) +(defconstant +es-password+ #x0020) +(defconstant +es-autovscroll+ #x0040) +(defconstant +es-autohscroll+ #x0080) +(defconstant +es-nohidesel+ #x0100) +(defconstant +es-oemconvert+ #x0400) +(defconstant +es-readonly+ #x0800) +(defconstant +es-wantreturn+ #x1000) +(defconstant +es-number+ #x2000) + (defconstant +eto-opaque+ #x0002) (defconstant +eto-clipped+ #x0004) (defconstant +eto-glyph-index+ #x0010) @@ -303,6 +318,24 @@ (defconstant +hs-cross+ 4) (defconstant +hs-diagcross+ 5) +(defconstant +icc-listview-classes+ #x00000001) +(defconstant +icc-treeview-classes+ #x00000002) +(defconstant +icc-bar-classes+ #x00000004) +(defconstant +icc-tab-classes+ #x00000008) +(defconstant +icc-updown-class+ #x00000010) +(defconstant +icc-progress-class+ #x00000020) +(defconstant +icc-hotkey-class+ #x00000040) +(defconstant +icc-animate-class+ #x00000080) +(defconstant +icc-win95-classes+ #x000000FF) +(defconstant +icc-date-classes+ #x00000100) +(defconstant +icc-userex-classes+ #x00000200) +(defconstant +icc-cool-classes+ #x00000400) +(defconstant +icc-internet-classes+ #x00000800) +(defconstant +icc-pagescroller-class+ #x00001000) +(defconstant +icc-nativefntctl-class+ #x00002000) +(defconstant +icc-standard-classes+ #x00004000) +(defconstant +icc-link-class+ #x00008000) + (defconstant +idok+ 1) (defconstant +idcancel+ 2) (defconstant +idabort+ 3) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Jun 26 18:28:49 2006 @@ -121,6 +121,10 @@ (rightmargin INT) (lengthdrawn UINT)) +(defcstruct initcommoncontrolsex + (size DWORD) + (icc DWORD)) + (defcstruct logbrush (style UINT) (color COLORREF) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Mon Jun 26 18:28:49 2006 @@ -42,9 +42,9 @@ (defmethod compute-style-flags ((btn button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (let ((std-flags +default-child-style+) (style (style-of btn))) - (loop for sym in (style-of btn) + (loop for sym in style do (cond ;; primary button styles ;; Added: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/edit.lisp Mon Jun 26 18:28:49 2006 @@ -0,0 +1,62 @@ +;;;; +;;;; edit.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self edit) &rest extra-data) + (declare (ignore extra-data)) + (let ((border-flag (if (find :no-border (style-of self)) 0 gfs::+ws-border+))) + (values (loop for sym in (style-of self) + for std-flags = (logior +default-child-style+ border-flag) + then (logior std-flags + (ecase sym + ;; primary edit styles + ;; + (:multi-line (logior +default-child-style+ + gfs::+es-multiline+ + border-flag)) + + ;; styles that can be combined + ;; + (:auto-hscroll gfs::+es-autohscroll+) + (:auto-vscroll gfs::+es-autovscroll+) + (:mask-characters gfs::+es-password+) + (:no-hide-selection gfs::+es-nohidesel+) + (:read-only gfs::+es-readonly+) + (:want-return gfs::+es-wantreturn+))) + finally (return std-flags)) + 0))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Jun 26 18:28:49 2006 @@ -94,8 +94,7 @@ (defmethod compute-style-flags ((label label) &rest extra-data) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) - (let ((std-style (logior gfs::+ws-child+ - gfs::+ws-visible+ + (let ((std-style (logior +default-child-style+ (cond ((first extra-data) (compute-image-style-flags (style-of label))) @@ -126,8 +125,7 @@ gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+ - gfs::+ws-child+ - gfs::+ws-visible+)) + +default-child-style+)) (tr-pnt (gfg:transparency-pixel-of image))) (if tr-pnt (let* ((color (gfg:background-color label)) @@ -206,8 +204,7 @@ (declare (ignore ex-flags)) (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags std-flags - gfs::+ws-child+ - gfs::+ws-visible+)))) + +default-child-style+)))) (set-widget-text self str)) (defmethod text-baseline ((self label)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Mon Jun 26 18:28:49 2006 @@ -55,7 +55,7 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) + (let ((std-flags +default-child-style+)) (mapc #'(lambda (sym) (cond ;; styles that can be combined Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Jun 26 18:28:49 2006 @@ -118,6 +118,9 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) +(defclass edit (control) () + (:documentation "This class represents a control in which the user may enter and edit text.")) + (defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image.")) Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Mon Jun 26 18:28:49 2006 @@ -33,63 +33,66 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +vk-break+ #x03) -(defconstant +vk-backspace+ #x08) -(defconstant +vk-tab+ #x09) -(defconstant +vk-clear+ #x0C) ; numpad-5 when numlock off -(defconstant +vk-return+ #x0D) -(defconstant +vk-shift+ #x10) -(defconstant +vk-control+ #x11) -(defconstant +vk-alt+ #x12) -(defconstant +vk-pause+ #x13) -(defconstant +vk-caps-lock+ #x14) -(defconstant +vk-escape+ #x1B) -(defconstant +vk-page-up+ #x21) -(defconstant +vk-page-down+ #x22) -(defconstant +vk-end+ #x23) -(defconstant +vk-home+ #x24) -(defconstant +vk-left+ #x25) -(defconstant +vk-up+ #x26) -(defconstant +vk-right+ #x27) -(defconstant +vk-down+ #x28) -(defconstant +vk-insert+ #x2D) -(defconstant +vk-delete+ #x2E) -(defconstant +vk-help+ #x2F) -(defconstant +vk-left-win+ #x5B) -(defconstant +vk-right-win+ #x5C) -(defconstant +vk-applications+ #x5D) -(defconstant +vk-numpad-0+ #x60) -(defconstant +vk-numpad-1+ #x61) -(defconstant +vk-numpad-2+ #x62) -(defconstant +vk-numpad-3+ #x63) -(defconstant +vk-numpad-4+ #x64) -(defconstant +vk-numpad-5+ #x65) -(defconstant +vk-numpad-6+ #x66) -(defconstant +vk-numpad-7+ #x67) -(defconstant +vk-numpad-8+ #x68) -(defconstant +vk-numpad-9+ #x69) -(defconstant +vk-numpad-*+ #x6A) -(defconstant +vk-numpad-++ #x6B) -(defconstant +vk-numpad--+ #x6D) -(defconstant +vk-numpad-.+ #x6E) -(defconstant +vk-numpad-/+ #x6F) -(defconstant +vk-numpad-f1+ #x70) -(defconstant +vk-numpad-f2+ #x71) -(defconstant +vk-numpad-f3+ #x72) -(defconstant +vk-numpad-f4+ #x73) -(defconstant +vk-numpad-f5+ #x74) -(defconstant +vk-numpad-f6+ #x75) -(defconstant +vk-numpad-f7+ #x76) -(defconstant +vk-numpad-f8+ #x77) -(defconstant +vk-numpad-f9+ #x78) -(defconstant +vk-numpad-f10+ #x79) -(defconstant +vk-numpad-f11+ #x7A) -(defconstant +vk-numpad-f12+ #x7B) -(defconstant +vk-num-lock+ #x90) -(defconstant +vk-scroll-lock+ #x91) -(defconstant +vk-left-shift+ #xA0) -(defconstant +vk-right-shift+ #xA1) -(defconstant +vk-left-control+ #xA2) -(defconstant +vk-right-control+ #xA3) -(defconstant +vk-left-alt+ #xA4) -(defconstant +vk-right-alt+ #xA5) +(defconstant +vk-break+ #x03) +(defconstant +vk-backspace+ #x08) +(defconstant +vk-tab+ #x09) +(defconstant +vk-clear+ #x0C) ; numpad-5 when numlock off +(defconstant +vk-return+ #x0D) +(defconstant +vk-shift+ #x10) +(defconstant +vk-control+ #x11) +(defconstant +vk-alt+ #x12) +(defconstant +vk-pause+ #x13) +(defconstant +vk-caps-lock+ #x14) +(defconstant +vk-escape+ #x1B) +(defconstant +vk-page-up+ #x21) +(defconstant +vk-page-down+ #x22) +(defconstant +vk-end+ #x23) +(defconstant +vk-home+ #x24) +(defconstant +vk-left+ #x25) +(defconstant +vk-up+ #x26) +(defconstant +vk-right+ #x27) +(defconstant +vk-down+ #x28) +(defconstant +vk-insert+ #x2D) +(defconstant +vk-delete+ #x2E) +(defconstant +vk-help+ #x2F) +(defconstant +vk-left-win+ #x5B) +(defconstant +vk-right-win+ #x5C) +(defconstant +vk-applications+ #x5D) +(defconstant +vk-numpad-0+ #x60) +(defconstant +vk-numpad-1+ #x61) +(defconstant +vk-numpad-2+ #x62) +(defconstant +vk-numpad-3+ #x63) +(defconstant +vk-numpad-4+ #x64) +(defconstant +vk-numpad-5+ #x65) +(defconstant +vk-numpad-6+ #x66) +(defconstant +vk-numpad-7+ #x67) +(defconstant +vk-numpad-8+ #x68) +(defconstant +vk-numpad-9+ #x69) +(defconstant +vk-numpad-*+ #x6A) +(defconstant +vk-numpad-++ #x6B) +(defconstant +vk-numpad--+ #x6D) +(defconstant +vk-numpad-.+ #x6E) +(defconstant +vk-numpad-/+ #x6F) +(defconstant +vk-numpad-f1+ #x70) +(defconstant +vk-numpad-f2+ #x71) +(defconstant +vk-numpad-f3+ #x72) +(defconstant +vk-numpad-f4+ #x73) +(defconstant +vk-numpad-f5+ #x74) +(defconstant +vk-numpad-f6+ #x75) +(defconstant +vk-numpad-f7+ #x76) +(defconstant +vk-numpad-f8+ #x77) +(defconstant +vk-numpad-f9+ #x78) +(defconstant +vk-numpad-f10+ #x79) +(defconstant +vk-numpad-f11+ #x7A) +(defconstant +vk-numpad-f12+ #x7B) +(defconstant +vk-num-lock+ #x90) +(defconstant +vk-scroll-lock+ #x91) +(defconstant +vk-left-shift+ #xA0) +(defconstant +vk-right-shift+ #xA1) +(defconstant +vk-left-control+ #xA2) +(defconstant +vk-right-control+ #xA3) +(defconstant +vk-left-alt+ #xA4) +(defconstant +vk-right-alt+ #xA5) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+))) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Jun 26 18:28:49 2006 @@ -129,7 +129,7 @@ (defgeneric display-to-object (self pnt) (:documentation "Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system.")) -(defgeneric echo-char (self) +(defgeneric echo-character (self) (:documentation "Returns the character that will be displayed when the user types text, or nil if no echo character has been set.")) (defgeneric enable (self flag)

1 0

[graphic-forms-cvs] r162 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Jun '06

26 Jun '06

Author: junrue Date: Mon Jun 26 08:30:24 2006 New Revision: 162 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented and documented capture-mouse/release-mouse functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 26 08:30:24 2006 @@ -813,6 +813,17 @@ widget must be a @ref{button} and is typically labelled @emph{Cancel}. @end deffn +@anchor{capture-mouse} +@deffn Function capture-mouse self +Enables the @ref{window} identified by @code{self} to receive mouse +input events even when the mouse pointer is outside of the bounds +of @code{self}. Only one window at a time can capture the mouse. This +function is primarily intended for use with a window in the foreground; +background windows may still capture the mouse, but only mouse move +events will be received and those only when the mouse hotspot is within +the visible portions of such a window. @xref{release-mouse}. +@end deffn + @anchor{center-on-owner} @deffn GenericFunction center-on-owner self Position @code{self} such that it is centrally located relative to its @@ -1031,6 +1042,12 @@ Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn +@anchor{release-mouse} +@deffn Function release-mouse +Clears the mouse capture state to restore normal mouse input processing. +@xref{capture-mouse}. +@end deffn + @anchor{show} @deffn GenericFunction show self flag Causes the object to be visible or hidden on the screen, but not Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Mon Jun 26 08:30:24 2006 @@ -110,19 +110,19 @@ (if (and (eql button :left-button) (> tile-kind 0)) (shape-tiles tiles tile-pnt tmp-table)) (when (> (hash-table-count tmp-table) 1) + (gfw:capture-mouse panel) (setf (shape-kind-of self) tile-kind) (setf (shape-pnts-of self) (shape-tile-points tmp-table)) (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) + (gfw:release-mouse) (let ((tile-pnt (window->tiles point)) (shape-pnts (shape-pnts-of self))) - (if (and (eql button :left-button) - shape-pnts - (find tile-pnt shape-pnts :test #'eql-point)) - (game-shape-data shape-pnts) - (if shape-pnts + (when (and (eql button :left-button) shape-pnts) + (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point)) + (game-shape-data shape-pnts) (draw-tiles-directly panel shape-pnts (shape-kind-of self))))) (setf (shape-kind-of self) 0) (setf (shape-pnts-of self) nil)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jun 26 08:30:24 2006 @@ -318,6 +318,7 @@ #:background-pattern #:border-width #:bottom-margin-of + #:capture-mouse #:caret #:center-on-owner #:center-on-parent @@ -441,6 +442,7 @@ #:primary-p #:redraw #:redrawing-p + #:release-mouse #:remove-all #:remove-item #:remove-span Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Jun 26 08:30:24 2006 @@ -141,6 +141,16 @@ retval (error 'gfs::win32-error :detail "register-class failed"))))))) +(defun capture-mouse (self) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (typep self 'window) + (error 'gfs:toolkit-error :detail "capture-mouse is restricted to window subclasses")) + (gfs::set-capture (gfs:handle self))) + +(defun release-mouse () + (gfs::release-capture)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-children ((win var) &body body) (let ((hwnd (gensym)))

1 0

[graphic-forms-cvs] r161 - in trunk: docs/manual src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Jun '06

26 Jun '06

Author: junrue Date: Mon Jun 26 00:25:52 2006 New Revision: 161 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/label.lisp Log: corrected an early mistake whereby rectangle should have been a structure originally Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Jun 26 00:25:52 2006 @@ -81,8 +81,6 @@ foreign pointer but should be treated as an opaque cookie. @deffn Initarg :handle @end deffn -@deffn Reader handle -@end deffn @end deftp @anchor{point} @@ -91,18 +89,10 @@ @end deftp @anchor{rectangle} -@deftp Class rectangle location size -This class identifies a region in the Cartesian coordinate system -consisting of an upper-left coordinate and bounds. See @ref{point} and +@deftp Structure rectangle location size +This structure identifies a region in the Cartesian coordinate system +consisting of an upper-left coordinate and size. See @ref{point} and @ref{size}. -@deffn Initarg :location -@end deffn -@deffn Initarg :size -@end deffn -@deffn Accessor location -@end deffn -@deffn Accessor size -@end deffn @end deftp @anchor{size} @@ -112,7 +102,7 @@ @anchor{span} @deftp Structure span start end -This structure represents a range of values or times in a collection. +This structure represents a range of values. @end deftp @@ -132,10 +122,18 @@ but secondary initialization code has not yet executed. @end deffn +@deffn Macro location rect +This macro returns the @code{location} slot of a @ref{rectangle}. +@end deffn + @deffn Function make-point :x :y :z This function creates a new @ref{point} object. @end deffn +@deffn Function make-rectangle :location :size +This function creates a new @ref{rectangle} object. +@end deffn + @deffn Function make-size :width :height :depth This function creates a new @ref{size} object. @end deffn @@ -144,6 +142,10 @@ This function creates a new @ref{span} object. @end deffn +@deffn Macro size rect +This macro returns the @code{size} slot of a @ref{rectangle}. +@end deffn + @node system conditions @section system conditions Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Mon Jun 26 00:25:52 2006 @@ -49,7 +49,7 @@ (let ((image (image-buffer-of self))) (setf (gfg:background-color gc) *background-color*) (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfg:size image))))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfg:size image))))) (defmethod dispose ((self double-buffered-event-dispatcher)) (let ((image (image-buffer-of self))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jun 26 00:25:52 2006 @@ -69,6 +69,7 @@ #:handle #:location #:make-point + #:make-rectangle #:make-size #:make-span #:null-handle-p Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Jun 26 00:25:52 2006 @@ -69,7 +69,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) @@ -145,7 +145,7 @@ (defun draw-arcs (gc) (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (start-pnt (gfs:make-point :x 15 :y 60)) (end-pnt (gfs:make-point :x 75 :y 25)) (delta-x (+ (gfs:size-width rect-size) 10)) @@ -154,12 +154,12 @@ (incf (gfs:point-y rect-pnt) delta-y) (incf (gfs:point-y start-pnt) delta-y) (incf (gfs:point-y end-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-chord nil) (incf (gfs:point-y rect-pnt) delta-y) (incf (gfs:point-y start-pnt) delta-y) (incf (gfs:point-y end-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil))) (defun select-arcs (disp item time rect) @@ -194,12 +194,12 @@ (defun draw-ellipses (gc) (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (delta-x (+ (gfs:size-width rect-size) 10)) (delta-y (+ (gfs:size-height rect-size) 10))) (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-ellipse t) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) (defun select-ellipses (disp item time rect) @@ -249,19 +249,19 @@ (defun draw-rects (gc) (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 50)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (delta-x (+ (gfs:size-width rect-size) 10)) (delta-y (+ (gfs:size-height rect-size) 10)) (arc-size (gfs:make-size :width 10 :height 10))) (draw-rectangular gc rect arc-size delta-x #'gfg:draw-filled-rounded-rectangle t) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-rectangle t) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect arc-size delta-x #'gfg:draw-rounded-rectangle nil) (incf (gfs:point-y rect-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) (defun select-rects (disp item time rect) @@ -323,7 +323,7 @@ (defun draw-wedges (gc) (let* ((rect-pnt (gfs:make-point :x 5 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) - (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (delta-x (+ (gfs:size-width rect-size) 10)) (delta-y (gfs:size-height rect-size)) (start-pnt (gfs:make-point :x 35 :y 75)) @@ -333,7 +333,7 @@ (incf (gfs:point-y rect-pnt) delta-y) (incf (gfs:point-y start-pnt) delta-y) (incf (gfs:point-y end-pnt) delta-y) - (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size)) (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil))) (defun select-wedges (disp item time rect) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Jun 26 00:25:52 2006 @@ -51,7 +51,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Jun 26 00:25:52 2006 @@ -74,7 +74,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defclass test-panel (gfw:panel) ()) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Jun 26 00:25:52 2006 @@ -53,7 +53,7 @@ (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:client-size window)))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) (defclass test-mini-events (test-win-events) ()) @@ -129,7 +129,7 @@ (let ((parent (gfw:parent panel))) (setf (gfg:background-color gc) (gfg:background-color parent)) (setf (gfg:foreground-color gc) (gfg:background-color parent)) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:size panel))))) (defclass dialog-events (gfw:event-dispatcher) ()) Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Jun 26 00:25:52 2006 @@ -37,19 +37,12 @@ (defstruct size (width 0) (height 0) (depth 0)) +(defstruct rectangle (location (make-point)) (size (make-size))) + (defstruct span (start 0) (end 0)) -(defclass rectangle () - ((location - :accessor location - :initarg :location - :initform (make-point)) - (size - :accessor size - :initarg :size - :initform (make-size))) - (:documentation "Describes the perimeter of a rectangular region in a given coordinate system.")) +(defmacro location (rect) + `(rectangle-location ,rect)) -(defmethod print-object ((obj rectangle) stream) - (print-unreadable-object (obj stream :type t) - (format stream "location: ~a size: ~a" (location obj) (size obj)))) +(defmacro size (rect) + `(rectangle-size ,rect)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Jun 26 00:25:52 2006 @@ -152,7 +152,7 @@ (event-select (dispatcher item) item (event-time tc) - (make-instance 'gfs:rectangle)))))) ; FIXME + (gfs:make-rectangle)))))) ; FIXME ((eq wparam-hi 1) (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug (t @@ -163,7 +163,7 @@ (event-select (dispatcher w) w (event-time tc) - (make-instance 'gfs:rectangle))))))) ; FIXME + (gfs:make-rectangle))))))) ; FIXME (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0) @@ -286,7 +286,7 @@ (let* ((tc (thread-context)) (widget (get-widget tc hwnd))) (if widget - (let ((rct (make-instance 'gfs:rectangle))) + (let ((rct (gfs:make-rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) (cffi:with-foreign-slots ((gfs::rcpaint-x gfs::rcpaint-y Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Jun 26 00:25:52 2006 @@ -141,7 +141,7 @@ (gfs:point-y pnt) (flow-data-wrap-coord state))) (incf (flow-data-next-coord state) (+ (funcall (flow-data-distance-fn state) kid-size) (flow-data-spacing state))) - (cons kid (make-instance 'gfs:rectangle :size kid-size :location pnt)))) + (cons kid (gfs:make-rectangle :size kid-size :location pnt)))) (defun flow-container-layout (layout visible kids width-hint height-hint) (let ((flows nil) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Mon Jun 26 00:25:52 2006 @@ -63,7 +63,7 @@ (gfs:size-height size)) vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) - (bounds (make-instance 'gfs:rectangle :size new-size :location new-pnt))) + (bounds (gfs:make-rectangle :size new-size :location new-pnt))) (with-children (win kids) (loop for kid in kids collect (cons kid bounds))))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Jun 26 00:25:52 2006 @@ -132,7 +132,7 @@ (if tr-pnt (let* ((color (gfg:background-color label)) (size (gfg:size image)) - (bounds (make-instance 'gfs:rectangle :size size)) + (bounds (gfs:make-rectangle :size size)) (tmp-image (make-instance 'gfg:image :size size)) (gc (make-instance 'gfg:graphics-context :image tmp-image))) (unwind-protect

1 0

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

26 Jun '06

Author: junrue Date: Sun Jun 25 19:31:00 2006 New Revision: 160 Modified: trunk/src/demos/unblocked/unblocked-model.lisp Log: fixed a glitch in usage of loop that manifested itself under LW Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sun Jun 25 19:31:00 2006 @@ -44,8 +44,8 @@ (defun lookup-level-reached (score) (loop for entry in *points-needed-table* - until (> entry score) for level from 1 + until (> entry score) finally (return level))) (defun revise-tiles (active-tiles orig-tiles shape-data)

1 0

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

26 Jun '06

Author: junrue Date: Sun Jun 25 19:22:52 2006 New Revision: 159 Modified: trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/tiles.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: implemented reveal-unblocked Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Jun 25 19:22:52 2006 @@ -110,13 +110,9 @@ (if (and (eql button :left-button) (> tile-kind 0)) (shape-tiles tiles tile-pnt tmp-table)) (when (> (hash-table-count tmp-table) 1) - (maphash #'(lambda (pnt kind) - (declare (ignore kind)) - (push pnt shape-pnts)) - tmp-table) (setf (shape-kind-of self) tile-kind) - (setf (shape-pnts-of self) shape-pnts) - (draw-tiles-directly panel shape-pnts +max-tile-kinds+)))) + (setf (shape-pnts-of self) (shape-tile-points tmp-table)) + (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+)))) (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button) (declare (ignore time)) Modified: trunk/src/demos/unblocked/tiles.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles.lisp (original) +++ trunk/src/demos/unblocked/tiles.lisp Sun Jun 25 19:22:52 2006 @@ -110,6 +110,28 @@ when (= kind (obtain-tile tiles pnt2)) do (shape-tiles tiles pnt2 results))))) +(defun shape-tile-points (shape) + (let ((shape-pnts nil)) + (maphash (lambda (pnt kind) + (declare (ignore kind)) + (push pnt shape-pnts)) + shape) + shape-pnts)) + +(defun shape-size (shape) + (hash-table-count shape)) + +(defun shape-kind (shape) + (if (null shape) + (return-from shape-kind 0)) + (let ((kind nil)) + (maphash (lambda (pnt k) + (declare (ignore pnt)) + (if (null kind) + (setf kind k))) + shape) + kind)) + (defun collapse-column (column-tiles) (let ((new-column (make-array (length column-tiles) :initial-element 0)) (new-index 0) @@ -133,3 +155,37 @@ (dotimes (i width) (setf (aref new-tiles i) (copy-seq (aref orig-tiles i)))) new-tiles)) + +(defun find-shape (tiles accept-p) + (if (null *unblocked-random-state*) + (setf *unblocked-random-state* (make-random-state))) + (let ((*random-state* *unblocked-random-state*) + (candidate-shapes nil)) + (dotimes (col-index (length tiles)) + (let ((column-tiles (aref tiles col-index))) + (dotimes (tile-index (length column-tiles)) + (let ((shape (make-hash-table :test #'equalp))) + (shape-tiles tiles (gfs:make-point :x col-index :y tile-index) shape) + (if (funcall accept-p shape) + (push shape candidate-shapes)))))) + (unless candidate-shapes + (return-from find-shape nil)) + (elt candidate-shapes (random (length candidate-shapes))))) + +#| +(defun find-shape (tiles accept-p) + (if (null *unblocked-random-state*) + (setf *unblocked-random-state* (make-random-state))) + (let ((*random-state* *unblocked-random-state*) + (shape nil)) + (loop for col-index = (random (length tiles)) + for column-tiles = (aref tiles col-index) + for tile-index = (random (length column-tiles)) + for tmp-shape = (make-hash-table :test #'equalp) + until shape + do (progn + (shape-tiles tiles (gfs:make-point :x col-index :y tile-index) tmp-shape) + (if (and (> (shape-size tmp-shape) 1) (funcall accept-p tmp-shape)) + (setf shape tmp-shape)))) + shape)) +|# \ No newline at end of file Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Jun 25 19:22:52 2006 @@ -33,8 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +spacing+ 4) -(defconstant +margin+ 4) +(defconstant +spacing+ 4) +(defconstant +margin+ 4) + +(defconstant +revealed-duration+ 2000) ; millis (defvar *scoreboard-panel* nil) (defvar *unblocked-startup-dir* nil) @@ -62,8 +64,21 @@ (update-panel *scoreboard-panel*) (update-panel *tiles-panel*)) +(defun accept-shape-p (shape) + (let ((size (shape-size shape)) + (kind (shape-kind shape))) + (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+)))) + (defun reveal-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (let ((shape (find-shape (game-tiles) #'accept-shape-p))) + (when shape + (let ((shape-pnts (shape-tile-points shape)) + (timer (make-instance 'gfw:timer :initial-delay +revealed-duration+ + :delay 0 + :dispatcher (gfw:dispatcher *unblocked-win*)))) + (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+) + (gfw:enable timer t))))) (defun quit-unblocked (disp item time rect) (declare (ignore disp item time rect)) @@ -79,6 +94,10 @@ (declare (ignore window time)) (quit-unblocked disp nil nil nil)) +(defmethod gfw:event-timer ((disp unblocked-win-events) timer time) + (declare (ignore timer time)) + (update-panel *tiles-panel*)) + (defclass unblocked-about-dialog-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time)

1 0

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

25 Jun '06

Author: junrue Date: Sat Jun 24 21:46:36 2006 New Revision: 158 Modified: trunk/src/demos/unblocked/unblocked-model.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: implemented game restart in UnBlocked Modified: trunk/src/demos/unblocked/unblocked-model.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-model.lisp (original) +++ trunk/src/demos/unblocked/unblocked-model.lisp Sat Jun 24 21:46:36 2006 @@ -48,6 +48,13 @@ for level from 1 finally (return level))) +(defun revise-tiles (active-tiles orig-tiles shape-data) + (if shape-data + (loop with tmp = (clone-tiles active-tiles) + for pnt in shape-data do (set-tile tmp pnt 0) + finally (return (collapse-tiles tmp))) + orig-tiles)) + (cells:defmodel unblocked-game-model () ((level :accessor level @@ -59,29 +66,29 @@ (shape-data :accessor shape-data :initform (cells:c-in nil)) - (tiles - :accessor tiles - :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 - (loop with tmp = (clone-tiles cells:.cache) - for pnt in data do (set-tile tmp pnt 0) - finally (return (collapse-tiles tmp)))) - (t - cells:.cache))))))) + (original-tiles + :accessor original-tiles + :initarg :original-tiles + :initform (cells:c-in (collapse-tiles (init-tiles +horz-tile-count+ + +vert-tile-count+ + (1- +max-tile-kinds+))))) + (active-tiles + :accessor active-tiles + :initform (cells:c? (revise-tiles cells:.cache (^original-tiles) (^shape-data)))))) (defvar *game* (make-instance 'unblocked-game-model)) -(defun reset-game () +(defun new-game () (cells:cells-reset) (setf *game* (make-instance 'unblocked-game-model))) +(defun restart-game () + (let ((saved-tiles (original-tiles *game*))) + (cells:cells-reset) + (setf *game* (make-instance 'unblocked-game-model :original-tiles saved-tiles)))) + (defun game-tiles () - (tiles *game*)) + (active-tiles *game*)) (defun game-shape-data (pnts) (setf (shape-data *game*) pnts)) @@ -102,5 +109,5 @@ (cells:defobserver score ((self unblocked-game-model)) (update-panel (get-scoreboard-panel))) -(cells:defobserver tiles ((self unblocked-game-model)) +(cells:defobserver active-tiles ((self unblocked-game-model)) (update-panel (get-tiles-panel))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sat Jun 24 21:46:36 2006 @@ -52,16 +52,15 @@ (defun new-unblocked (disp item time rect) (declare (ignore disp item time rect)) - (reset-game) - (let ((tiles-disp (gfw:dispatcher *tiles-panel*)) - (scoreboard-disp (gfw:dispatcher *scoreboard-panel*))) - (update-buffer scoreboard-disp) - (update-buffer tiles-disp) - (gfw:redraw *scoreboard-panel*) - (gfw:redraw *tiles-panel*))) + (new-game) + (update-panel *scoreboard-panel*) + (update-panel *tiles-panel*)) (defun restart-unblocked (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (restart-game) + (update-panel *scoreboard-panel*) + (update-panel *tiles-panel*)) (defun reveal-unblocked (disp item time rect) (declare (ignore disp item time rect)))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

graphic-forms-cvs June 2006