graphic-forms-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
June 2006
- 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
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
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
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
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 26 Jun '06
by junrue@common-lisp.net 26 Jun '06
26 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
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
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

25 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

25 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

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