[graphic-forms-cvs] r44 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Mar 16 01:24:53 UTC 2006
Author: junrue
Date: Wed Mar 15 20:24:52 2006
New Revision: 44
Added:
trunk/src/tests/uitoolkit/windlg.lisp
Modified:
trunk/graphic-forms-tests.asd
trunk/src/tests/uitoolkit/hello-world.lisp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
implemented thread context cleanup; implemented +style-popup+ window style; implemented draw-filled-rectangle method
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Wed Mar 15 20:24:52 2006
@@ -53,4 +53,5 @@
(:file "layout-unit-tests")
(:file "hello-world")
(:file "event-tester")
- (:file "layout-tester")))))))))
+ (:file "layout-tester")
+ (:file "windlg")))))))))
Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp (original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Mar 15 20:24:52 2006
@@ -33,38 +33,35 @@
(in-package #:graphic-forms.uitoolkit.tests)
-(defparameter *hellowin* nil)
-
-(defun exit-hello-world ()
- (let ((w *hellowin*))
- (setf *hellowin* nil)
- (gfi:dispose w))
- (gfw:shutdown 0))
-
(defclass hellowin-events (gfw:event-dispatcher) ())
(defmethod gfw:event-close ((d hellowin-events) widget time)
(declare (ignore widget time))
- (exit-hello-world))
+ (gfw:shutdown 0))
(defmethod gfw:event-paint ((d hellowin-events) window time gc rect)
- (declare (ignorable window time rect))
+ (declare (ignore window time rect))
+ (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point)
+ :size (gfw:client-size window)))
+ (setf (gfg:background-color gc) gfg:+color-white+)
+ (gfg:draw-filled-rectangle gc rect)
(setf (gfg:background-color gc) gfg:+color-red+)
(setf (gfg:foreground-color gc) gfg:+color-green+)
(gfg:draw-text gc "Hello World!" (gfi:make-point)))
(defun exit-fn (disp item time rect)
(declare (ignorable disp item time rect))
- (exit-hello-world))
+ (gfw:shutdown 0))
(defun run-hello-world-internal ()
- (let ((menubar nil))
- (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events)))
- (gfw:realize *hellowin* nil :style-workspace)
+ (let ((menubar nil)
+ (window nil))
+ (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events)))
+ (gfw:realize window nil :style-workspace)
(setf menubar (gfw:defmenusystem ((:item "&File"
:submenu ((:item "E&xit" :callback #'exit-fn))))))
- (setf (gfw:menu-bar *hellowin*) menubar)
- (gfw:show *hellowin* t)))
+ (setf (gfw:menu-bar window) menubar)
+ (gfw:show window t)))
(defun run-hello-world ()
(gfw:startup "Hello World" #'run-hello-world-internal))
Added: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/windlg.lisp Wed Mar 15 20:24:52 2006
@@ -0,0 +1,88 @@
+;;;;
+;;;; windlg.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package #:graphic-forms.uitoolkit.tests)
+
+(defclass main-win-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((d main-win-events) window time)
+ (declare (ignore time))
+ (gfi:dispose window)
+ (gfw:shutdown 0))
+
+(defclass test-win-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((d test-win-events) window time)
+ (declare (ignore time))
+ (gfi:dispose window))
+
+(defmethod gfw:event-paint ((d test-win-events) window time gc rect)
+ (declare (ignore time))
+ (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point)
+ :size (gfw:client-size window)))
+ (setf (gfg:background-color gc) gfg:+color-white+)
+ (gfg:draw-filled-rectangle gc rect))
+
+(defun create-borderless-win ())
+
+(defun create-miniframe-win ())
+
+(defun create-popup-win (disp item time rect)
+ (declare (ignore disp item time rect))
+ (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events))))
+ (gfw:realize window nil :style-popup)
+ (setf (gfw:location window) (gfi:make-point :x 250 :y 150))
+ (setf (gfw:size window) (gfi:make-size :width 75 :height 125))
+ (setf (gfw:text window) "Popup")
+ (gfw:show window t)))
+
+(defun exit-callback (disp item time rect)
+ (declare (ignore disp item time rect))
+ (gfw:shutdown 0))
+
+(defun run-windlg-internal ()
+ (let ((menubar nil)
+ (window nil))
+ (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events)))
+ (gfw:realize window nil :style-workspace)
+ (setf menubar (gfw:defmenusystem ((:item "&File"
+ :submenu ((:item "E&xit" :callback #'exit-callback)))
+ (:item "&Windows"
+ :submenu ((:item "&Borderless" :callback #'create-borderless-win)
+ (:item "&Mini Frame" :callback #'create-miniframe-win)
+ (:item "&Popup" :callback #'create-popup-win))))))
+ (setf (gfw:menu-bar window) menubar)
+ (gfw:show window t)))
+
+(defun run-windlg ()
+ (gfw:startup "Window/Dialog Tester" #'run-windlg-internal))
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Mar 15 20:24:52 2006
@@ -60,6 +60,28 @@
(gfs::set-dc-brush-color hdc rgb)
(gfs::set-bk-color hdc rgb)))
+(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfi:rectangle))
+ (if (gfi:disposed-p gc)
+ (error 'gfi:disposed-error))
+ (let ((hdc (gfi:handle gc))
+ (pnt (gfi:location rect))
+ (size (gfi:size rect)))
+ (cffi:with-foreign-object (rect-ptr 'gfs::rect)
+ (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
+ rect-ptr gfs::rect)
+ (setf gfs::top (gfi:point-y pnt))
+ (setf gfs::left (gfi:point-x pnt))
+ (setf gfs::bottom (+ (gfi:point-y pnt) (gfi:size-height size)))
+ (setf gfs::right (+ (gfi:point-x pnt) (gfi:size-width size)))
+ (gfs::ext-text-out hdc
+ (gfi:point-x pnt)
+ (gfi:point-y pnt)
+ gfs::+eto-opaque+
+ rect-ptr
+ ""
+ 0
+ (cffi:null-pointer))))))
+
(defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point))
(if (gfi:disposed-p gc)
(error 'gfi:disposed-error))
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Wed Mar 15 20:24:52 2006
@@ -93,6 +93,18 @@
(params LPTR))
(defcfun
+ ("ExtTextOutA" ext-text-out)
+ BOOL
+ (hdc HANDLE)
+ (x INT)
+ (y INT)
+ (options UINT)
+ (rect LPRECT)
+ (str :string)
+ (count UINT)
+ (dx LPTR))
+
+(defcfun
("GetBkColor" get-bk-color)
COLORREF
(hdc HANDLE))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Wed Mar 15 20:24:52 2006
@@ -173,6 +173,15 @@
(defconstant +dt-hideprefix+ #x00100000)
(defconstant +dt-prefixonly+ #x00200000)
+(defconstant +eto-opaque+ #x0002)
+(defconstant +eto-clipped+ #x0004)
+(defconstant +eto-glyph_index+ #x0010)
+(defconstant +eto-rtlreading+ #x0080)
+(defconstant +eto-numericslocal+ #x0400)
+(defconstant +eto-numericslatin+ #x0800)
+(defconstant +eto-ignorelanguage+ #x1000)
+(defconstant +eto-pdy+ #x2000)
+
(defconstant +ga-parent+ 1)
(defconstant +ga-root+ 2)
(defconstant +ga-rootowner+ 3)
@@ -634,6 +643,7 @@
(defconstant +ws-minimizebox+ #x00020000)
(defconstant +ws-maximizebox+ #x00010000)
(defconstant +ws-popupwindow+ #x80880000)
+(defconstant +ws-overlappedwindow+ #x00CF0000)
(defconstant +ws-ex-dlgmodalframe+ #x00000001)
(defconstant +ws-ex-noparentnotify+ #x00000004)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Mar 15 20:24:52 2006
@@ -56,6 +56,9 @@
#+clisp (defun thread-context ()
*the-thread-context*)
+#+clisp (defun dispose-thread-context ()
+ (setf *the-thread-context* nil))
+
#+lispworks (defun thread-context ()
(let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context)))
(when (null tc)
@@ -63,6 +66,9 @@
(setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc))
tc))
+#+lispworks (defun dispose-thread-context ()
+ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil))
+
(defmethod call-child-visitor-func ((tc thread-context) parent child)
"Call the closure at the top of the child window visitor function stack."
(let ((fn (first (slot-value tc 'child-visitor-stack))))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 15 20:24:52 2006
@@ -49,7 +49,8 @@
(run-default-message-loop)))))
(defun shutdown (exit-code)
- (gfs::post-quit-message exit-code))
+ (gfs::post-quit-message exit-code)
+ (dispose-thread-context))
(defun clear-all (w)
(let ((count (gfw:item-count w)))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Wed Mar 15 20:24:52 2006
@@ -154,53 +154,50 @@
(declare (ignore win))
(let ((std-flags 0)
(ex-flags 0))
- (mapcar #'(lambda (sym)
- (cond
- ;; styles that can be combined
- ;;
- ((eq sym :style-hscroll)
- (setf std-flags (logior std-flags gfs::+ws-hscroll+)))
- ((eq sym :style-max)
- (setf std-flags (logior std-flags gfs::+ws-maximizebox+)))
- ((eq sym :style-min)
- (setf std-flags (logior std-flags gfs::+ws-minimizebox+)))
- ((eq sym :style-resize)
- (setf std-flags (logior std-flags gfs::+ws-thickframe+)))
- ((eq sym :style-sysmenu)
- (setf std-flags (logior std-flags gfs::+ws-sysmenu+)))
- ((eq sym :style-title)
- (setf std-flags (logior std-flags gfs::+ws-caption+)))
- ((eq sym :style-top)
- (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+)))
- ((eq sym :style-vscroll)
- (setf std-flags (logior std-flags gfs::+ws-vscroll+)))
-
- ;; pre-packaged combinations of window styles
- ;;
- ((eq sym :style-no-title)
- (setf std-flags 0)
- (setf ex-flags gfs::+ws-ex-windowedge+))
- ((eq sym :style-splash)
- (setf std-flags (logior gfs::+ws-overlapped+
- gfs::+ws-popup+
- gfs::+ws-clipsiblings+
- gfs::+ws-border+
- gfs::+ws-visible+))
- (setf ex-flags 0))
- ((eq sym :style-tool)
- (setf std-flags 0)
- (setf ex-flags gfs::+ws-ex-palettewindow+))
- ((eq sym :style-workspace)
- (setf std-flags (logior gfs::+ws-overlapped+
- gfs::+ws-clipsiblings+
- gfs::+ws-clipchildren+
- gfs::+ws-caption+
- gfs::+ws-sysmenu+
- gfs::+ws-thickframe+
- gfs::+ws-minimizebox+
- gfs::+ws-maximizebox+))
- (setf ex-flags 0))))
- (flatten style))
+ (mapc #'(lambda (sym)
+ (cond
+ ;; styles that can be combined
+ ;;
+ ((eq sym :style-hscroll)
+ (setf std-flags (logior std-flags gfs::+ws-hscroll+)))
+#|
+ ((eq sym :style-max)
+ (setf std-flags (logior std-flags gfs::+ws-maximizebox+)))
+ ((eq sym :style-min)
+ (setf std-flags (logior std-flags gfs::+ws-minimizebox+)))
+ ((eq sym :style-resize)
+ (setf std-flags (logior std-flags gfs::+ws-thickframe+)))
+ ((eq sym :style-sysmenu)
+ (setf std-flags (logior std-flags gfs::+ws-sysmenu+)))
+ ((eq sym :style-title)
+ (setf std-flags (logior std-flags gfs::+ws-caption+)))
+ ((eq sym :style-top)
+ (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+)))
+|#
+ ((eq sym :style-vscroll)
+ (setf std-flags (logior std-flags gfs::+ws-vscroll+)))
+
+ ;; pre-packaged combinations of window styles
+ ;;
+ ((eq sym :style-popup)
+ (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+))
+ (setf ex-flags gfs::+ws-ex-toolwindow+))
+ ((eq sym :style-splash)
+ (setf std-flags (logior gfs::+ws-overlapped+
+ gfs::+ws-popup+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-border+
+ gfs::+ws-visible+))
+ (setf ex-flags 0))
+ ((eq sym :style-tool)
+ (setf std-flags 0)
+ (setf ex-flags gfs::+ws-ex-palettewindow+))
+ ((eq sym :style-workspace)
+ (setf std-flags (logior gfs::+ws-overlappedwindow+
+ gfs::+ws-clipsiblings+
+ gfs::+ws-clipchildren+))
+ (setf ex-flags 0))))
+ (flatten style))
(values std-flags ex-flags)))
(defmethod gfi:dispose ((win window))
@@ -300,3 +297,9 @@
(let ((sz (gfi:make-size)))
(outer-size win sz)
sz))
+
+(defmethod text ((win window))
+ (get-widget-text win))
+
+(defmethod (setf text) (str (win window))
+ (set-widget-text win str))
More information about the Graphic-forms-cvs
mailing list