From erik.enge at gmail.com Fri Mar 3 14:48:58 2006
From: erik.enge at gmail.com (Erik Enge)
Date: Fri, 3 Mar 2006 09:48:58 -0500
Subject: [graphic-forms-cvs] test - ignore
Message-ID: <58f839b70603030648l32bb9d0fmda05460bb3c827fe@mail.gmail.com>
test - ignore
From junrue at common-lisp.net Fri Mar 3 22:27:21 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri, 3 Mar 2006 17:27:21 -0500 (EST)
Subject: [graphic-forms-cvs] r24 - trunk/src/uitoolkit/widgets
Message-ID: <20060303222721.BEBD916010@common-lisp.net>
Author: junrue
Date: Fri Mar 3 17:27:21 2006
New Revision: 24
Modified:
trunk/src/uitoolkit/widgets/menu-language.lisp
Log:
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Fri Mar 3 17:27:21 2006
@@ -53,7 +53,9 @@
;;;
(defclass base-menu-generator ()
- ((menu-stack :accessor menu-stack-of
+ ((commands :accessor commands-of
+ :initform nil)
+ (menu-stack :accessor menu-stack-of
:initform nil)))
(defgeneric define-item (generator label dispatcher disabled checked image)
@@ -61,10 +63,10 @@
(:method (generator label dispatcher disabled checked image)
(declare (ignorable generator label dispatcher disabled checked image))))
-(defgeneric define-submenu (generator label body dispatcher disabled)
+(defgeneric define-submenu (generator label dispatcher disabled)
(:documentation "Defines a submenu and its associated item on the parent menu.")
- (:method (generator label body dispatcher disabled)
- (declare (ignorable generator label body dispatcher disabled))))
+ (:method (generator label dispatcher disabled)
+ (declare (ignorable generator label dispatcher disabled))))
(defgeneric define-separator (generator)
(:documentation "Defines a separator.")
@@ -144,14 +146,17 @@
(if (or checked image sep (not (listp sub)))
(error 'gfs:toolkit-error :detail "invalid option for submenu")))
(cond
- (sep `(define-separator ,generator))
- (sub `(define-submenu ,generator ,label ,sub ,disp ,disabled))
- (t `(define-item ,generator ,label ,disp ,disabled ,checked ,image)))))
-
-#|
- (mapcar #'(lambda (var) (process-item-form gen var)) body)
- (complete-submenu gen)))
-|#
+ (sep (push (commands-of generator) `(define-separator ,generator)))
+ (sub (push (commands-of generator) `(define-submenu ,generator
+ ,label
+ ,disp
+ ,disabled)))
+ (t (push (commands-of generator) `(define-item ,generator
+ ,label
+ ,disp
+ ,disabled
+ ,checked
+ ,image))))))
;;;
;;; interpreter for debugging
@@ -159,7 +164,8 @@
(defun interp-menusystem (sexp)
(let ((gen (make-instance 'base-menu-generator)))
- (mapcar #'(lambda (var) (process-item-form gen var)) sexp)))
+ (mapcar #'(lambda (var) (process-item-form gen var)) sexp)
+ (commands-of gen)))
;;;
;;; the real generator
@@ -187,7 +193,7 @@
(setf (slot-value it 'gfi:handle) hmenu)
(vector-push-extend it (items owner))))
-(defmethod define-submenu ((gen win32-menu-generator) label body dispatcher disabled)
+(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
(let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
(parent (first (menu-stack-of gen)))
(item (append-submenu parent label submenu)))
@@ -200,4 +206,5 @@
(defmacro defmenusystem (sexp)
(let ((gen (gensym)))
`(let ((,gen (make-instance 'win32-menu-generator)))
- ,@(loop for form in sexp append (process-item-form gen form)))))
+ (loop for form in sexp do (process-item-form gen form))
+ ,@(commands-of ,gen))))
From junrue at common-lisp.net Sat Mar 4 07:13:11 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat, 4 Mar 2006 02:13:11 -0500 (EST)
Subject: [graphic-forms-cvs] r25 - in trunk: . src/tests/uitoolkit
src/uitoolkit/widgets
Message-ID: <20060304071311.7B1502015@common-lisp.net>
Author: junrue
Date: Sat Mar 4 02:13:10 2006
New Revision: 25
Modified:
trunk/graphic-forms-tests.asd
trunk/src/tests/uitoolkit/event-tester.lisp
trunk/src/uitoolkit/widgets/menu-language.lisp
Log:
more menu system rewrite fixes
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Sat Mar 4 02:13:10 2006
@@ -49,9 +49,9 @@
:components
((:module "uitoolkit"
:components
- ((:file "hello-world")))))))))
+ ((:file "hello-world")
+ (:file "event-tester")))))))))
#|
- ((:file "event-tester")
(:file "hello-world")))))))))
(:file "layout-tester"))
|#
Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp Sat Mar 4 02:13:10 2006
@@ -195,7 +195,7 @@
(setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md
:submenu ((:item "&Open..." :dispatcher echo-md)
(:item "&Save..." :disabled :dispatcher echo-md)
- (:item :separator)
+ (:item "" :separator)
(:item "E&xit" :dispatcher exit-md)))
(:item "&Options" :dispatcher echo-md
:submenu ((:item "&Enabled" :checked :dispatcher echo-md)
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Sat Mar 4 02:13:10 2006
@@ -53,9 +53,7 @@
;;;
(defclass base-menu-generator ()
- ((commands :accessor commands-of
- :initform nil)
- (menu-stack :accessor menu-stack-of
+ ((menu-stack :accessor menu-stack-of
:initform nil)))
(defgeneric define-item (generator label dispatcher disabled checked image)
@@ -78,19 +76,15 @@
(:method (generator)
(declare (ignorable generator))))
-;;; borrowed from Practical Common Lisp, pg. 433
-;;;
-(defun self-evaluating-p (form)
- (and (atom form) (if (symbolp form) (keywordp form) t)))
-
(defun item-form-p (form)
(and (consp form)
(eq (car form) :item)))
-(defun process-item-form (generator form)
+(defun process-item-form (form generator-sym)
(if (not (item-form-p form))
(error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" form)))
- (let ((checked nil)
+ (let ((cmds nil)
+ (checked nil)
(disabled nil)
(disp nil)
(image nil)
@@ -105,7 +99,7 @@
((not (null disp-tmp))
(setf disp opt)
(setf disp-tmp nil))
- ((not (null image-tmp))
+ ((not (null image-tmp))
(setf image opt)
(setf image-tmp nil))
((not (null sub-tmp))
@@ -141,35 +135,33 @@
(if sep
(error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators"))
(if (null disp)
- (error 'gfs:toolkit-error :detail "missing dispatcher function")))
+ (error 'gfs:toolkit-error :detail "missing dispatcher argument")))
(when sub
(if (or checked image sep (not (listp sub)))
(error 'gfs:toolkit-error :detail "invalid option for submenu")))
(cond
- (sep (push (commands-of generator) `(define-separator ,generator)))
- (sub (push (commands-of generator) `(define-submenu ,generator
- ,label
- ,disp
- ,disabled)))
- (t (push (commands-of generator) `(define-item ,generator
- ,label
- ,disp
- ,disabled
- ,checked
- ,image))))))
-
-;;;
-;;; interpreter for debugging
-;;;
-
-(defun interp-menusystem (sexp)
- (let ((gen (make-instance 'base-menu-generator)))
- (mapcar #'(lambda (var) (process-item-form gen var)) sexp)
- (commands-of gen)))
-
-;;;
-;;; the real generator
-;;;
+ (sep (push `(define-separator ,generator-sym) cmds))
+ (sub (push `(define-submenu ,generator-sym
+ ,label
+ ,disp
+ ,disabled) cmds)
+ (loop for subform in sub
+ do (setf cmds (append (process-item-form subform generator-sym) cmds)))
+ (push `(complete-submenu ,generator-sym) cmds))
+ (t (push `(define-item ,generator-sym
+ ,label
+ ,disp
+ ,disabled
+ ,checked
+ ,image) cmds)))
+ cmds))
+
+(defun generate-menusystem-code (sexp generator-sym)
+ (let ((cmds nil))
+ (mapcar #'(lambda (var)
+ (setf cmds (append (process-item-form var generator-sym) cmds)))
+ sexp)
+ (reverse cmds)))
(defclass win32-menu-generator (base-menu-generator) ())
@@ -204,7 +196,8 @@
(pop (menu-stack-of gen)))
(defmacro defmenusystem (sexp)
- (let ((gen (gensym)))
+ (let* ((gen (gensym))
+ (cmds (generate-menusystem-code sexp gen)))
`(let ((,gen (make-instance 'win32-menu-generator)))
- (loop for form in sexp do (process-item-form gen form))
- ,@(commands-of ,gen))))
+ , at cmds
+ (pop (menu-stack-of ,gen)))))
From junrue at common-lisp.net Sat Mar 4 17:23:23 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat, 4 Mar 2006 12:23:23 -0500 (EST)
Subject: [graphic-forms-cvs] r26 - in trunk: . src/tests/uitoolkit
Message-ID: <20060304172323.2191446115@common-lisp.net>
Author: junrue
Date: Sat Mar 4 12:23:22 2006
New Revision: 26
Modified:
trunk/graphic-forms-tests.asd
trunk/src/tests/uitoolkit/layout-tester.lisp
Log:
layout tester up-to-date with new menu system definition
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Sat Mar 4 12:23:22 2006
@@ -50,8 +50,5 @@
((:module "uitoolkit"
:components
((:file "hello-world")
- (:file "event-tester")))))))))
-#|
- (:file "hello-world")))))))))
- (:file "layout-tester"))
-|#
+ (:file "event-tester")
+ (:file "layout-tester")))))))))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Sat Mar 4 12:23:22 2006
@@ -123,15 +123,11 @@
(gfw:clear-all menu)
(gfw:with-children (*layout-tester-win* kids)
(loop for k in kids
- do (let ((it (make-instance 'gfw:menu-item)))
- (gfw:append-item menu it)
+ do (let ((it (gfw::append-item menu (gfw:text k) nil nil)))
(unless (null (sub-disp-class-of d))
(setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d))))
- (setf (gfw:text it) (gfw:text k))
(unless (null (check-test-fn d))
- (if (funcall (check-test-fn d) k)
- (gfw::check it)
- (gfw::uncheck it)))))))
+ (gfw:check it (funcall (check-test-fn d) k)))))))
(defclass remove-child-dispatcher (gfw:event-dispatcher) ())
@@ -158,9 +154,7 @@
do (if (string= (gfw:text k) text)
(setf victim k))))
(unless (null victim)
- (if (gfw:visible-p victim)
- (gfw:hide victim)
- (gfw:show victim))
+ (gfw:show victim (not (gfw:visible-p victim)))
(gfw:layout *layout-tester-win*))))
(defclass flow-modifier-menu-dispatcher (gfw:event-dispatcher) ())
@@ -169,34 +163,28 @@
(declare (ignore time))
(gfw:clear-all menu)
(let ((it nil)
- (margin-menu (gfw:defmenusystem `(((:menu "Top")
- (:menuitem "Decrease")
- (:menuitem "Increase"))
- ((:menu "Left")
- (:menuitem "Decrease")
- (:menuitem "Increase"))
- ((:menu "Right")
- (:menuitem "Decrease")
- (:menuitem "Increase"))
- ((:menu "Bottom")
- (:menuitem "Decrease")
- (:menuitem "Increase")))))
- (orient-menu (gfw:defmenusystem `(((:menu "")
- (:menuitem "Horizontal")
- (:menuitem "Vertical")))))
- (spacing-menu (gfw:defmenusystem `(((:menu "")
- (:menuitem "Decrease")
- (:menuitem "Increase"))))))
+ (margin-menu (gfw:defmenusystem ((:item "Top"
+ :submenu ((:item "Decrease")
+ (:item "Increase")))
+ (:item "Left"
+ :submenu ((:item "Decrease")
+ (:item "Increase")))
+ (:item "Right"
+ :submenu ((:item "Decrease")
+ (:item "Increase")))
+ (:item "Bottom"
+ :submenu ((:item "Decrease")
+ (:item "Increase"))))))
+ (orient-menu (gfw:defmenusystem ((:item "Horizontal")
+ (:item "Vertical"))))
+ (spacing-menu (gfw:defmenusystem ((:item "Decrease")
+ (:item "Increase")))))
(gfw:append-submenu menu "Margin" margin-menu)
(gfw:append-submenu menu "Orientation" orient-menu)
(gfw:append-submenu menu "Spacing" spacing-menu)
- (setf it (make-instance 'gfw:menu-item))
- (gfw:append-item menu it)
- (setf (gfw:text it) "Fill")
- (gfw:check it)
- (setf it (make-instance 'gfw:menu-item))
- (gfw:append-item menu it)
- (setf (gfw:text it) "Wrap")))
+ (setf it (gfw:append-item menu "Fill" nil nil))
+ (gfw:check it t)
+ (gfw:append-item menu "Wrap" nil nil)))
(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
@@ -219,24 +207,27 @@
(setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
:layout-manager (make-instance 'gfw:flow-layout)))
(gfw:realize *layout-tester-win* nil :style-workspace)
- (setf menubar (gfw:defmenusystem `(((:menu "&File")
- (:menuitem "E&xit" :dispatcher ,exit-disp))
- ((:menu "&Children")
- (:menuitem :submenu ((:menu "Add")
- (:menuitem "Button" :dispatcher ,add-btn-disp)
- (:menuitem "Label" :dispatcher ,add-text-label-disp)))
- (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)))
- (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp))))
- ((:menu "&Window")
- (:menuitem :submenu ((:menu "Modify Layout" :dispatcher ,mod-layout-menu-disp)))
- (:menuitem :submenu ((:menu "Select Layout")
- (:menuitem "Flow")))
- (:menuitem "Pack" :dispatcher ,pack-disp)))))
+ (setf menubar (gfw:defmenusystem ((:item "&File"
+ :submenu ((:item "E&xit" :dispatcher exit-disp)))
+ (:item "&Children"
+ :submenu ((:item "Add"
+ :submenu ((:item "Button" :dispatcher add-btn-disp)
+ (:item "Label" :dispatcher add-text-label-disp)))
+ (:item "Remove" :dispatcher rem-menu-disp
+ :submenu ((:item "")))
+ (:item "Visible" :dispatcher vis-menu-disp
+ :submenu ((:item "")))))
+ (:item "&Window"
+ :submenu ((:item "Modify Layout" :dispatcher mod-layout-menu-disp
+ :submenu ((:item "")))
+ (:item "Select Layout"
+ :submenu ((:item "Flow")))
+ (:item "Pack" :dispatcher pack-disp))))))
(setf (gfw:menu-bar *layout-tester-win*) menubar)
(dotimes (i 3)
(add-layout-tester-widget 'gfw:button :push-button))
(gfw:pack *layout-tester-win*)
- (gfw:show *layout-tester-win*)))
+ (gfw:show *layout-tester-win* t)))
(defun run-layout-tester ()
(gfw:startup "Layout Tester" #'run-layout-tester-internal))
From junrue at common-lisp.net Sat Mar 4 21:54:25 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat, 4 Mar 2006 16:54:25 -0500 (EST)
Subject: [graphic-forms-cvs] r27 - trunk/src/uitoolkit/widgets
Message-ID: <20060304215425.F3DA51E00F@common-lisp.net>
Author: junrue
Date: Sat Mar 4 16:54:25 2006
New Revision: 27
Modified:
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-with-items.lisp
Log:
fixed cleanup bug when submenu items disposed, which caused duplication in layout-tester menu tree
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Sat Mar 4 16:54:25 2006
@@ -154,7 +154,6 @@
(increment-menuitem-id tc)
(insert-submenu hparent id text (cffi:null-pointer) hmenu)
(setf (item-id item) id)
- (setf (slot-value item 'gfi:handle) hmenu)
(put-menuitem tc item)
(vector-push-extend item (items parent))
(put-widget tc submenu)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Mar 4 16:54:25 2006
@@ -40,7 +40,7 @@
(:documentation "If the object is visible, move it to the top of the display z-order and request the window manager to set it active."))
(defgeneric alignment (object)
- (:documentation "Returns an integer describing the position of internal content within the object."))
+ (:documentation "Returns a keyword symbol describing the position of internal content within the object."))
(defgeneric ancestor-p (ancestor descendant)
(:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise."))
Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Sat Mar 4 16:54:25 2006
@@ -56,8 +56,8 @@
(error 'gfi:disposed-error)))
(defmethod clear-span ((w widget-with-items) (sp gfi:span))
- (loop for index from (gfi:span-start sp) to (gfi:span-end sp)
- collect (clear-item w 0)))
+ (dotimes (i (1+ (- (gfi:span-end sp) (gfi:span-start sp))))
+ (clear-item w (gfi:span-start sp))))
(defmethod item-at :before ((w widget-with-items) index)
(declare (ignore index))
From junrue at common-lisp.net Sun Mar 5 23:36:31 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 5 Mar 2006 18:36:31 -0500 (EST)
Subject: [graphic-forms-cvs] r28 - in trunk/src/third-party: . lw-compat
Message-ID: <20060305233631.180F477000@common-lisp.net>
Author: junrue
Date: Sun Mar 5 18:36:30 2006
New Revision: 28
Added:
trunk/src/third-party/
trunk/src/third-party/lw-compat/
trunk/src/third-party/lw-compat/lw-compat-package.lisp
trunk/src/third-party/lw-compat/lw-compat.asd
trunk/src/third-party/lw-compat/lw-compat.lisp
Log:
added local copy of lw-compat lib written by Pascal Costanza
Added: trunk/src/third-party/lw-compat/lw-compat-package.lisp
==============================================================================
--- (empty file)
+++ trunk/src/third-party/lw-compat/lw-compat-package.lisp Sun Mar 5 18:36:30 2006
@@ -0,0 +1,34 @@
+;;;;
+;;;; Copyright (c) 2005 Pascal Costanza
+;;;; with permission from http://www.lispworks.com
+;;;;
+;;;; Permission is hereby granted, free of charge, to any person
+;;;; obtaining a copy of this software and associated documentation
+;;;; files (the \"Software\"), to deal in the Software without
+;;;; restriction, including without limitation the rights to use,
+;;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;;; sell copies of the Software, and to permit persons to whom the
+;;;; Software is furnished to do so, subject to the following
+;;;; conditions:
+;;;;
+;;;; The above copyright notice and this permission notice shall be
+;;;; included in all copies or substantial portions of the Software.
+;;;;
+;;;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,
+;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;;; OTHER DEALINGS IN THE SOFTWARE.
+;;;;
+
+;;; (in-package :cl-user)
+(in-package #:graphic-forms-system)
+
+#-lispworks
+(defpackage #:lispworks
+ (:use #:common-lisp)
+ (:export #:appendf #:nconcf #:rebinding #:removef
+ #:when-let #:when-let* #:with-unique-names))
Added: trunk/src/third-party/lw-compat/lw-compat.asd
==============================================================================
--- (empty file)
+++ trunk/src/third-party/lw-compat/lw-compat.asd Sun Mar 5 18:36:30 2006
@@ -0,0 +1,36 @@
+(in-package :cl-user)
+
+(asdf:defsystem #:lw-compat
+ :name "LispWorks Compatibility Library"
+ :author "Pascal Costanza, with permission from http://www.lispworks.com"
+ :version "0.2"
+ :licence "
+Copyright (c) 2005 Pascal Costanza
+with permission from http://www.lispworks.com
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the \"Software\"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or
+sell copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
+"
+ :components (#-lispworks
+ (:file "lw-compat-package")
+ #-lispworks
+ (:file "lw-compat"
+ :depends-on ("lw-compat-package"))))
Added: trunk/src/third-party/lw-compat/lw-compat.lisp
==============================================================================
--- (empty file)
+++ trunk/src/third-party/lw-compat/lw-compat.lisp Sun Mar 5 18:36:30 2006
@@ -0,0 +1,76 @@
+;;;;
+;;;; Copyright (c) 2005 Pascal Costanza
+;;;; with permission from http://www.lispworks.com
+;;;;
+;;;; Permission is hereby granted, free of charge, to any person
+;;;; obtaining a copy of this software and associated documentation
+;;;; files (the \"Software\"), to deal in the Software without
+;;;; restriction, including without limitation the rights to use,
+;;;; copy, modify, merge, publish, distribute, sublicense, and/or
+;;;; sell copies of the Software, and to permit persons to whom the
+;;;; Software is furnished to do so, subject to the following
+;;;; conditions:
+;;;;
+;;;; The above copyright notice and this permission notice shall be
+;;;; included in all copies or substantial portions of the Software.
+;;;;
+;;;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,
+;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;;; OTHER DEALINGS IN THE SOFTWARE.
+;;;;
+
+(in-package #:lispworks)
+
+#+lispworks
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "lw-compat is not needed in LispWorks."))
+
+(define-modify-macro appendf (&rest lists)
+ append "Appends lists to the end of given list.")
+
+(define-modify-macro nconcf (&rest lists)
+ nconc "Appends lists to the end of given list by NCONC.")
+
+(defmacro rebinding (vars &body body)
+ "Ensures unique names for all the variables in a groups of forms."
+ (loop for var in vars
+ for name = (gensym (symbol-name var))
+ collect `(,name ,var) into renames
+ collect ``(,,var ,,name) into temps
+ finally (return `(let ,renames
+ (with-unique-names
+ ,vars
+ `(let (,, at temps)
+ ,, at body))))))
+
+(define-modify-macro removef (item &rest keys)
+ (lambda (place item &rest keys &key test test-not start end key)
+ (declare (ignorable test test-not start end key))
+ (apply #'remove item place keys))
+ "Removes an item from a sequence.")
+
+(defmacro when-let ((var form) &body body)
+ "Executes a body of code if a form evaluates to non-nil,
+ propagating the result of the form through the body of code."
+ `(let ((,var ,form))
+ (when ,var
+ (locally
+ , at body))))
+
+(defmacro when-let* (bindings &body body)
+ "Executes a body of code if a series of forms evaluates to non-nil,
+ propagating the results of the forms through the body of code."
+ (loop for form = `(progn , at body) then `(when-let (,(car binding) ,(cadr binding)) ,form)
+ for binding in (reverse bindings)
+ finally (return form)))
+
+(defmacro with-unique-names (names &body body)
+ "Returns a body of code with each specified name bound to a similar name."
+ `(let ,(mapcar (lambda (name) `(,name (gensym ,(symbol-name name))))
+ names)
+ , at body))
From junrue at common-lisp.net Sun Mar 5 23:37:13 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 5 Mar 2006 18:37:13 -0500 (EST)
Subject: [graphic-forms-cvs] r29 - trunk
Message-ID: <20060305233713.770BA77000@common-lisp.net>
Author: junrue
Date: Sun Mar 5 18:37:13 2006
New Revision: 29
Modified:
trunk/graphic-forms-uitoolkit.asd
Log:
added local copy of lw-compat lib written by Pascal Costanza
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Sun Mar 5 18:37:13 2006
@@ -45,7 +45,14 @@
:components
((:module "src"
:components
- ((:file "packages")
+ ((:module "third-party"
+ :components
+ ((:module "lw-compat"
+ :components
+ (#-lispworks (:file "lw-compat-package")
+ #-lispworks (:file "lw-compat"
+ :depends-on ("lw-compat-package"))))))
+ (:file "packages")
(:module "intrinsics"
:depends-on ("packages")
:components
From junrue at common-lisp.net Mon Mar 6 03:45:38 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 5 Mar 2006 22:45:38 -0500 (EST)
Subject: [graphic-forms-cvs] r30 - trunk/src/third-party
Message-ID: <20060306034538.EDD4854055@common-lisp.net>
Author: junrue
Date: Sun Mar 5 22:45:38 2006
New Revision: 30
Removed:
trunk/src/third-party/
Log:
changed my mind about importing lw-compat
From junrue at common-lisp.net Mon Mar 6 03:57:40 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 5 Mar 2006 22:57:40 -0500 (EST)
Subject: [graphic-forms-cvs] r31 - trunk
Message-ID: <20060306035740.BE24254060@common-lisp.net>
Author: junrue
Date: Sun Mar 5 22:57:40 2006
New Revision: 31
Modified:
trunk/graphic-forms-uitoolkit.asd
Log:
changed my mind about importing lw-compat
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Sun Mar 5 22:57:40 2006
@@ -45,14 +45,7 @@
:components
((:module "src"
:components
- ((:module "third-party"
- :components
- ((:module "lw-compat"
- :components
- (#-lispworks (:file "lw-compat-package")
- #-lispworks (:file "lw-compat"
- :depends-on ("lw-compat-package"))))))
- (:file "packages")
+ ((:file "packages")
(:module "intrinsics"
:depends-on ("packages")
:components
@@ -100,6 +93,7 @@
(:file "event-generics")
(:file "layout-generics")
(:file "widget-generics")
+ (:file "event-dispatcher")
(:file "widget-utils")
(:file "item")
(:file "widget")
From junrue at common-lisp.net Mon Mar 6 07:16:31 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 6 Mar 2006 02:16:31 -0500 (EST)
Subject: [graphic-forms-cvs] r32 - in trunk: . src src/uitoolkit/widgets
Message-ID: <20060306071631.3DB5352000@common-lisp.net>
Author: junrue
Date: Mon Mar 6 02:16:30 2006
New Revision: 32
Added:
trunk/src/uitoolkit/widgets/event-dispatcher.lisp
Modified:
trunk/build.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/widgets/layout-classes.lisp
trunk/src/uitoolkit/widgets/layouts.lisp
Log:
implemented backend to support :callbacks initarg for event-source instances
Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp (original)
+++ trunk/build.lisp Mon Mar 6 02:16:30 2006
@@ -39,36 +39,40 @@
(defvar *external-build-dirs* nil)
-(defvar *library-root* "c:/projects/third_party/")
-(defvar *project-root* "c:/projects/public/")
+(defvar *library-root* "c:/projects/third_party/")
+(defvar *project-root* "c:/projects/public/")
-(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/"))
+(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/"))
-(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/"))
-(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/"))
-(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/"))
-(defvar *cldoc-dir* (concatenate 'string *asdf-root* "cldoc/"))
-
-(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/"))
-(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/")
-(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/"))
+(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/"))
+(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/"))
+(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/"))
+(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/"))
+(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/"))
+
+(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/"))
+(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/")
+(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/"))
(defvar *asdf-dirs* (list *cffi-dir*
+ *closer-mop-dir*
+ *lw-compat-dir*
*pcl-ch08-dir*
*pcl-ch24-dir*
- *cldoc-dir*
*gf-dir*))
-(defvar *library-build-root* (concatenate 'string *library-root* "build/"))
-(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/"))
-(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/"))
-(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/"))
-(defvar *cldoc-build-dir* (concatenate 'string *library-build-root* "cldoc/"))
+(defvar *library-build-root* (concatenate 'string *library-root* "build/"))
+(defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/"))
+(defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/"))
+(defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/"))
+(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/"))
+(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/"))
(defvar *build-dirs* (list *cffi-build-dir*
+ *closer-mop-build-dir*
+ *lw-compat-build-dir*
*pcl-ch08-build-dir*
*pcl-ch24-build-dir*
- *cldoc-build-dir*
*gf-build-dir*))
#+lispworks (defmacro chdir (path)
@@ -87,6 +91,18 @@
(asdf:operate 'asdf:load-op :cffi)
(if *external-build-dirs*
+ (chdir *lw-compat-build-dir*))
+ (asdf:operate 'asdf:load-op :lw-compat)
+
+ (if *external-build-dirs*
+ (chdir *closer-mop-build-dir*))
+ (asdf:operate 'asdf:load-op :closer-mop)
+
+ (if *external-build-dirs*
+ (chdir *cffi-build-dir*))
+ (asdf:operate 'asdf:load-op :cffi)
+
+ (if *external-build-dirs*
(chdir *pcl-ch08-build-dir*))
(asdf:operate 'asdf:load-op :macro-utilities)
@@ -97,14 +113,3 @@
(if *external-build-dirs*
(chdir *gf-build-dir*))
(asdf:operate 'asdf:load-op :graphic-forms-uitoolkit))
-
-;;; FIXME: reference to :cldoc below can't be satisfied yet when
-;;; this file is loaded
-#|
-(defun build-docs ()
- (chdir *gf-doc-dir*)
- (load "c:/projects/third_party/asdf-repo/cldoc/src/cldoc.asd")
- (asdf:operate 'asdf:load-op :cldoc)
- (let ((fn (find-symbol "EXTRACT-DOCUMENTATION" :cldoc)))
- (funcall fn 'cldoc:html *gf-doc-dir* (asdf:find-system 'graphic-forms-uitoolkit))))
-|#
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Mar 6 02:16:30 2006
@@ -431,7 +431,7 @@
#:size
#:startup
#:step-increment
- #:style
+ #:style-of
#:sub-menu
#:text
#:text-height
Added: trunk/src/uitoolkit/widgets/event-dispatcher.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/event-dispatcher.lisp Mon Mar 6 02:16:30 2006
@@ -0,0 +1,89 @@
+;;;;
+;;;; event-dispatcher.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)
+
+(defun dispatcher-for-activate-callback (class fn)
+ (lispworks:with-unique-names (arg0 arg1 arg2)
+ (let ((gf (clos:ensure-generic-function 'gfw:event-activate
+ :lambda-list (list arg0 arg1 arg2))))
+ (c2mop:ensure-method gf
+ `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2))
+ :specializers (list class
+ (find-class 'gfw:event-source)
+ (find-class 'integer))))))
+
+(defun dispatcher-for-arm-callback (class fn)
+ (lispworks:with-unique-names (arg0 arg1 arg2)
+ (let ((gf (clos:ensure-generic-function 'gfw:event-arm
+ :lambda-list (list arg0 arg1 arg2))))
+ (c2mop:ensure-method gf
+ `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2))
+ :specializers (list class
+ (find-class 'gfw:event-source)
+ (find-class 'integer))))))
+
+(defun dispatcher-for-select-callback (class fn)
+ (lispworks:with-unique-names (arg0 arg1 arg2 arg4)
+ (let ((gf (clos:ensure-generic-function 'gfw:event-select
+ :lambda-list (list arg0 arg1 arg2 arg4))))
+ (c2mop:ensure-method gf
+ `(lambda (,arg0 ,arg1 ,arg2 ,arg4) (funcall ,fn ,arg0 ,arg1 ,arg2 ,arg4))
+ :specializers (list class
+ (find-class 'gfw:item)
+ (find-class 'integer)
+ (find-class 'gfi:rectangle))))))
+
+(defun defdispatcher (callbacks)
+ (let ((class (clos:ensure-class (gensym "EDCLASS") :direct-superclasses '(event-dispatcher))))
+ (loop for pair in callbacks
+ do (cond
+ ((eq (car pair) 'gfw:event-activate)
+ (dispatcher-for-activate-callback class (cdr pair)))
+ ((eq (car pair) 'gfw:event-arm)
+ (dispatcher-for-arm-callback class (cdr pair)))
+ ((eq (car pair) 'gfw:event-select)
+ (dispatcher-for-select-callback class (cdr pair)))
+ (t
+ (error 'gfs:toolkit-error :detail (format nil "unsupported event method for callbacks: ~a"
+ (car pair))))))
+ class))
+
+(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys)
+ "The :callbacks parameter specifies an association list where the CAR is the \
+name of an event-* method (e.g., event-select) and the CDR is a function \
+pointer. As such, this constitutes a specification for a new event-dispatcher \
+object and associated methods."
+ (unless (null callbacks)
+ (let ((class (defdispatcher callbacks)))
+ (setf (dispatcher src) (make-instance (class-name class))))))
Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout-classes.lisp Mon Mar 6 02:16:30 2006
@@ -35,7 +35,7 @@
(defclass layout-manager ()
((style
- :accessor style
+ :accessor style-of
:initarg :style
:initform nil))
(:documentation "Subclasses implement layout strategies on behalf of window objects."))
Modified: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layouts.lisp (original)
+++ trunk/src/uitoolkit/widgets/layouts.lisp Mon Mar 6 02:16:30 2006
@@ -76,7 +76,7 @@
(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
(let ((max -1)
(total 0)
- (vert-orient (find :vertical (gfw:style layout))))
+ (vert-orient (find :vertical (style-of layout))))
(with-children (win kids)
(loop for k in kids
do (let ((kid-size (preferred-size k
@@ -100,7 +100,7 @@
(let ((entries nil)
(last-coord 0)
(last-dim 0)
- (vert-orient (find :vertical (gfw:style layout))))
+ (vert-orient (find :vertical (style-of layout))))
(with-children (win kids)
(loop for k in kids
do (let ((kid-size (preferred-size k
@@ -128,5 +128,5 @@
(unless (listp style)
(setf style (list style)))
(if (and (null (find :horizontal style)) (null (find :vertical style)))
- (setf (slot-value layout 'style) '(:horizontal))
- (setf (slot-value layout 'style) style)))
+ (setf (style-of layout) '(:horizontal))
+ (setf (style-of layout) style)))
From junrue at common-lisp.net Wed Mar 8 21:42:25 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Wed, 8 Mar 2006 16:42:25 -0500 (EST)
Subject: [graphic-forms-cvs] r33 - in trunk: . src src/tests/uitoolkit
src/uitoolkit/widgets
Message-ID: <20060308214225.3F6CD4D012@common-lisp.net>
Author: junrue
Date: Wed Mar 8 16:42:24 2006
New Revision: 33
Added:
trunk/src/uitoolkit/widgets/event-source.lisp
- copied, changed from r32, trunk/src/uitoolkit/widgets/event-dispatcher.lisp
Removed:
trunk/src/uitoolkit/widgets/event-dispatcher.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/hello-world.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/menu-language.lisp
Log:
implemented and debugged :callback option for menu language
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Wed Mar 8 16:42:24 2006
@@ -93,7 +93,7 @@
(:file "event-generics")
(:file "layout-generics")
(:file "widget-generics")
- (:file "event-dispatcher")
+ (:file "event-source")
(:file "widget-utils")
(:file "item")
(:file "widget")
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Wed Mar 8 16:42:24 2006
@@ -33,6 +33,16 @@
(in-package #:graphic-forms-system)
+;;;
+;;; destination for unique symbols generated by the library
+;;;
+(defpackage #:graphic-forms.generated
+ (:nicknames #:gfgen)
+ (:use #:common-lisp))
+
+;;;
+;;; package for fundamental stuff shared across the library
+;;;
(defpackage #:graphic-forms.intrinsics
(:nicknames #:gfi)
(:use #:common-lisp)
@@ -69,6 +79,9 @@
;; conditions
#:disposed-error))
+;;;
+;;; package for system-level functionality
+;;;
(defpackage #:graphic-forms.uitoolkit.system
(:nicknames #:gfs)
(:shadow #:atom #:boolean)
@@ -91,6 +104,9 @@
#:win32-error
#:win32-warning))
+;;;
+;;; package for graphics functionality
+;;;
(defpackage #:graphic-forms.uitoolkit.graphics
(:nicknames #:gfg)
(:shadow #:load #:type)
@@ -195,6 +211,9 @@
;; conditions
))
+;;;
+;;; package for UI objects
+;;;
(defpackage #:graphic-forms.uitoolkit.widgets
(:nicknames #:gfw)
(:use #:common-lisp)
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 8 16:42:24 2006
@@ -48,23 +48,21 @@
(exit-hello-world))
(defmethod gfw:event-paint ((d hellowin-events) window time gc rect)
- (declare (ignorable window time ignore rect))
+ (declare (ignorable window time 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)))
-(defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ())
-
-(defmethod gfw:event-select ((d hellowin-exit-dispatcher) item time rect)
- (declare (ignorable item time rect))
+(defun exit-fn (disp item time rect)
+ (declare (ignorable disp item time rect))
(exit-hello-world))
(defun run-hello-world-internal ()
- (let ((menubar nil)
- (disp (make-instance 'hellowin-exit-dispatcher)))
+ (let ((menubar nil))
(setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events)))
(gfw:realize *hellowin* nil :style-workspace)
- (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :dispatcher disp))))))
+ (setf menubar (gfw:defmenusystem ((:item "&File"
+ :submenu ((:item "E&xit" :callback #'exit-fn))))))
(setf (gfw:menu-bar *hellowin*) menubar)
(gfw:show *hellowin* t)))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Mar 8 16:42:24 2006
@@ -157,10 +157,8 @@
(gfw:show victim (not (gfw:visible-p victim)))
(gfw:layout *layout-tester-win*))))
-(defclass flow-modifier-menu-dispatcher (gfw:event-dispatcher) ())
-
-(defmethod gfw:event-activate ((d flow-modifier-menu-dispatcher) menu time)
- (declare (ignore time))
+(defun flow-mod-callback (disp menu time)
+ (declare (ignore disp time))
(gfw:clear-all menu)
(let ((it nil)
(margin-menu (gfw:defmenusystem ((:item "Top"
@@ -186,29 +184,26 @@
(gfw:check it t)
(gfw:append-item menu "Wrap" nil nil)))
-(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
-
-(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect)
- (declare (ignorable item time rect))
+(defun exit-layout-callback (disp item time rect)
+ (declare (ignorable disp item time rect))
(exit-layout-tester))
(defun run-layout-tester-internal ()
(setf *widget-counter* 0)
(let ((menubar nil)
- (exit-disp (make-instance 'layout-tester-exit-dispatcher))
(pack-disp (make-instance 'pack-layout-dispatcher))
(add-btn-disp (make-instance 'add-child-dispatcher))
(add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label
:subtype :text-label))
(rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher))
(vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher
- :check-test-fn #'gfw:visible-p))
- (mod-layout-menu-disp (make-instance 'flow-modifier-menu-dispatcher)))
+ :check-test-fn #'gfw:visible-p)))
(setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
:layout-manager (make-instance 'gfw:flow-layout)))
(gfw:realize *layout-tester-win* nil :style-workspace)
(setf menubar (gfw:defmenusystem ((:item "&File"
- :submenu ((:item "E&xit" :dispatcher exit-disp)))
+ :submenu ((:item "E&xit"
+ :callback #'exit-layout-callback)))
(:item "&Children"
:submenu ((:item "Add"
:submenu ((:item "Button" :dispatcher add-btn-disp)
@@ -218,7 +213,7 @@
(:item "Visible" :dispatcher vis-menu-disp
:submenu ((:item "")))))
(:item "&Window"
- :submenu ((:item "Modify Layout" :dispatcher mod-layout-menu-disp
+ :submenu ((:item "Modify Layout" :callback #'flow-mod-callback
:submenu ((:item "")))
(:item "Select Layout"
:submenu ((:item "Flow")))
Copied: trunk/src/uitoolkit/widgets/event-source.lisp (from r32, trunk/src/uitoolkit/widgets/event-dispatcher.lisp)
==============================================================================
--- trunk/src/uitoolkit/widgets/event-dispatcher.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp Wed Mar 8 16:42:24 2006
@@ -1,5 +1,5 @@
;;;;
-;;;; event-dispatcher.lisp
+;;;; event-source.lisp
;;;;
;;;; Copyright (C) 2006, Jack D. Unrue
;;;; All rights reserved.
@@ -33,50 +33,36 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defun dispatcher-for-activate-callback (class fn)
- (lispworks:with-unique-names (arg0 arg1 arg2)
- (let ((gf (clos:ensure-generic-function 'gfw:event-activate
- :lambda-list (list arg0 arg1 arg2))))
- (c2mop:ensure-method gf
- `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2))
- :specializers (list class
- (find-class 'gfw:event-source)
- (find-class 'integer))))))
-
-(defun dispatcher-for-arm-callback (class fn)
- (lispworks:with-unique-names (arg0 arg1 arg2)
- (let ((gf (clos:ensure-generic-function 'gfw:event-arm
- :lambda-list (list arg0 arg1 arg2))))
- (c2mop:ensure-method gf
- `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2))
- :specializers (list class
- (find-class 'gfw:event-source)
- (find-class 'integer))))))
-
-(defun dispatcher-for-select-callback (class fn)
- (lispworks:with-unique-names (arg0 arg1 arg2 arg4)
- (let ((gf (clos:ensure-generic-function 'gfw:event-select
- :lambda-list (list arg0 arg1 arg2 arg4))))
- (c2mop:ensure-method gf
- `(lambda (,arg0 ,arg1 ,arg2 ,arg4) (funcall ,fn ,arg0 ,arg1 ,arg2 ,arg4))
- :specializers (list class
- (find-class 'gfw:item)
- (find-class 'integer)
- (find-class 'gfi:rectangle))))))
-
-(defun defdispatcher (callbacks)
- (let ((class (clos:ensure-class (gensym "EDCLASS") :direct-superclasses '(event-dispatcher))))
+(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer))
+ (gfw:event-arm . (gfw:event-source integer))
+ (gfw:event-select . (gfw:item integer gfi:rectangle))))
+
+(defun make-specializer-list (disp-class arg-info)
+ (let ((tmp (mapcar #'find-class arg-info)))
+ (push disp-class tmp)
+ tmp))
+
+(defun define-dispatcher (callbacks)
+ (let* ((*print-gensym* nil)
+ (class (clos:ensure-class (gentemp "EDCLASS" :gfgen)
+ :direct-superclasses '(event-dispatcher))))
(loop for pair in callbacks
- do (cond
- ((eq (car pair) 'gfw:event-activate)
- (dispatcher-for-activate-callback class (cdr pair)))
- ((eq (car pair) 'gfw:event-arm)
- (dispatcher-for-arm-callback class (cdr pair)))
- ((eq (car pair) 'gfw:event-select)
- (dispatcher-for-select-callback class (cdr pair)))
- (t
- (error 'gfs:toolkit-error :detail (format nil "unsupported event method for callbacks: ~a"
- (car pair))))))
+ do (let* ((method-sym (car pair))
+ (fn (cdr pair))
+ (arg-info (cdr (assoc method-sym +callback-info+)))
+ (args nil))
+ `(unless (or (symbolp ,fn) (functionp ,fn))
+ (error 'gfs:toolkit-error
+ :detail "callback must be function or symbol naming function"))
+ (if (null arg-info)
+ (error 'gfs:toolkit-error :detail (format nil
+ "unsupported event method for callbacks: ~a"
+ method-sym)))
+ (dotimes (i (1+ (length arg-info)))
+ (push (gentemp "ARG" :gfgen) args))
+ (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args)
+ `(lambda ,args (funcall ,fn , at args))
+ :specializers (make-specializer-list class arg-info))))
class))
(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys)
@@ -85,5 +71,5 @@
pointer. As such, this constitutes a specification for a new event-dispatcher \
object and associated methods."
(unless (null callbacks)
- (let ((class (defdispatcher callbacks)))
+ (let ((class (define-dispatcher callbacks)))
(setf (dispatcher src) (make-instance (class-name class))))))
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Wed Mar 8 16:42:24 2006
@@ -41,7 +41,7 @@
(gfw:defmenusystem ((:item "&File" :submenu ((:item "&Open...")
(:item "&Save..." :disabled)
(:item :separator)
- (:item "E&xit")))
+ (:item "E&xit" :callback #'some-fn)))
(:item "&Options" :submenu ((:item "&Enabled" :checked)
(:item "&Tools" :submenu ((:item "&Fonts" :disabled)
(:item "&Colors")))))
@@ -49,7 +49,7 @@
|#
;;;
-;;; basic infrastructure
+;;; base class and generic functions
;;;
(defclass base-menu-generator ()
@@ -80,10 +80,15 @@
(and (consp form)
(eq (car form) :item)))
+;;;
+;;; menu system form parser
+;;;
+
(defun process-item-form (form generator-sym)
(if (not (item-form-p form))
(error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" form)))
- (let ((cmds nil)
+ (let ((callback nil)
+ (code nil)
(checked nil)
(disabled nil)
(disp nil)
@@ -91,14 +96,20 @@
(label nil)
(sep nil)
(sub nil)
+ (cb-tmp nil)
(disp-tmp nil)
(image-tmp nil)
(sub-tmp nil))
(loop for opt in form
do (cond
+ ((not (null cb-tmp))
+ (setf callback opt)
+ (setf cb-tmp nil)
+ (setf disp nil))
((not (null disp-tmp))
(setf disp opt)
- (setf disp-tmp nil))
+ (setf disp-tmp nil)
+ (setf callback nil))
((not (null image-tmp))
(setf image opt)
(setf image-tmp nil))
@@ -107,6 +118,8 @@
(setf sub-tmp nil))
((and (not (eq opt :item)) (null label))
(setf label opt))
+ ((eq opt :callback)
+ (setf cb-tmp t))
((eq opt :checked)
(setf checked t))
((eq opt :disabled)
@@ -131,6 +144,14 @@
(error 'gfs:toolkit-error :detail "image cannot be set for separators or submenus"))
(if (null image)
(error 'gfs:toolkit-error :detail "missing image object")))
+ (when callback
+ (if sep
+ (error 'gfs:toolkit-error :detail "callbacks cannot be set for separators"))
+ (if (null callback)
+ (error 'gfs:toolkit-error :detail "missing callback argument"))
+ (if sub
+ (setf disp `(make-instance (define-dispatcher `((gfw:event-activate . ,,callback)))))
+ (setf disp `(make-instance (define-dispatcher `((gfw:event-select . ,,callback)))))))
(when disp
(if sep
(error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators"))
@@ -140,35 +161,39 @@
(if (or checked image sep (not (listp sub)))
(error 'gfs:toolkit-error :detail "invalid option for submenu")))
(cond
- (sep (push `(define-separator ,generator-sym) cmds))
+ (sep (push `(define-separator ,generator-sym) code))
(sub (push `(define-submenu ,generator-sym
,label
,disp
- ,disabled) cmds)
+ ,disabled) code)
(loop for subform in sub
- do (setf cmds (append (process-item-form subform generator-sym) cmds)))
- (push `(complete-submenu ,generator-sym) cmds))
+ do (setf code (append (process-item-form subform generator-sym) code)))
+ (push `(complete-submenu ,generator-sym) code))
(t (push `(define-item ,generator-sym
,label
,disp
,disabled
,checked
- ,image) cmds)))
- cmds))
+ ,image) code)))
+ code))
+
+;;;
+;;; code generation
+;;;
(defun generate-menusystem-code (sexp generator-sym)
- (let ((cmds nil))
+ (let ((code nil))
(mapcar #'(lambda (var)
- (setf cmds (append (process-item-form var generator-sym) cmds)))
+ (setf code (append (process-item-form var generator-sym) code)))
sexp)
- (reverse cmds)))
+ (reverse code)))
(defclass win32-menu-generator (base-menu-generator) ())
(defmethod initialize-instance :after ((gen win32-menu-generator) &key)
(let ((m (make-instance 'menu :handle (gfs::create-menu))))
(put-widget (thread-context) m)
- (setf (menu-stack-of gen) (list m))))
+ (push m (menu-stack-of gen))))
(defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image)
(let* ((owner (first (menu-stack-of gen)))
@@ -195,9 +220,12 @@
(defmethod complete-submenu ((gen win32-menu-generator))
(pop (menu-stack-of gen)))
+;;;
+;;; top-level API for the menu language
+;;;
+
(defmacro defmenusystem (sexp)
- (let* ((gen (gensym))
- (cmds (generate-menusystem-code sexp gen)))
+ (let ((gen (gensym)))
`(let ((,gen (make-instance 'win32-menu-generator)))
- , at cmds
+ ,@(generate-menusystem-code sexp gen)
(pop (menu-stack-of ,gen)))))
From junrue at common-lisp.net Thu Mar 9 16:45:11 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 9 Mar 2006 11:45:11 -0500 (EST)
Subject: [graphic-forms-cvs] r34 - in trunk/src: . tests/uitoolkit
uitoolkit/widgets
Message-ID: <20060309164511.DCDFC4100F@common-lisp.net>
Author: junrue
Date: Thu Mar 9 11:45:11 2006
New Revision: 34
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/menu-item.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
Log:
update menu append-item to support callback functions in addition to dispatchers
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu Mar 9 11:45:11 2006
@@ -34,7 +34,7 @@
(in-package #:graphic-forms-system)
;;;
-;;; destination for unique symbols generated by the library
+;;; destination for unique symbols generated by GENTEMP
;;;
(defpackage #:graphic-forms.generated
(:nicknames #:gfgen)
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Mar 9 11:45:11 2006
@@ -182,7 +182,7 @@
(gfw:append-submenu menu "Spacing" spacing-menu)
(setf it (gfw:append-item menu "Fill" nil nil))
(gfw:check it t)
- (gfw:append-item menu "Wrap" nil nil)))
+ (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2)))))
(defun exit-layout-callback (disp item time rect)
(declare (ignorable disp item time rect))
Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp Thu Mar 9 11:45:11 2006
@@ -142,6 +142,20 @@
(error 'gfs:win32-error :detail "set-menu-item-info failed"))
(= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+))))
+(defun create-menuitem-with-callback (hmenu disp)
+ (let ((item nil))
+ (cond
+ ((null disp)
+ (setf item (make-instance 'menu-item :handle hmenu)))
+ ((functionp disp)
+ (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp)))))
+ ((typep disp 'gfw:event-dispatcher)
+ (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp)))
+ (t
+ (error 'gfs:toolkit-error
+ :detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
+ item))
+
;;;
;;; methods
;;;
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Thu Mar 9 11:45:11 2006
@@ -132,13 +132,11 @@
(defmethod append-item ((owner menu) text image disp)
(let* ((tc (thread-context))
- (item (make-instance 'menu-item :dispatcher disp))
- (id (next-menuitem-id tc))
- (hmenu (gfi:handle owner)))
- (increment-menuitem-id tc)
+ (id (increment-menuitem-id tc))
+ (hmenu (gfi:handle owner))
+ (item (create-menuitem-with-callback hmenu disp)))
(insert-menuitem hmenu id text (cffi:null-pointer))
(setf (item-id item) id)
- (setf (slot-value item 'gfi:handle) hmenu)
(put-menuitem tc item)
(vector-push-extend item (items owner))
item))
@@ -147,11 +145,10 @@
(if (or (gfi:disposed-p parent) (gfi:disposed-p submenu))
(error 'gfi:disposed-error))
(let* ((tc (thread-context))
- (id (next-menuitem-id tc))
+ (id (increment-menuitem-id tc))
(hparent (gfi:handle parent))
(hmenu (gfi:handle submenu))
(item (make-instance 'menu-item :handle hparent)))
- (increment-menuitem-id tc)
(insert-submenu hparent id text (cffi:null-pointer) hmenu)
(setf (item-id item) id)
(put-menuitem tc item)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Mar 9 11:45:11 2006
@@ -129,5 +129,7 @@
(slot-value tc 'menuitems-by-id)))
(defmethod increment-menuitem-id ((tc thread-context))
- "Bump up the next menu item ID."
- (incf (slot-value tc 'next-menuitem-id)))
+ "Return the next menu item ID; also increment the internal value."
+ (let ((id (next-menuitem-id tc)))
+ (incf (slot-value tc 'next-menuitem-id))
+ id))
From junrue at common-lisp.net Mon Mar 13 00:19:37 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 12 Mar 2006 19:19:37 -0500 (EST)
Subject: [graphic-forms-cvs] r35 - in trunk: . src/intrinsics/datastructs
src/tests/uitoolkit src/uitoolkit/widgets
Message-ID: <20060313001937.708F62100D@common-lisp.net>
Author: junrue
Date: Sun Mar 12 19:19:36 2006
New Revision: 35
Added:
trunk/src/intrinsics/datastructs/datastruct.lisp
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/tests/uitoolkit/mock-objects.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/layout.lisp
- copied, changed from r32, trunk/src/uitoolkit/widgets/layouts.lisp
Removed:
trunk/src/uitoolkit/widgets/layouts.lisp
Modified:
trunk/graphic-forms-tests.asd
trunk/graphic-forms-uitoolkit.asd
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/tests.lisp
Log:
flow layout unit-test code; bug fixes for vertical flow layout style
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Sun Mar 12 19:19:36 2006
@@ -49,6 +49,8 @@
:components
((:module "uitoolkit"
:components
- ((:file "hello-world")
+ ((:file "mock-objects")
+ (:file "layout-unit-tests")
+ (:file "hello-world")
(:file "event-tester")
(:file "layout-tester")))))))))
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Sun Mar 12 19:19:36 2006
@@ -51,7 +51,8 @@
:components
((:module "datastructs"
:components
- ((:file "datastruct-classes")))
+ ((:file "datastruct-classes")
+ (:file "datastruct")))
(:module "system"
:components
((:file "native-classes")
@@ -106,4 +107,5 @@
(:file "menu-language")
(:file "event")
(:file "window")
- (:file "layouts")))))))))
+ (:file "layout")
+ (:file "flow-layout")))))))))
Added: trunk/src/intrinsics/datastructs/datastruct.lisp
==============================================================================
--- (empty file)
+++ trunk/src/intrinsics/datastructs/datastruct.lisp Sun Mar 12 19:19:36 2006
@@ -0,0 +1,38 @@
+;;;;
+;;;; datastruct.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.intrinsics)
+
+(defmethod print-object ((obj rectangle) stream)
+ (print-unreadable-object (obj stream :type t)
+ (format stream "location: ~a size: ~a" (location obj) (size obj))))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 19:19:36 2006
@@ -157,6 +157,18 @@
(gfw:show victim (not (gfw:visible-p victim)))
(gfw:layout *layout-tester-win*))))
+(defun set-flow-horizontal (disp item time rect)
+ (declare (ignorable disp item time rect))
+ (let ((layout (gfw:layout-manager *layout-tester-win*)))
+ (setf (gfw:style-of layout) (list :horizontal))
+ (gfw:layout *layout-tester-win*)))
+
+(defun set-flow-vertical (disp item time rect)
+ (declare (ignorable disp item time rect))
+ (let ((layout (gfw:layout-manager *layout-tester-win*)))
+ (setf (gfw:style-of layout) (list :vertical))
+ (gfw:layout *layout-tester-win*)))
+
(defun flow-mod-callback (disp menu time)
(declare (ignore disp time))
(gfw:clear-all menu)
@@ -173,8 +185,10 @@
(:item "Bottom"
:submenu ((:item "Decrease")
(:item "Increase"))))))
- (orient-menu (gfw:defmenusystem ((:item "Horizontal")
- (:item "Vertical"))))
+ (orient-menu (gfw:defmenusystem ((:item "Horizontal"
+ :callback #'set-flow-horizontal)
+ (:item "Vertical"
+ :callback #'set-flow-vertical))))
(spacing-menu (gfw:defmenusystem ((:item "Decrease")
(:item "Increase")))))
(gfw:append-submenu menu "Margin" margin-menu)
Added: trunk/src/tests/uitoolkit/layout-unit-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Sun Mar 12 19:19:36 2006
@@ -0,0 +1,81 @@
+;;;;
+;;;; layout-unit-tests.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)
+
+(defvar *minsize1* (gfi:make-size :width 20 :height 10))
+(defvar *flow-layout-kids1* (list (make-instance 'mock-widget :min-size *minsize1*)
+ (make-instance 'mock-widget :min-size *minsize1*)
+ (make-instance 'mock-widget :min-size *minsize1*)))
+
+(defun validate-layout-points (actual-entries expected-pnts)
+ (mapc #'(lambda (pnt entry)
+ (let ((pnt2 (gfi:location (cdr entry))))
+ (assert-true (and (= (gfi:point-x pnt) (gfi:point-x pnt2))
+ (= (gfi:point-y pnt) (gfi:point-y pnt2))))))
+ expected-pnts
+ actual-entries))
+
+(define-test flow-layout-test1
+ ;; orient: horizontal
+ ;; wrap: disabled
+ ;; fill: disabled
+ ;; container: visible
+ ;; kids: uniform
+ ;;
+ (let* ((size (gfw::flow-container-size '(:horizontal) t *flow-layout-kids1* -1 -1))
+ (actual (gfw::flow-container-layout '(:horizontal) t *flow-layout-kids1* -1 -1))
+ (expected-pnts nil))
+ (push (gfi:make-point :x 40 :y 0) expected-pnts)
+ (push (gfi:make-point :x 20 :y 0) expected-pnts)
+ (push (gfi:make-point :x 0 :y 0) expected-pnts)
+ (assert-equal 60 (gfi:size-width size))
+ (assert-equal 10 (gfi:size-height size))
+ (validate-layout-points actual expected-pnts)))
+
+(define-test flow-layout-test2
+ ;; orient: vertical
+ ;; wrap: disabled
+ ;; fill: disabled
+ ;; container: visible
+ ;; kids: uniform
+ ;;
+ (let* ((size (gfw::flow-container-size '(:vertical) t *flow-layout-kids1* -1 -1))
+ (actual (gfw::flow-container-layout '(:vertical) t *flow-layout-kids1* -1 -1))
+ (expected-pnts nil))
+ (push (gfi:make-point :x 0 :y 20) expected-pnts)
+ (push (gfi:make-point :x 0 :y 10) expected-pnts)
+ (push (gfi:make-point :x 0 :y 0) expected-pnts)
+ (assert-equal 20 (gfi:size-width size))
+ (assert-equal 30 (gfi:size-height size))
+ (validate-layout-points actual expected-pnts)))
Added: trunk/src/tests/uitoolkit/mock-objects.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/mock-objects.lisp Sun Mar 12 19:19:36 2006
@@ -0,0 +1,79 @@
+;;;;
+;;;; mock-objects.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)
+
+(defconstant +max-widget-size+ 5000)
+
+;;;
+;;; stand-ins for widgets that would be children of windows, to be organized
+;;; via layout managers
+;;;
+
+(defclass mock-widget (gfw:widget)
+ ((visibility
+ :accessor visibility-of
+ :initform t)
+ (actual-size
+ :accessor actual-size-of
+ :initarg :actual-size
+ :initform (gfi:make-size))
+ (max-size
+ :accessor max-size-of
+ :initarg :max-size
+ :initform (gfi:make-size :width +max-widget-size+ :height +max-widget-size+))
+ (min-size
+ :accessor min-size-of
+ :initarg :min-size
+ :initform (gfi:make-size))))
+
+(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys)
+ (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF)))
+
+(defmethod gfw:minimum-size ((widget mock-widget))
+ (gfi:make-size :width (gfi:size-width (min-size-of widget))
+ :height (gfi:size-height (min-size-of widget))))
+
+(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint)
+ (let ((size (gfi:make-size))
+ (min-size (min-size-of widget)))
+ (if (< width-hint 0)
+ (setf (gfi:size-width size) (gfi:size-width min-size))
+ (setf (gfi:size-width size) width-hint))
+ (if (< height-hint 0)
+ (setf (gfi:size-height size) (gfi:size-height min-size))
+ (setf (gfi:size-height size) height-hint))
+ size))
+
+(defmethod gfw:visible-p ((widget mock-widget))
+ (visibility-of widget))
Added: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 19:19:36 2006
@@ -0,0 +1,109 @@
+;;;;
+;;;; flow-layout.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)
+
+;;;
+;;; helper functions
+;;;
+
+(defun flow-container-size (style win-visible kids width-hint height-hint)
+ (let ((max -1)
+ (total 0)
+ (vert-orient (find :vertical style)))
+ (loop for kid in kids
+ do (let ((size (preferred-size kid
+ (if vert-orient width-hint -1)
+ (if vert-orient -1 height-hint))))
+ (when (or (visible-p kid) (not win-visible))
+ (if vert-orient
+ (progn
+ (incf total (gfi:size-height size))
+ (if (< max (gfi:size-width size))
+ (setf max (gfi:size-width size))))
+ (progn
+ (incf total (gfi:size-width size))
+ (if (< max (gfi:size-height size))
+ (setf max (gfi:size-height size))))))))
+ (if vert-orient
+ (gfi:make-size :width max :height total)
+ (gfi:make-size :width total :height max))))
+
+(defun flow-container-layout (style win-visible kids width-hint height-hint)
+ (let ((entries nil)
+ (last-coord 0)
+ (last-dim 0)
+ (vert-orient (find :vertical style)))
+ (loop for kid in kids
+ do (let ((size (preferred-size kid
+ (if vert-orient width-hint -1)
+ (if vert-orient -1 height-hint)))
+ (pnt (gfi:make-point)))
+ (when (or (visible-p kid) (not win-visible))
+ (if vert-orient
+ (progn
+ (setf (gfi:point-y pnt) (+ last-coord last-dim))
+ (if (>= width-hint 0)
+ (setf (gfi:size-width size) width-hint))
+ (setf last-coord (gfi:point-y pnt))
+ (setf last-dim (gfi:size-height size)))
+ (progn
+ (setf (gfi:point-x pnt) (+ last-coord last-dim))
+ (if (>= height-hint 0)
+ (setf (gfi:size-height size) height-hint))
+ (setf last-coord (gfi:point-x pnt))
+ (setf last-dim (gfi:size-width size))))
+ (push (cons kid (make-instance 'gfi:rectangle
+ :size size
+ :location pnt))
+ entries))))
+ (reverse entries)))
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
+ (with-children (win kids)
+ (flow-container-size (style-of layout) (visible-p win) kids width-hint height-hint)))
+
+(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
+ (with-children (win kids)
+ (flow-container-layout (style-of layout) (visible-p win) kids width-hint height-hint)))
+
+(defmethod initialize-instance :after ((layout flow-layout) &key style)
+ (unless (listp style)
+ (setf style (list style)))
+ (if (and (null (find :horizontal style)) (null (find :vertical style)))
+ (setf (style-of layout) '(:horizontal))
+ (setf (style-of layout) style)))
Copied: trunk/src/uitoolkit/widgets/layout.lisp (from r32, trunk/src/uitoolkit/widgets/layouts.lisp)
==============================================================================
--- trunk/src/uitoolkit/widgets/layouts.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 19:19:36 2006
@@ -1,5 +1,5 @@
;;;;
-;;;; layouts.lisp
+;;;; layout.lisp
;;;;
;;;; Copyright (C) 2006, Jack D. Unrue
;;;; All rights reserved.
@@ -45,6 +45,7 @@
(hdwp nil))
(when (and (layout-p win) layout)
(setf kids (compute-layout layout win width-hint height-hint))
+(loop for x in kids do (format t "~a~%" (cdr x)))
(setf hdwp (gfs::begin-defer-window-pos (length kids)))
(loop for k in kids
do (let* ((rect (cdr k))
@@ -68,65 +69,3 @@
+window-pos-flags+)))))
(unless (gfi:null-handle-p hdwp)
(gfs::end-defer-window-pos hdwp)))))
-
-;;;
-;;; flow-layout methods
-;;;
-
-(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
- (let ((max -1)
- (total 0)
- (vert-orient (find :vertical (style-of layout))))
- (with-children (win kids)
- (loop for k in kids
- do (let ((kid-size (preferred-size k
- (if vert-orient width-hint -1)
- (if vert-orient -1 height-hint))))
- (when (or (visible-p k) (not (visible-p win)))
- (if (not vert-orient)
- (progn
- (incf total (gfi:size-width kid-size))
- (if (< max (gfi:size-height kid-size))
- (setf max (gfi:size-height kid-size))))
- (progn
- (incf total (gfi:size-height kid-size))
- (if (< max (gfi:size-width kid-size))
- (setf max (gfi:size-width kid-size)))))))))
- (if vert-orient
- (gfi:make-size :width max :height total)
- (gfi:make-size :width total :height max))))
-
-(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
- (let ((entries nil)
- (last-coord 0)
- (last-dim 0)
- (vert-orient (find :vertical (style-of layout))))
- (with-children (win kids)
- (loop for k in kids
- do (let ((kid-size (preferred-size k
- (if vert-orient width-hint -1)
- (if vert-orient -1 height-hint)))
- (pnt (gfi:make-point)))
- (when (or (visible-p k) (not (visible-p win)))
- (if (not vert-orient)
- (progn
- (setf (gfi:point-x pnt) (+ last-coord last-dim))
- (if (>= height-hint 0)
- (setf (gfi:size-height kid-size) height-hint))
- (setf last-coord (gfi:point-x pnt))
- (setf last-dim (gfi:size-width kid-size)))
- (progn
- (setf (gfi:point-y pnt) (+ last-coord last-dim))
- (if (>= width-hint 0)
- (setf (gfi:size-width kid-size) width-hint))
- (setf last-coord (gfi:point-y pnt))
- (setf last-dim (gfi:size-height kid-size))))
- (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries)))))
- (reverse entries)))
-
-(defmethod initialize-instance :after ((layout flow-layout) &key style)
- (unless (listp style)
- (setf style (list style)))
- (if (and (null (find :horizontal style)) (null (find :vertical style)))
- (setf (style-of layout) '(:horizontal))
- (setf (style-of layout) style)))
Modified: trunk/tests.lisp
==============================================================================
--- trunk/tests.lisp (original)
+++ trunk/tests.lisp Sun Mar 12 19:19:36 2006
@@ -33,15 +33,15 @@
(in-package #:graphic-forms-system)
-(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp"))
+(defvar *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit"))
-(load (compile-file *lisp-unit-srcfile*))
+(load (compile-file *lisp-unit-file*))
(defpackage #:graphic-forms.uitoolkit.tests
(:nicknames #:gft)
(:use :common-lisp :lisp-unit))
-(defun load-adhoc-tests ()
+(defun load-tests ()
(if *external-build-dirs*
(chdir *gf-build-dir*))
(asdf:operate 'asdf:load-op :graphic-forms-tests))
From junrue at common-lisp.net Mon Mar 13 02:06:21 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 12 Mar 2006 21:06:21 -0500 (EST)
Subject: [graphic-forms-cvs] r36 - in trunk/src: tests/uitoolkit
uitoolkit/widgets
Message-ID: <20060313020621.D49F059057@common-lisp.net>
Author: junrue
Date: Sun Mar 12 21:06:21 2006
New Revision: 36
Modified:
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/layout.lisp
trunk/src/uitoolkit/widgets/menu-language.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
enhance append-submenu so it can take callback or dispatcher
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 21:06:21 2006
@@ -157,6 +157,12 @@
(gfw:show victim (not (gfw:visible-p victim)))
(gfw:layout *layout-tester-win*))))
+(defun check-flow-orient-item (disp menu time)
+ (declare (ignore disp time))
+ (let ((layout (gfw:layout-manager *layout-tester-win*)))
+ (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout)))
+ (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout)))))
+
(defun set-flow-horizontal (disp item time rect)
(declare (ignorable disp item time rect))
(let ((layout (gfw:layout-manager *layout-tester-win*)))
@@ -191,9 +197,9 @@
:callback #'set-flow-vertical))))
(spacing-menu (gfw:defmenusystem ((:item "Decrease")
(:item "Increase")))))
- (gfw:append-submenu menu "Margin" margin-menu)
- (gfw:append-submenu menu "Orientation" orient-menu)
- (gfw:append-submenu menu "Spacing" spacing-menu)
+ (gfw:append-submenu menu "Margin" margin-menu nil)
+ (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item)
+ (gfw:append-submenu menu "Spacing" spacing-menu nil)
(setf it (gfw:append-item menu "Fill" nil nil))
(gfw:check it t)
(gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2)))))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 21:06:21 2006
@@ -87,7 +87,7 @@
:size size
:location pnt))
entries))))
- (reverse entries)))
+ (nreverse entries)))
;;;
;;; methods
Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 21:06:21 2006
@@ -45,7 +45,6 @@
(hdwp nil))
(when (and (layout-p win) layout)
(setf kids (compute-layout layout win width-hint height-hint))
-(loop for x in kids do (format t "~a~%" (cdr x)))
(setf hdwp (gfs::begin-defer-window-pos (length kids)))
(loop for k in kids
do (let* ((rect (cdr k))
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Mar 12 21:06:21 2006
@@ -211,9 +211,9 @@
(vector-push-extend it (items owner))))
(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
- (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
+ (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))
(parent (first (menu-stack-of gen)))
- (item (append-submenu parent label submenu)))
+ (item (append-submenu parent label submenu dispatcher)))
(push submenu (menu-stack-of gen))
(enable item (not disabled))))
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Sun Mar 12 21:06:21 2006
@@ -141,7 +141,7 @@
(vector-push-extend item (items owner))
item))
-(defmethod append-submenu ((parent menu) text (submenu menu))
+(defmethod append-submenu ((parent menu) text (submenu menu) disp)
(if (or (gfi:disposed-p parent) (gfi:disposed-p submenu))
(error 'gfi:disposed-error))
(let* ((tc (thread-context))
@@ -154,6 +154,16 @@
(put-menuitem tc item)
(vector-push-extend item (items parent))
(put-widget tc submenu)
+ (cond
+ ((null disp))
+ ((functionp disp)
+ (let ((class (define-dispatcher `((event-activate . ,disp)))))
+ (setf (dispatcher submenu) (make-instance (class-name class)))))
+ ((typep disp 'gfw:event-dispatcher)
+ (setf (dispatcher submenu) disp))
+ (t
+ (error 'gfs:toolkit-error
+ :detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
item))
(defun menu-cleanup-callback (menu item)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Mar 12 21:06:21 2006
@@ -48,7 +48,7 @@
(defgeneric append-item (object text image dispatcher)
(:documentation "Adds the new item with the specified text to the object, and returns the newly-created item."))
-(defgeneric append-submenu (object text submenu)
+(defgeneric append-submenu (object text submenu dispatcher)
(:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
(defgeneric background-color (object)
From junrue at common-lisp.net Mon Mar 13 05:40:49 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 13 Mar 2006 00:40:49 -0500 (EST)
Subject: [graphic-forms-cvs] r37 - in trunk: docs/manual src/tests/uitoolkit
src/uitoolkit/widgets
Message-ID: <20060313054049.BEEAC58343@common-lisp.net>
Author: junrue
Date: Mon Mar 13 00:40:49 2006
New Revision: 37
Added:
trunk/docs/manual/
trunk/docs/manual/Makefile
trunk/docs/manual/graphic-forms-reference.texinfo
trunk/docs/manual/style.css
Modified:
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
Log:
stub out reference manual
Added: trunk/docs/manual/Makefile
==============================================================================
--- (empty file)
+++ trunk/docs/manual/Makefile Mon Mar 13 00:40:49 2006
@@ -0,0 +1,47 @@
+# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
+#
+# Makefile
+#
+# Copyright (c) 2006, Jack D. Unrue
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+#
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+#
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# 3. Neither the names of the authors nor the names of its contributors
+# may be used to endorse or promote products derived from this software
+# without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+# CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+
+#
+# TODO: upgrade MSYS version of makeinfo so "--css-include=style.css" works
+#
+docs:
+ makeinfo --html graphic-forms-reference.texinfo
+
+clean:
+ find . \( -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \;
+ rm -rf graphic-forms-reference
+
+#
+# TODO: implement an upload target
+#
Added: trunk/docs/manual/graphic-forms-reference.texinfo
==============================================================================
--- (empty file)
+++ trunk/docs/manual/graphic-forms-reference.texinfo Mon Mar 13 00:40:49 2006
@@ -0,0 +1,155 @@
+\input texinfo @c -*- Mode: Texinfo; Mode: auto-fill -*-
+ at c %**start of header
+ at setfilename graphic-forms-reference.info
+ at settitle Graphic-Forms Programming Reference
+ at exampleindent 2
+
+ at c @documentencoding utf-8
+
+ at c ============================= Macros =============================
+
+ at macro Function {args}
+ at defun \args\
+ at end defun
+ at end macro
+
+ at macro Macro {args}
+ at defmac \args\
+ at end defmac
+ at end macro
+
+ at macro Accessor {args}
+ at deffn {Accessor} \args\
+ at end deffn
+ at end macro
+
+ at macro GenericFunction {args}
+ at deffn {Generic Function} \args\
+ at end deffn
+ at end macro
+
+ at macro Variable {args}
+ at defvr {Special Variable} \args\
+ at end defvr
+ at end macro
+
+ at macro Condition {args}
+ at deftp {Condition Type} \args\
+ at end deftp
+ at end macro
+
+ at macro GFI
+ at acronym{GFW}
+ at end macro
+
+ at macro GFG
+ at acronym{GFW}
+ at end macro
+
+ at macro GFS
+ at acronym{GFW}
+ at end macro
+
+ at macro GFW
+ at acronym{GFW}
+ at end macro
+
+ at macro impnote {text}
+ at quotation
+ at strong{Implementor's note:} @emph{\text\}
+ at end quotation
+ at end macro
+
+ at c Info "requires" that x-refs end in a period or comma, or ) in the
+ at c case of @pxref. So the following implements that requirement for
+ at c the "See also" subheadings that permeate this manual, but only in
+ at c Info mode.
+ at ifinfo
+ at macro seealso {name}
+ at ref{\name\}.
+ at end macro
+ at end ifinfo
+
+ at ifnotinfo
+ at alias seealso = ref
+ at end ifnotinfo
+
+ at c ==========================End Macros =============================
+
+ at c Show types, functions, and concepts in the same index.
+ at syncodeindex tp cp
+ at syncodeindex fn cp
+
+ at copying
+Copyright @copyright{} 2006, Jack D. Unrue Graphic-Forms is distributed in source code form. Please choose from
+ one of the following options:
+
+ Programming Reference
+
+ FAQ
+
+ Articles
+
+
+
+
+
Added: trunk/docs/website/download.html
==============================================================================
--- (empty file)
+++ trunk/docs/website/download.html Wed Mar 15 14:40:07 2006
@@ -0,0 +1,38 @@
+
+
+
+
+
Graphic-Forms is a user interface library implemented in @@ -44,45 +53,38 @@ in the open-source world or the toolkits provided by commercial vendors. Or you might consider helping new portable UI projects such as wxCL. This - project is aimed specifically at Windows® developers. + project is aimed specifically at Windows® developers.
-The Subversion repository will be populated with an initial code - drop in the near future. Additional documentation will be - made available at that time, as will screenshots.
+The first release will be version 0.2.0 and should be + available shortly.
-NOTE: This library is in the early implementation stage. Brave souls who +
This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and - behavior changes in the preliminary releases leading up to the 1.0 release.
+ behavior changes in the preliminary releases leading up to the 1.0 release.
-This project has not released any files.
- -You can -browse the Subversion repository or download the current development tree via - anonymous svn, as described here.
- - + + + Added: trunk/docs/website/screenshots.html ============================================================================== --- (empty file) +++ trunk/docs/website/screenshots.html Wed Mar 15 14:40:07 2006 @@ -0,0 +1,20 @@ + + + + +Screenshots coming soon...stay tuned!
+ + + + + Modified: trunk/docs/website/style.css ============================================================================== --- trunk/docs/website/style.css (original) +++ trunk/docs/website/style.css Wed Mar 15 14:40:07 2006 @@ -24,19 +24,24 @@ .footer a:link { font-weight:bold; color:#ffffff; - text-decoration:underline; } .footer a:visited { font-weight:bold; color:#ffffff; - text-decoration:underline; } -.footer a:hover { +:link.footerleft { font-weight:bold; - color:#002244; - text-decoration:underline; } + float: left; + color:#ffffff; +} + +:visited.footerleft { + font-weight:bold; + float: left; + color:#ffffff; +} .check {font-size: x-small; text-align:right;} @@ -52,3 +57,52 @@ .check a:hover { font-weight:bold; color:#000000; text-decoration:underline; } + +div.NavBar { + padding: 4px 0px 4px 0px; + float: right; + font-weight:bold; +} + +.barfirst { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +.barcenter { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +.barlast { + padding: 0px 5px 0px 5px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; +} + +:hover.barfirst { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} + +:hover.barcenter { + padding: 0px 5px 0px 5px; + margin: 0px 3px 0px 0px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} + +:hover.barlast { + padding: 0px 5px 0px 5px; + border-width: 0px 0px 0px 1px; + border-style: none none none solid; + background-color:#e4e4e4; +} From junrue at common-lisp.net Thu Mar 16 01:24:53 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 15 Mar 2006 20:24:53 -0500 (EST) Subject: [graphic-forms-cvs] r44 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060316012453.E33CE1C002@common-lisp.net> 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)) From junrue at common-lisp.net Thu Mar 16 05:17:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 16 Mar 2006 00:17:32 -0500 (EST) Subject: [graphic-forms-cvs] r45 - in trunk/src: tests/uitoolkit uitoolkit/system uitoolkit/widgets Message-ID: <20060316051732.702BB7E02C@common-lisp.net> Author: junrue Date: Thu Mar 16 00:17:31 2006 New Revision: 45 Modified: trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: replaced +style-popup+ with +style-palette+ and associated implementation; implemented +style-miniframe+ and +style-borderless+; relocated thread context cleanup function call to a more robust location Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Thu Mar 16 00:17:31 2006 @@ -33,14 +33,17 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defvar *hello-win* nil) + (defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d hellowin-events) widget time) +(defmethod gfw:event-close ((d hellowin-events) window time) (declare (ignore widget time)) + (gfi:dispose window) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignore window time rect)) + (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:+color-white+) @@ -51,17 +54,18 @@ (defun exit-fn (disp item time rect) (declare (ignorable disp item time rect)) + (gfi:dispose *hello-win*) + (setf *hello-win* nil) (gfw:shutdown 0)) (defun run-hello-world-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) + (gfw:realize *hello-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (setf (gfw:menu-bar *hello-win*) menubar) + (gfw:show *hello-win* t))) (defun run-hello-world () (gfw:startup "Hello World" #'run-hello-world-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Thu Mar 16 00:17:31 2006 @@ -33,19 +33,18 @@ (in-package #:graphic-forms.uitoolkit.tests) +(defvar *main-win* nil) + (defclass main-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d main-win-events) window time) (declare (ignore time)) + (setf *main-win* nil) (gfi:dispose window) (gfw:shutdown 0)) (defclass test-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d test-win-events) window time) - (declare (ignore time)) - (gfi:dispose window)) - (defmethod gfw:event-paint ((d test-win-events) window time gc rect) (declare (ignore time)) (setf rect (make-instance 'gfi:rectangle :location (gfi:make-point) @@ -53,36 +52,62 @@ (setf (gfg:background-color gc) gfg:+color-white+) (gfg:draw-filled-rectangle gc rect)) -(defun create-borderless-win ()) +(defclass test-mini-events (test-win-events) ()) -(defun create-miniframe-win ()) +(defmethod gfw:event-close ((d test-mini-events) window time) + (declare (ignore time)) + (gfi:dispose window)) + +(defclass test-borderless-events (test-win-events) ()) + +(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button) + (declare (ignore time point button)) + (gfi:dispose window)) -(defun create-popup-win (disp item time rect) +(defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-win-events)))) - (gfw:realize window nil :style-popup) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) + (gfw:realize window *main-win* :style-borderless) + (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) + (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) + (gfw:show window t))) + +(defun create-miniframe-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-miniframe) + (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Mini Frame") + (gfw:show window t))) + +(defun create-palette-win (disp item time rect) + (declare (ignore disp item time rect)) + (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) + (gfw:realize window *main-win* :style-palette) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) - (setf (gfw:size window) (gfi:make-size :width 75 :height 125)) - (setf (gfw:text window) "Popup") + (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) + (setf (gfw:text window) "Palette") (gfw:show window t))) (defun exit-callback (disp item time rect) (declare (ignore disp item time rect)) + (gfi:dispose *main-win*) + (setf *main-win* nil) (gfw:shutdown 0)) (defun run-windlg-internal () - (let ((menubar nil) - (window nil)) - (setf window (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize window nil :style-workspace) + (let ((menubar nil)) + (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) + (gfw:realize *main-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) - (:item "&Popup" :callback #'create-popup-win)))))) - (setf (gfw:menu-bar window) menubar) - (gfw:show window t))) + (:item "&Palette" :callback #'create-palette-win)))))) + (setf (gfw:menu-bar *main-win*) menubar) + (gfw:show *main-win* t))) (defun run-windlg () (gfw:startup "Window/Dialog Tester" #'run-windlg-internal)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Mar 16 00:17:31 2006 @@ -232,6 +232,11 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) +(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h +(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h +(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h +(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h +(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Mar 16 00:17:31 2006 @@ -75,6 +75,7 @@ msg-ptr gfs::msg) (setf (event-time (thread-context)) gfs::time) (when (zerop gm) + (dispose-thread-context) (return-from run-default-message-loop gfs::wparam)) (when (= gm -1) (warn 'gfs:win32-warning :detail "get-message failed") Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Mar 16 00:17:31 2006 @@ -49,8 +49,7 @@ (run-default-message-loop))))) (defun shutdown (exit-code) - (gfs::post-quit-message exit-code) - (dispose-thread-context)) + (gfs::post-quit-message exit-code)) (defun clear-all (w) (let ((count (gfw:item-count w))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Mar 16 00:17:31 2006 @@ -179,19 +179,28 @@ ;; pre-packaged combinations of window styles ;; - ((eq sym :style-popup) - (setf std-flags (logior gfs::+ws-popupwindow+ gfs::+ws-caption+)) - (setf ex-flags gfs::+ws-ex-toolwindow+)) - ((eq sym :style-splash) - (setf std-flags (logior gfs::+ws-overlapped+ - gfs::+ws-popup+ + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ - gfs::+ws-visible+)) - (setf ex-flags 0)) - ((eq sym :style-tool) - (setf std-flags 0) - (setf ex-flags gfs::+ws-ex-palettewindow+)) + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) ((eq sym :style-workspace) (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ @@ -266,10 +275,11 @@ (size win)))) (defmethod realize ((win window) parent &rest style) - (if (not (null parent)) - (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future (if (not (gfi:disposed-p win)) (error 'gfs:toolkit-error :detail "object already realized")) + (unless (null parent) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) (let ((tc (thread-context))) (setf (widget-in-progress tc) win) (register-workspace-window-class) @@ -277,7 +287,7 @@ (compute-style-flags win style) (create-window +workspace-window-classname+ +default-window-title+ - (cffi:null-pointer) + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) std-style ex-style)) (clear-widget-in-progress tc) From junrue at common-lisp.net Fri Mar 17 05:42:12 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 17 Mar 2006 00:42:12 -0500 (EST) Subject: [graphic-forms-cvs] r46 - in trunk: . src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060317054212.AEC2F6713D@common-lisp.net> Author: junrue Date: Fri Mar 17 00:42:11 2006 New Revision: 46 Added: trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/text-label.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: refactored window class to differentiate between top-level and panel windows; replaced realize generic function by moving native object creation into initialize-instance Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Mar 17 00:42:11 2006 @@ -107,5 +107,7 @@ (:file "menu-language") (:file "event") (:file "window") + (:file "top-level") + (:file "panel") (:file "layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Mar 17 00:42:11 2006 @@ -91,7 +91,6 @@ ;; classes and structs ;; constants - #:+button-classname+ ;; methods, functions, macros #:detail @@ -230,6 +229,8 @@ #:layout-manager #:menu #:menu-item + #:panel + #:top-level #:widget #:widget-with-items #:window @@ -423,7 +424,6 @@ #:paste #:peer #:preferred-size - #:realize #:redraw #:redrawing-p #:remove-all Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Fri Mar 17 00:42:11 2006 @@ -190,8 +190,8 @@ (let ((echo-md (make-instance 'event-tester-echo-dispatcher)) (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) - (setf *event-tester-window* (make-instance 'gfw:window :dispatcher (make-instance 'event-tester-window-events))) - (gfw:realize *event-tester-window* nil :style-workspace) + (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :dispatcher echo-md :submenu ((:item "&Open..." :dispatcher echo-md) (:item "&Save..." :disabled :dispatcher echo-md) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 17 00:42:11 2006 @@ -60,8 +60,8 @@ (defun run-hello-world-internal () (let ((menubar nil)) - (setf *hello-win* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) - (gfw:realize *hello-win* nil :style-workspace) + (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hello-win*) menubar) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Fri Mar 17 00:42:11 2006 @@ -70,9 +70,19 @@ :initarg :id :initform 0))) +(defclass test-panel (gfw:panel) ()) + +(defmethod gfw:preferred-size ((win test-panel) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (gfi:make-size :width 45 :height 45)) + +(defmethod gfw:text ((win test-panel)) + (declare (ignore win)) + "Test Panel") + (defun add-layout-tester-widget (widget-class subtype) (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) - (w (make-instance widget-class :dispatcher be))) + (w (make-instance widget-class :parent *layout-tester-win* :dispatcher be))) (cond ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) @@ -83,11 +93,10 @@ (format nil "~d ~a" (id be) +btn-text-before+)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+))))))) + (format nil "~d ~a" (id be) +btn-text-after+)))))) + (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :text-label) - (setf (toggle-fn be) #'(lambda () (format nil "~d ~a" (id be) +label-text+))))) - (gfw:realize w *layout-tester-win* subtype) - (setf (gfw:text w) (funcall (toggle-fn be))) + (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+)))) (incf *widget-counter*))) (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect) @@ -331,23 +340,26 @@ (let ((menubar nil) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) + (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel + :subtype :panel)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher :check-test-fn #'gfw:visible-p))) - (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) - :layout (make-instance 'gfw:flow-layout - :spacing +spacing-delta+ - :margins +margin-delta+))) - (gfw:realize *layout-tester-win* nil :style-workspace) + (setf *layout-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'layout-tester-events) + :style '(:style-workspace) + :layout (make-instance 'gfw:flow-layout + :spacing +spacing-delta+ + :margins +margin-delta+))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) - (:item "Label" :dispatcher add-text-label-disp))) + (:item "Label" :dispatcher add-text-label-disp) + (:item "Panel" :dispatcher add-panel-disp))) (:item "Remove" :dispatcher rem-menu-disp :submenu ((:item ""))) (:item "Visible" :dispatcher vis-menu-disp Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Mar 17 00:42:11 2006 @@ -57,7 +57,7 @@ :initarg :min-size :initform (gfi:make-size)))) -(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys) +(defmethod initialize-instance :after ((widget mock-widget) &key) (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) (defmethod gfw:minimum-size ((widget mock-widget)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 17 00:42:11 2006 @@ -66,16 +66,18 @@ (defun create-borderless-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-borderless-events)))) - (gfw:realize window *main-win* :style-borderless) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) + :owner *main-win* + :style '(:style-borderless)))) (setf (gfw:location window) (gfi:make-point :x 400 :y 250)) (setf (gfw:size window) (gfi:make-size :width 300 :height 250)) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) - (gfw:realize window *main-win* :style-miniframe) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) + :owner *main-win* + :style '(:style-miniframe)))) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) (setf (gfw:text window) "Mini Frame") @@ -83,8 +85,9 @@ (defun create-palette-win (disp item time rect) (declare (ignore disp item time rect)) - (let ((window (make-instance 'gfw:window :dispatcher (make-instance 'test-mini-events)))) - (gfw:realize window *main-win* :style-palette) + (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events) + :owner *main-win* + :style '(:style-palette)))) (setf (gfw:location window) (gfi:make-point :x 250 :y 150)) (setf (gfw:size window) (gfi:make-size :width 150 :height 225)) (setf (gfw:text window) "Palette") @@ -98,8 +101,8 @@ (defun run-windlg-internal () (let ((menubar nil)) - (setf *main-win* (make-instance 'gfw:window :dispatcher (make-instance 'main-win-events))) - (gfw:realize *main-win* nil :style-workspace) + (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) + :style '(:style-workspace))) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-callback))) (:item "&Windows" Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 17 00:42:11 2006 @@ -232,11 +232,6 @@ (defconstant +mfs-disabled+ #x00000003) (defconstant +mfs-checked+ #x00000008) (defconstant +mfs-hilite+ #x00000080) -(defconstant +mfs-syncactive+ #x00000100) ; mini-frame style from afxwin.h -(defconstant +mfs-4thickframe+ #x00000200) ; mini-frame style from afxwin.h -(defconstant +mfs-thickframe+ #x00000400) ; mini-frame style from afxwin.h -(defconstant +mfs-moveframe+ #x00000800) ; mini-frame style from afxwin.h -(defconstant +mfs-blocksysmenu+ #x00001000) ; mini-frame style from afxwin.h (defconstant +mfs-enabled+ #x00000000) (defconstant +mfs-unchecked+ #x00000000) (defconstant +mfs-unhilite+ #x00000000) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Mar 17 00:42:11 2006 @@ -61,6 +61,21 @@ (setf std-flags gfs::+bs-pushbox+)))) (values std-flags ex-flags))) +(defmethod initialize-instance :after ((btn button) &key parent style &allow-other-keys) + (if (not (listp style)) + (setf style (list style))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags btn style) + (let ((hwnd (create-window gfs::+button-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value btn 'gfi:handle) hwnd))) + (init-control btn)) + (defmethod preferred-size ((btn button) width-hint height-hint) (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) (if (>= width-hint 0) @@ -71,18 +86,6 @@ (setf (gfi:size-height sz) (+ (gfi:size-height sz) 10))) sz)) -(defmethod realize ((btn button) parent &rest style) - (multiple-value-bind (std-style ex-style) - (compute-style-flags btn style) - (let ((hwnd (create-window gfs:+button-classname+ - " " - (gfi:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) - ex-style))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value btn 'gfi:handle) hwnd)))) - (defmethod text ((btn button)) (get-widget-text btn)) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Mar 17 00:42:11 2006 @@ -34,30 +34,30 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; -;;; methods +;;; helper functions ;;; -(defmethod preferred-size :before ((ctl control) width-hint height-hint) - (declare (ignorable width-hint height-hint)) - (if (gfi:disposed-p ctl) - (error 'gfi:disposed-error))) - -(defmethod realize :before ((ctl control) parent &rest style) - (declare (ignore style)) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error)) - (if (not (gfi:disposed-p ctl)) - (error 'gfs:toolkit-error :detail "object already realized"))) - -(defmethod realize :after ((ctl control) parent &rest style) - (declare (ignorable parent style)) - (let ((hwnd (gfi:handle ctl))) +(defun init-control (ctrl) + (let ((hwnd (gfi:handle ctrl))) (subclass-wndproc hwnd) - (put-widget (thread-context) ctl) + (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfi:null-handle-p hfont) (unless (zerop (gfs::send-message hwnd - gfs::+wm-setfont+ - (cffi:pointer-address hfont) - 0)) + gfs::+wm-setfont+ + (cffi:pointer-address hfont) + 0)) (error 'gfs:win32-error :detail "send-message failed")))))) + +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error))) + +(defmethod preferred-size :before ((ctrl control) width-hint height-hint) + (declare (ignorable width-hint height-hint)) + (if (gfi:disposed-p ctrl) + (error 'gfi:disposed-error))) Added: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 17 00:42:11 2006 @@ -0,0 +1,71 @@ +;;;; +;;;; panel.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +(defconstant +panel-window-classname+ "GraphicFormsPanel") + +;;; +;;; helper functions +;;; + +(defun register-panel-window-class () + (register-window-class +panel-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + gfs::+color-btnface+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((win panel) &rest style) + (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) + (ex-flags 0)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; + ((eq sym :style-border) + (setf std-flags (logior std-flags gfs::+ws-border+))))) + (flatten style)) + (values std-flags ex-flags))) + +(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) + (if (null parent) + (error 'gfs:toolkit-error :detail "parent is required for panel")) + (if (gfi:disposed-p parent) + (error 'gfi:disposed-error)) + (if (not (listp style)) + (setf style (list style))) + (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/text-label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/text-label.lisp Fri Mar 17 00:42:11 2006 @@ -72,6 +72,22 @@ (setf std-flags (logior std-flags gfs::+ss-left+))))) (values std-flags ex-flags))) +(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys) + (if (not (listp style)) + (setf style (list style))) + (multiple-value-bind (std-style ex-style) + (compute-style-flags label style) + (let ((hwnd (create-window gfs::+static-classname+ + " " + (gfi:handle parent) + (logior std-style gfs::+ws-child+ gfs::+ws-visible+) + ex-style))) + (if (not hwnd) + (error 'gfs:win32-error :detail "create-window failed")) + (setf (slot-value label 'gfi:handle) hwnd))) + (init-control label)) + + (defmethod preferred-size ((label text-label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) @@ -90,18 +106,6 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod realize ((label text-label) parent &rest style) - (multiple-value-bind (std-style ex-style) - (compute-style-flags label style) - (let ((hwnd (create-window gfs::+static-classname+ - " " - (gfi:handle parent) - (logior std-style gfs::+ws-child+ gfs::+ws-visible+) - ex-style))) - (if (not hwnd) - (error 'gfs:win32-error :detail "create-window failed")) - (setf (slot-value label 'gfi:handle) hwnd)))) - (defmethod text ((label text-label)) (get-widget-text label)) Added: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/top-level.lisp Fri Mar 17 00:42:11 2006 @@ -0,0 +1,172 @@ +;;;; +;;;; top-level.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +(defconstant +toplevel-window-classname+ "GraphicFormsTopLevel") + +(defconstant +default-window-title+ "New Window") + +;;; +;;; helper functions +;;; + +(defun register-toplevel-window-class () + (register-window-class +toplevel-window-classname+ + (cffi:get-callback 'uit_widgets_wndproc) + gfs::+cs-dblclks+ + gfs::+color-appworkspace+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((win top-level) &rest style) + (declare (ignore win)) + (let ((std-flags 0) + (ex-flags 0)) + (mapc #'(lambda (sym) + (cond + ;; styles that can be combined + ;; +#| + ((eq sym :style-hscroll) + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + ((eq sym :style-max) + (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + ((eq sym :style-min) + (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + ((eq sym :style-resize) + (setf std-flags (logior std-flags gfs::+ws-thickframe+))) + ((eq sym :style-sysmenu) + (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + ((eq sym :style-title) + (setf std-flags (logior std-flags gfs::+ws-caption+))) + ((eq sym :style-top) + (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) + ((eq sym :style-vscroll) + (setf std-flags (logior std-flags gfs::+ws-vscroll+))) +|# + + ;; pre-packaged combinations of window styles + ;; + ((eq sym :style-borderless) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-border+ + gfs::+ws-popup+)) + (setf ex-flags gfs::+ws-ex-topmost+)) + ((eq sym :style-palette) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popupwindow+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-toolwindow+ + gfs::+ws-ex-windowedge+))) + ((eq sym :style-miniframe) + (setf std-flags (logior gfs::+ws-clipchildren+ + gfs::+ws-clipsiblings+ + gfs::+ws-popup+ + gfs::+ws-thickframe+ + gfs::+ws-sysmenu+ + gfs::+ws-caption+)) + (setf ex-flags (logior gfs::+ws-ex-appwindow+ + gfs::+ws-ex-toolwindow+))) + ((eq sym :style-workspace) + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)))) + (flatten style)) + (values std-flags ex-flags))) + +(defmethod gfi:dispose ((win top-level)) + (let ((m (menu-bar win))) + (unless (null m) + (visit-menu-tree m #'menu-cleanup-callback) + (remove-widget (thread-context) (gfi:handle m)))) + (call-next-method)) + +(defmethod initialize-instance :after ((win top-level) &key owner style title &allow-other-keys) + (unless (null owner) + (if (gfi:disposed-p owner) + (error 'gfi:disposed-error))) + (if (null title) + (setf title +default-window-title+)) + (if (not (listp style)) + (setf style (list style))) + (init-window win +toplevel-window-classname+ #'register-toplevel-window-class style owner title)) + +(defmethod menu-bar :before ((win top-level)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod menu-bar ((win top-level)) + (let ((hmenu (gfs::get-menu (gfi:handle win)))) + (if (gfi:null-handle-p hmenu) + (return-from menu-bar nil)) + (let ((m (get-widget (thread-context) hmenu))) + (if (null m) + (error 'gfs:toolkit-error :detail "no object for menu handle")) + m))) + +(defmethod (setf menu-bar) :before ((m menu) (win top-level)) + (declare (ignore m)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod (setf menu-bar) ((m menu) (win top-level)) + (let* ((hwnd (gfi:handle win)) + (hmenu (gfs::get-menu hwnd)) + (old-menu (get-widget (thread-context) hmenu))) + (unless (gfi:null-handle-p hmenu) + (gfs::destroy-menu hmenu)) + (unless (null old-menu) + (gfi:dispose old-menu)) + (gfs::set-menu hwnd (gfi:handle m)) + (gfs::draw-menu-bar hwnd))) + +(defmethod text :before ((win top-level)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod text ((win top-level)) + (get-widget-text win)) + +(defmethod (setf text) :before (str (win top-level)) + (declare (ignore str)) + (if (gfi:disposed-p win) + (error 'gfi:disposed-error))) + +(defmethod (setf text) (str (win top-level)) + (set-widget-text win str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 17 00:42:11 2006 @@ -60,7 +60,7 @@ (:documentation "The caret class provides an i-beam typically representing an insertion point.")) (defclass control (widget) () - (:documentation "The base class for widgets that process user input and/or display items.")) + (:documentation "The base class for widgets having pre-defined native behavior.")) (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) @@ -76,7 +76,7 @@ :accessor items ;; FIXME: allow subclasses to set initial size? :initform (make-array 7 :fill-pointer 0 :adjustable t))) - (:documentation "The widget-with-items class is the base class for objects composed of fine-grained items.")) + (:documentation "The widget-with-items class is the base class for objects composed of sub-items.")) (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus).")) @@ -89,4 +89,10 @@ :accessor layout-of :initarg :layout :initform nil)) - (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows).")) + (:documentation "Base class for user-defined widgets that serve as containers.")) + +(defclass panel (window) () + (:documentation "Base class for windows that are children of top-level windows (or other panels).")) + +(defclass top-level (window) () + (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 17 00:42:11 2006 @@ -255,9 +255,6 @@ (defgeneric preferred-size (object width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) -(defgeneric realize (object parent &rest style) - (:documentation "Realizes the object on the screen.")) - (defgeneric redraw (object) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 17 00:42:11 2006 @@ -179,6 +179,10 @@ (declare (ignore w)) nil) +(defmethod size :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod size ((w widget)) (client-size w)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 17 00:42:11 2006 @@ -33,14 +33,27 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow") - -(defconstant +default-window-title+ "New Window") - ;;; ;;; helper functions ;;; +(defun init-window (win classname register-class-fn style parent text) + (let ((tc (thread-context))) + (setf (widget-in-progress tc) win) + (funcall register-class-fn) + (multiple-value-bind (std-style ex-style) + (compute-style-flags win style) + (create-window classname + text + (if (null parent) (cffi:null-pointer) (gfi:handle parent)) + std-style + ex-style)) + (clear-widget-in-progress tc) + (let ((hwnd (gfi:handle win))) + (if (not hwnd) ; handle slot should have been set during create-window + (error 'gfs:win32-error :detail "create-window failed")) + (put-widget tc win)))) + #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -85,7 +98,7 @@ (pop-child-visitor-func tc))) nil) -(defun register-window-class (class-name proc-ptr st) +(defun register-window-class (class-name proc-ptr style bkgcolor) (let ((retval 0)) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -100,7 +113,7 @@ str-ptr wc-ptr)) (progn (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) - (setf gfs::style st) + (setf gfs::style style) (setf gfs::wndproc proc-ptr) (setf gfs::clsextra 0) (setf gfs::wndextra 0) @@ -111,7 +124,7 @@ gfs::+image-cursor+ 0 0 (logior gfs::+lr-defaultcolor+ gfs::+lr-shared+))) - (setf gfs::hbrush (cffi:make-pointer (1+ gfs::+color-appworkspace+))) + (setf gfs::hbrush (cffi:make-pointer (1+ bkgcolor))) (setf gfs::menuname (cffi:null-pointer)) (setf gfs::classname str-ptr) (setf gfs::smallicon (cffi:null-pointer)) @@ -130,16 +143,13 @@ (setf ,var (reverse ,var)) , at body))) -(defun register-workspace-window-class () - (register-window-class +workspace-window-classname+ - (cffi:get-callback 'uit_widgets_wndproc) - (logior gfs::+cs-hredraw+ gfs::+cs-vredraw+))) - ;;; ;;; methods ;;; (defmethod compute-outer-size ((win window) desired-client-size) + ;; TODO: consider reimplementing this with AdjustWindowRect + ;; (let ((client-sz (client-size win)) (outer-sz (size win)) (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) @@ -150,72 +160,6 @@ (gfi:size-height client-sz))) trim-sz)) -(defmethod compute-style-flags ((win window) &rest style) - (declare (ignore win)) - (let ((std-flags 0) - (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; - ((eq sym :style-hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) -#| - ((eq sym :style-max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :style-min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :style-resize) - (setf std-flags (logior std-flags gfs::+ws-thickframe+))) - ((eq sym :style-sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :style-title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :style-top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# - ((eq sym :style-vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :style-borderless) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-border+ - gfs::+ws-popup+)) - (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :style-palette) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-popupwindow+ - gfs::+ws-caption+)) - (setf ex-flags (logior gfs::+ws-ex-toolwindow+ - gfs::+ws-ex-windowedge+))) - ((eq sym :style-miniframe) - (setf std-flags (logior gfs::+ws-clipchildren+ - gfs::+ws-clipsiblings+ - gfs::+ws-popup+ - gfs::+ws-thickframe+ - gfs::+ws-sysmenu+ - gfs::+ws-caption+)) - (setf ex-flags (logior gfs::+ws-ex-appwindow+ - gfs::+ws-ex-toolwindow+))) - ((eq sym :style-workspace) - (setf std-flags (logior gfs::+ws-overlappedwindow+ - gfs::+ws-clipsiblings+ - gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (flatten style)) - (values std-flags ex-flags))) - -(defmethod gfi:dispose ((win window)) - (let ((m (menu-bar win))) - (unless (null m) - (visit-menu-tree m #'menu-cleanup-callback) - (remove-widget (thread-context) (gfi:handle m)))) - (call-next-method)) - (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) (if (gfi:disposed-p win) @@ -232,37 +176,17 @@ (let ((sz (client-size win))) (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) -(defmethod location ((w window)) - (if (gfi:disposed-p w) +(defmethod location ((win window)) + (if (gfi:disposed-p win) (error 'gfi:disposed-error)) (let ((pnt (gfi:make-point))) - (outer-location w pnt) + (outer-location win pnt) pnt)) (defmethod layout ((win window)) (let ((sz (client-size win))) (perform-layout win (gfi:size-width sz) (gfi:size-height sz)))) -(defmethod menu-bar ((win window)) - (let ((hmenu (gfs::get-menu (gfi:handle win)))) - (if (gfi:null-handle-p hmenu) - (return-from menu-bar nil)) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no object for menu handle")) - m))) - -(defmethod (setf menu-bar) ((m menu) (win window)) - (let* ((hwnd (gfi:handle win)) - (hmenu (gfs::get-menu hwnd)) - (old-menu (get-widget (thread-context) hmenu))) - (unless (gfi:null-handle-p hmenu) - (gfs::destroy-menu hmenu)) - (unless (null old-menu) - (gfi:dispose old-menu)) - (gfs::set-menu hwnd (gfi:handle m)) - (gfs::draw-menu-bar hwnd))) - (defmethod pack ((win window)) (perform-layout win -1 -1) (call-next-method)) @@ -274,42 +198,12 @@ (compute-outer-size win new-client-sz)) (size win)))) -(defmethod realize ((win window) parent &rest style) - (if (not (gfi:disposed-p win)) - (error 'gfs:toolkit-error :detail "object already realized")) - (unless (null parent) - (if (gfi:disposed-p parent) - (error 'gfi:disposed-error))) - (let ((tc (thread-context))) - (setf (widget-in-progress tc) win) - (register-workspace-window-class) - (multiple-value-bind (std-style ex-style) - (compute-style-flags win style) - (create-window +workspace-window-classname+ - +default-window-title+ - (if (null parent) (cffi:null-pointer) (gfi:handle parent)) - std-style - ex-style)) - (clear-widget-in-progress tc) - (let ((hwnd (gfi:handle win))) - (if (not hwnd) ; handle slot should have been set during create-window - (error 'gfs:win32-error :detail "create-window failed")) - (put-widget tc win)))) - (defmethod show ((win window) flag) (declare (ignore flag)) (call-next-method) (gfs::update-window (gfi:handle win))) (defmethod size ((win window)) - (if (gfi:disposed-p win) - (error 'gfi:disposed-error)) (let ((sz (gfi:make-size))) (outer-size win sz) sz)) - -(defmethod text ((win window)) - (get-widget-text win)) - -(defmethod (setf text) (str (win window)) - (set-widget-text win str)) From junrue at common-lisp.net Sat Mar 18 19:17:32 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 18 Mar 2006 14:17:32 -0500 (EST) Subject: [graphic-forms-cvs] r47 - trunk/docs/website Message-ID: <20060318191732.E1F5B77015@common-lisp.net> Author: junrue Date: Sat Mar 18 14:17:32 2006 New Revision: 47 Added: trunk/docs/website/sourceforge.html Modified: trunk/docs/website/docs.html trunk/docs/website/download.html trunk/docs/website/index.html trunk/docs/website/screenshots.html Log: updated for newly-created SourceForge project Modified: trunk/docs/website/docs.html ============================================================================== --- trunk/docs/website/docs.html (original) +++ trunk/docs/website/docs.html Sat Mar 18 14:17:32 2006 @@ -3,12 +3,16 @@Graphic-Forms is distributed in source code form. Please choose from one of the following options:
Graphic-Forms is a user interface library implemented in - Common Lisp focusing on the - Windows® platform. Graphic-Forms is licensed under the - terms of the - BSD License.
+Graphic-Forms is a user interface library implemented in + Common Lisp focusing on the + Windows® platform. Graphic-Forms is licensed under the + terms of the + BSD License.
In the near term, the goal is to provide a toolkit encapsulating the underlying Modified: trunk/docs/website/screenshots.html ============================================================================== --- trunk/docs/website/screenshots.html (original) +++ trunk/docs/website/screenshots.html Sat Mar 18 14:17:32 2006 @@ -3,12 +3,16 @@
Screenshots coming soon...stay tuned!
From junrue at common-lisp.net Sun Mar 19 17:42:21 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 19 Mar 2006 12:42:21 -0500 (EST) Subject: [graphic-forms-cvs] r50 - in trunk: . src src/intrinsics/system src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060319174221.B3C654006@common-lisp.net> Author: junrue Date: Sun Mar 19 12:42:18 2006 New Revision: 50 Added: trunk/src/intrinsics/system/clib.lisp trunk/src/tests/uitoolkit/blackwhite20x16.bmp (contents, props changed) trunk/src/tests/uitoolkit/happy.bmp (contents, props changed) trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/image-unit-tests.lisp trunk/src/tests/uitoolkit/truecolor16x16.bmp (contents, props changed) trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp Removed: trunk/src/uitoolkit/graphics/file-formats.lisp Modified: trunk/build.lisp trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/palette.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/tests.lisp Log: integrated ImageMagick and got rid of home-grown bmp parsing; fixed bugs in data->image and draw-image in order for image-tester to partially work -- bitmap transparency is next Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Mar 19 12:42:18 2006 @@ -39,20 +39,22 @@ (defvar *external-build-dirs* nil) -(defvar *library-root* "c:/projects/third_party/") -(defvar *project-root* "c:/projects/public/") +(defvar *library-root* "c:/projects/third_party/") +(defvar *project-root* "c:/projects/public/") -(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) +(defvar *asdf-root* (concatenate 'string *library-root* "asdf-repo/")) -(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) -(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) -(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) -(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) -(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) - -(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") -(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *cffi-dir* (concatenate 'string *asdf-root* "cffi-0.9.0/")) +(defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) +(defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") +(defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) +(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) +(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) + +(defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) +(defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") +(defvar *gf-doc-dir* (concatenate 'string *gf-build-dir* "docs/")) +(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defvar *asdf-dirs* (list *cffi-dir* *closer-mop-dir* @@ -99,10 +101,6 @@ (asdf:operate 'asdf:load-op :closer-mop) (if *external-build-dirs* - (chdir *cffi-build-dir*)) - (asdf:operate 'asdf:load-op :cffi) - - (if *external-build-dirs* (chdir *pcl-ch08-build-dir*)) (asdf:operate 'asdf:load-op :macro-utilities) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 19 12:42:18 2006 @@ -50,8 +50,10 @@ ((:module "uitoolkit" :components ((:file "mock-objects") + (:file "image-unit-tests") (:file "layout-unit-tests") (:file "hello-world") (:file "event-tester") (:file "layout-tester") + (:file "image-tester") (:file "windlg"))))))))) Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 19 12:42:18 2006 @@ -58,6 +58,7 @@ ((:file "native-classes") (:file "native-conditions") (:file "native-object-generics") + (:file "clib") (:file "native-object"))))) (:module "uitoolkit" :depends-on ("intrinsics") @@ -74,11 +75,12 @@ (:module "graphics" :depends-on ("system") :components - ((:file "graphics-classes") + ((:file "magick-core-types") + (:file "magick-core-api") + (:file "graphics-classes") (:file "graphics-generics") (:file "color") (:file "palette") - (:file "file-formats") (:file "image-data") (:file "image") (:file "font") Added: trunk/src/intrinsics/system/clib.lisp ============================================================================== --- (empty file) +++ trunk/src/intrinsics/system/clib.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; clib.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.intrinsics) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(defcfun + ("strncpy" strncpy) + :pointer + (dest :pointer) + (src :pointer) + (count :unsigned-int)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 12:42:18 2006 @@ -136,7 +136,6 @@ #:average-char-width #:background-color #:background-pattern - #:bits-per-pixel #:blue-mask #:blue-shift #:clipped-p @@ -148,9 +147,8 @@ #:color-table #:copy-area #:data-obj + #:depth #:descent - #:direct - #:direct-p #:draw-arc #:draw-filled-arc #:draw-filled-oval @@ -174,8 +172,6 @@ #:green-mask #:green-shift #:height - #:image-data-type - #:image-palette #:invert #:leading #:line-cap-style @@ -183,18 +179,14 @@ #:line-join-style #:line-style #:line-width + #:load #:make-color - #:make-image-data - #:make-palette #:matrix #:maximum-char-width #:metrics #:multiply - #:pixel-color - #:pixels #:red-mask #:red-shift - #:register-image-loader #:rotate #:scale #:size Added: trunk/src/tests/uitoolkit/blackwhite20x16.bmp ============================================================================== Binary file. No diff available. Added: trunk/src/tests/uitoolkit/happy.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Sun Mar 19 12:42:18 2006 @@ -38,7 +38,7 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((d hellowin-events) window time) - (declare (ignore widget time)) + (declare (ignore time)) (gfi:dispose window) (gfw:shutdown 0)) Added: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,86 @@ +;;;; +;;;; image-tester.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) + +(defvar *image-win* nil) +(defvar *happy-image* nil) +(defvar *bw-image* nil) +(defvar *true-image* nil) + +(defclass image-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (gfi:dispose *happy-image*) + (setf *happy-image* nil) + (gfi:dispose *bw-image*) + (setf *bw-image* nil) + (gfi:dispose *true-image*) + (setf *true-image* nil) + (gfi:dispose *image-win*) + (setf *image-win* nil) + (gfw:shutdown 0)) + +(defmethod gfw:event-paint ((d image-events) window time gc rect) + (declare (ignore window time rect)) + (let ((pnt (gfi:make-point))) + (gfg:draw-image gc *happy-image* pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *bw-image* pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *true-image* pnt))) + +(defun exit-image-fn (disp item time rect) + (declare (ignorable disp item time rect)) + (gfi:dispose *image-win*) + (setf *image-win* nil) + (gfw:shutdown 0)) + +(defun run-image-tester-internal () + (let ((menubar nil)) + (setf *happy-image* (make-instance 'gfg:image)) + (setf *bw-image* (make-instance 'gfg:image)) + (setf *true-image* (make-instance 'gfg:image)) + (gfg::load *happy-image* "happy.bmp") + (gfg::load *bw-image* "blackwhite20x16.bmp") + (gfg::load *true-image* "truecolor16x16.bmp") + (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) + :style '(:style-workspace))) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) + (setf (gfw:menu-bar *image-win*) menubar) + (gfw:show *image-win* t))) + +(defun run-image-tester () + (gfw:startup "Image Tester" #'run-image-tester-internal)) Added: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,73 @@ +;;;; +;;;; image-unit-tests.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) + +(defun image-data-tester (path) + (let ((d1 (make-instance 'gfg:image-data)) + (d2 nil) + (d3 nil) + (im (make-instance 'gfg:image)) + (hbmp (cffi:null-pointer))) + (unwind-protect + (progn + (gfg:load d1 path) + (cffi:with-foreign-string (ptr path) + (setf hbmp (gfs::load-image nil + ptr + gfs::+image-bitmap+ + 0 0 + (logior gfs::+lr-loadfromfile+ + gfs::+lr-createdibsection+)))) + (if (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "load-image failed")) + (setf d2 (gfg::image->data hbmp)) + (assert-equal (gfg:depth d1) (gfg:depth d2) path) + (let ((size1 (gfg:size d1)) + (size2 (gfg:size d2))) + (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) + (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (gfg:load im path) + (setf d3 (gfg:data-obj im)) + (assert-equal (gfg:depth d1) (gfg:depth d3) path) + (let ((size1 (gfg:size d1)) + (size2 (gfg:size d3))) + (assert-equal (gfi:size-width size1) (gfi:size-width size2) path) + (assert-equal (gfi:size-height size1) (gfi:size-height size2) path)) + (unless (gfi:disposed-p im) + (gfi:dispose im)) + (unless (gfi:null-handle-p hbmp) + (gfs::delete-object hbmp)))))) + +(define-test image-data-loading-test + (mapc #'image-data-tester '("blackwhite20x16.bmp" "happy.bmp" "truecolor16x16.bmp"))) Added: trunk/src/tests/uitoolkit/truecolor16x16.bmp ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 19 12:42:18 2006 @@ -37,61 +37,47 @@ (defstruct color (red 0) (green 0) - (blue 0))) + (blue 0)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defstruct font-metrics (ascent 0) (descent 0) (leading 0) (avg-char-width 0) - (max-char-width 0))) + (max-char-width 0)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro ascent (metrics) - `(gfg::font-metrics-ascent ,metrics))) + `(gfg::font-metrics-ascent ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro descent (metrics) - `(gfg::font-metrics-descent ,metrics))) + `(gfg::font-metrics-descent ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro leading (metrics) - `(gfg::font-metrics-leading ,metrics))) + `(gfg::font-metrics-leading ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro height (metrics) `(+ (gfg::font-metrics-ascent ,metrics) (gfg::font-metrics-descent ,metrics) - (gfg::font-metrics-leading ,metrics)))) + (gfg::font-metrics-leading ,metrics))) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro average-char-width (metrics) - `(gfg::font-metrics-avg-char-width ,metrics))) + `(gfg::font-metrics-avg-char-width ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro maximum-char-width (metrics) - `(gfg::font-metrics-max-char-width ,metrics))) + `(gfg::font-metrics-max-char-width ,metrics)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct image-data - (pixels nil) ; vector of bytes - (bits-per-pixel 0) ; number of bits per pixel - (palette nil) ; palette - (size (gfi:make-size)) ; width and height of image in pixels - (type 'bmp))) ; symbol corresponding to file extension (e.g., 'bmp) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro bits-per-pixel (data) - `(gfg::image-data-bits-per-pixel ,data))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro image-palette (data) - `(gfg::image-data-palette ,data))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro pixels (data) - `(gfg::image-data-pixels ,data))) + (defstruct palette + (red-mask 0) + (green-mask 0) + (blue-mask 0) + (red-shift 0) + (green-shift 0) + (blue-shift 0) + (direct nil) + (table nil))) ; vector of COLOR structs + +(defclass image-data (gfi:native-object) () + (:documentation "This class maintains image attributes, color, and pixel data.")) (defclass font (gfi:native-object) () (:documentation "This class encapsulates a realized native font.")) @@ -106,17 +92,6 @@ :initform (make-color))) (:documentation "This class represents an image of a particular type (BMP, PNG, etc.).")) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defstruct palette - (red-mask 0) - (green-mask 0) - (blue-mask 0) - (red-shift 0) - (green-shift 0) - (blue-shift 0) - (direct nil) - (table nil))) ; vector of COLOR structs - (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) @@ -126,10 +101,6 @@ (defmacro direct (data flag) `(setf (gfg::palette-direct ,data) ,flag)) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro direct-p (data) - `(null (gfg::palette-direct ,data)))) - (defmacro green-mask (data) `(gfg::palette-green-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 19 12:42:18 2006 @@ -90,20 +90,20 @@ ;; TODO: support addressing elements within bitmap as if it were an array ;; (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - oldhbm) + (oldhbm (cffi:null-pointer))) (if (gfi:null-handle-p memdc) (error 'gfs:win32-error :detail "create-compatible-dc failed")) (setf oldhbm (gfs::select-object memdc (gfi:handle im))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (gfs::bit-blt (gfi:handle gc) - (gfi:point-x pnt) - (gfi:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) - memdc - 0 0 - gfs::+blt-srccopy+)) + (gfi:point-x pnt) + (gfi:point-y pnt) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) + (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) + memdc + 0 0 + gfs::+blt-srccopy+)) (gfs::select-object memdc oldhbm) (gfs::delete-dc memdc))) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 19 12:42:18 2006 @@ -57,6 +57,9 @@ (defgeneric data-obj (object) (:documentation "Returns the data structure representing the raw form of the object.")) +(defgeneric depth (object) + (:documentation "Returns the bits-per-pixel depth of the object.")) + (defgeneric draw-arc (object rect start-angle arc-angle) (:documentation "Draws the outline of a circular or elliptical arc within the specified rectangular area.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sun Mar 19 12:42:18 2006 @@ -33,110 +33,12 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defvar *loaders-by-type* (make-hash-table :test #'equal)) - -;;; -;;; image loader functions -;;; - -(defmacro bmp-pixel-row-length (im-width im-bit-count) - `(ash (logand (+ (* ,im-width ,im-bit-count) 31) (lognot 31)) -3)) - -(defun bmp-loader (path victim) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (let ((header (read-value 'BITMAPFILEHEADER in)) - (info (read-value 'BASE-BITMAPINFOHEADER in)) - (pix-bits nil)) - (declare (ignore header)) - (unless (= (biCompression info) gfs::+bi-rgb+) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) - - ;; load color table - ;; - (let ((used (biClrUsed info)) - (rgbs nil)) - (ecase (biBitCount info) - (1 - (setf rgbs (make-array 2))) - (4 - (if (or (= used 0) (= used 16)) - (setf rgbs (make-array 16)) - (setf rgbs (make-array used)))) - (8 - (if (or (= used 0) (= used 256)) - (setf rgbs (make-array 256)) - (setf rgbs (make-array used)))) - (16 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (24 - (unless (/= used 0) - (setf rgbs (make-array used)))) - (32 - (unless (/= used 0) - (setf rgbs (make-array used))))) - (dotimes (i (length rgbs)) - (let ((quad (read-value 'RGBQUAD in))) - (setf (aref rgbs i) (make-color :red (rgbRed quad) - :green (rgbGreen quad) - :blue (rgbBlue quad))))) - (setf (image-data-palette victim) (make-palette :direct nil :table rgbs))) - - ;; load pixel bits - ;; - (let ((row-len (bmp-pixel-row-length (biWidth info) (biBitCount info)))) - (setf pix-bits (make-array (* row-len (biHeight info)) :element-type '(unsigned-byte 8))) - (read-sequence pix-bits in)) - - ;; populate and return image-data object - ;; - (setf (image-data-pixels victim) pix-bits) - (setf (image-data-bits-per-pixel victim) (biBitCount info)) - (setf (size victim) (gfi:make-size :width (biWidth info) :height (biHeight info))) - (setf (image-data-type victim) 'bmp) - victim))) - -#| -(define-binary-type raw-data (size width) - (:reader (in) - (let ((buf (make-array size :element-type '(unsigned-byte width)))) - (read-sequence buf in) - buf)) - (:writer (out) - (write-sequence buf out))) -|# - -#| -(defun bmp-loader (path) - (let (hwnd) - (cffi:with-foreign-string (ptr (namestring path)) - (setf hwnd (gfs::load-image nil - ptr - gfs::+image-bitmap+ - 0 0 - gfs::+lr-loadfromfile+))) - (if (gfi:null-handle-p hwnd) - (error 'gfs:win32-error :detail "load-image failed")) - hwnd)) -|# - -(setf (gethash "bmp" *loaders-by-type*) #'bmp-loader) - ;;; ;;; helper functions ;;; -(defun register-image-loader (file-type loader-fn) - "Associate a new (or replacement) loader function with the specified file type. \ -Returns the previous loader function, if any." - (unless (typep file-type 'string) - (error 'gfs:toolkit-error :detail "file-type must be a string")) - (unless (typep loader-fn 'function) - (error 'gfs:toolkit-error :detail "loader-fn must be a function")) - (let ((old-fn (gethash file-type *loaders-by-type*))) - (setf (gethash file-type *loaders-by-type*) loader-fn) - old-fn)) - +(defun image->data (hbmp) (declare (ignore hbmp))) +#| (defun image->data (hbmp) "Convert the native bitmap handle to an image-data." (let ((mem-dc (gfs::create-compatible-dc (cffi:null-pointer))) @@ -222,6 +124,7 @@ (cffi:foreign-free raw-bits)) (gfs::delete-dc mem-dc)) data)) +|# (defun data->image (data) "Convert the image-data object to a bitmap and return the native handle." @@ -239,20 +142,20 @@ gfs::biclrimp gfs::bmicolors) bi-ptr gfs::bitmapinfo) - (let* ((sz (size data)) - (colors (palette-table (image-palette data))) - (bit-count (bits-per-pixel data)) - (row-len (bmp-pixel-row-length (gfi:size-width sz) bit-count)) - (byte-count (* row-len (gfi:size-height sz))) - (data-bits (pixels data)) - (pix-bits (cffi:null-pointer)) + (let* ((handle (gfi:handle data)) + (sz (size data)) + (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) + (bit-count (depth data)) (hbmp (cffi:null-pointer)) - (mem-dc (gfs::create-compatible-dc (cffi:null-pointer)))) + (screen-dc (gfs::get-dc (cffi:null-pointer)))) +(format t "bi-size: ~a~%" (cffi:foreign-type-size 'gfs::bitmapinfoheader)) +(format t "bit-count: ~a~%" bit-count) +(format t "size: ~a ~a~%" (gfi:size-width sz) (gfi:size-height sz)) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) (setf gfs::biwidth (gfi:size-width sz)) - (setf gfs::biheight (gfi:size-height sz)) + (setf gfs::biheight (- 0 (gfi:size-height sz))) (setf gfs::biplanes 1) - (setf gfs::bibitcount bit-count) + (setf gfs::bibitcount 32) ;; 32bpp even if original image file is not (setf gfs::bicompression gfs::+bi-rgb+) (setf gfs::bisizeimage 0) (setf gfs::bixpels 0) @@ -260,73 +163,111 @@ (setf gfs::biclrused 0) (setf gfs::biclrimp 0) - (unwind-protect - (progn - - ;; populate the RGBQUADs - ;; - (dotimes (i (length colors)) - (let ((clr (aref colors i))) - (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen - gfs::rgbred gfs::rgbreserved) - (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i) - gfs::rgbquad) - (setf gfs::rgbblue (color-blue clr)) - (setf gfs::rgbgreen (color-green clr)) - (setf gfs::rgbred (color-red clr)) - (setf gfs::rgbreserved 0)))) - - ;; populate the pixel data - ;; - (setf pix-bits (cffi:foreign-alloc :unsigned-char :count byte-count)) - (dotimes (i byte-count) - (setf (cffi:mem-aref pix-bits :unsigned-char i) (aref data-bits i))) + ;; create the bitmap + ;; + (cffi:with-foreign-object (pix-bits-ptr :pointer) + (setf hbmp (gfs::create-dib-section screen-dc + bi-ptr + gfs::+dib-rgb-colors+ + pix-bits-ptr + (cffi:null-pointer) + 0)) + (if (gfi:null-handle-p hbmp) + (error 'gfs:win32-error :detail "create-dib-section failed")) - ;; create the bitmap - ;; - (setf hbmp (gfs::create-di-bitmap mem-dc - bi-ptr - 0 ; gfs::+cbm-init+ - pix-bits - bi-ptr - gfs::+dib-rgb-colors+)) - (if (gfi:null-handle-p hbmp) - (error 'gfs:win32-error :detail "create-di-bitmap failed"))) - (unless (cffi:null-pointer-p pix-bits) - (cffi:foreign-free pix-bits)) - (gfs::delete-dc mem-dc)) - hbmp)))) + ;; update the RGBQUADs + ;; + (let ((tmp (get-image-pixels handle 0 0 (gfi:size-width sz) (gfi:size-height sz))) + (ptr (cffi:mem-ref pix-bits-ptr :pointer))) + (dotimes (i pix-count) + (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved) + (cffi:mem-aref tmp 'gfg::pixel-packet i) + gfg::pixel-packet) + (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved) + (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad) + (setf gfs::rgbreserved 0) + (setf gfs::rgbred (scale-quantum-to-byte red)) + (setf gfs::rgbgreen (scale-quantum-to-byte green)) + (setf gfs::rgbblue (scale-quantum-to-byte blue)))))) + hbmp))))) ;;; ;;; methods ;;; -(defmethod load ((d image-data) path) +(defmethod depth ((data image-data)) + (let ((handle (gfi:handle data))) + (if (null handle) + (error 'gfi:disposed-error)) + (cffi:foreign-slot-value handle 'magick-image 'depth))) + +(defmethod gfi:dispose ((data image-data)) + (let ((victim (gfi:handle data))) + (if (null victim) + (error 'gfi:disposed-error)) + (destroy-image victim)) + (setf (slot-value data 'gfi:handle) nil)) + +(defmethod load ((data image-data) path) (setf path (cond - ((typep path 'pathname) path) - ((typep path 'string) - (parse-namestring path)) + ((typep path 'pathname) (namestring path)) + ((typep path 'string) path) (t (error 'gfs:toolkit-error :detail "pathname or string required")))) - (let* ((ptype (pathname-type path)) - (fn (gethash ptype *loaders-by-type*))) - (if (null fn) - (error 'gfs:toolkit-error - :detail (format nil "no loader registered for type: ~a" ptype))) - (funcall fn path d) - d)) - -(defmethod size ((obj image-data)) - (image-data-size obj)) - -(defmethod (setf size) (sz (obj image-data)) - (setf (image-data-size obj) sz)) - -(defmethod print-object ((obj image-data) stream) - (print-unreadable-object (obj stream :type t) - (format stream "type: ~a " (image-data-type obj)) - (format stream "width: ~a " (gfi:size-width (image-data-size obj))) - (format stream "height: ~a " (gfi:size-height (image-data-size obj))) - (format stream "bits per pixel: ~a " (bits-per-pixel obj)) - (format stream "pixel count: ~a " (length (pixels obj))) - (format stream "palette: ~a" (image-palette obj)))) + (let ((handle (gfi:handle data))) + (when (and (not (null handle)) (not (cffi:null-pointer-p handle))) + (destroy-image handle) + (setf (slot-value data 'gfi:handle) nil) + (setf handle nil)) + (with-image-path (path info ex) + (setf handle (read-image info ex)) + (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) + (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" + (cffi:foreign-string-to-lisp (cffi:foreign-slot-value ex 'exception-info 'reason))))) + (if (cffi:null-pointer-p handle) + (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) + (setf (slot-value data 'gfi:handle) handle)))) + +(defmethod size ((data image-data)) + (let ((handle (gfi:handle data)) + (size (gfi:make-size))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfi:disposed-error)) + (cffi:with-foreign-slots ((rows columns) handle magick-image) + (setf (gfi:size-height size) rows) + (setf (gfi:size-width size) columns)) + size)) + +(defmethod (setf size) (size (data image-data)) + (let ((handle (gfi:handle data)) + (new-handle (cffi:null-pointer)) + (ex (acquire-exception-info))) + (if (or (null handle) (cffi:null-pointer-p handle)) + (error 'gfi:disposed-error)) + (unwind-protect + (progn + (setf new-handle (resize-image handle + (gfi:size-width size) + (gfi:size-height size) + (cffi:foreign-enum-value 'filter-types :lanczos) + 1.0 ex)) + (if (gfi:null-handle-p new-handle) + (error 'gfs:toolkit-error :detail (format nil + "could not resize: ~a" + (cffi:foreign-slot-value ex + 'exception-info + 'reason)))) + (setf (slot-value data 'gfi:handle) new-handle) + (destroy-image handle)) + (destroy-exception-info ex)))) + +(defmethod print-object ((data image-data) stream) + (if (or (null (gfi:handle data)) (cffi:null-pointer-p (gfi:handle data))) + (error 'gfi:disposed-error)) + (let ((size (size data))) + (print-unreadable-object (data stream :type t) + ;; FIXME: dump palette info, too + ;; + (format stream "width: ~a " (gfi:size-width size)) + (format stream "height: ~a " (gfi:size-height size)) + (format stream "bits per pixel: ~a " (depth data))))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 12:42:18 2006 @@ -59,13 +59,7 @@ (setf (slot-value im 'gfi:handle) (data->image id))) (defmethod load ((im image) path) - (let ((data (make-image-data))) + (let ((data (make-instance 'image-data))) (load data path) (setf (data-obj im) data) data)) - -(defmethod size ((im image)) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) - -(defmethod transparency-mask ((im image)) - (error 'gfs:toolkit-error :detail "FIXME: not yet implemented")) Added: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,198 @@ +;;;; +;;;; magick-core-api.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.graphics) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi) + (pushnew gfsys::*imagemagick-dir* *foreign-library-directories*)) + +(define-foreign-library wsock32 (t (:default "wsock32"))) +(define-foreign-library msvcr71 (t (:default "msvcr71"))) +(define-foreign-library x11 (t (:default "x11"))) +(define-foreign-library core_rl_bzlib (t (:default "CORE_RL_bzlib_"))) +(define-foreign-library core_rl_jbig (t (:default "CORE_RL_jbig_"))) +(define-foreign-library core_rl_jpeg (t (:default "CORE_RL_jpeg_"))) +(define-foreign-library core_rl_lcms (t (:default "CORE_RL_lcms_"))) +(define-foreign-library core_rl_zlib (t (:default "CORE_RL_zlib_"))) +(define-foreign-library core_rl_png (t (:default "CORE_RL_png_"))) +(define-foreign-library core_rl_tiff (t (:default "CORE_RL_tiff_"))) +(define-foreign-library core_rl_ttf (t (:default "CORE_RL_ttf_"))) +(define-foreign-library core_rl_xlib (t (:default "CORE_RL_xlib_"))) +(define-foreign-library core_rl_magick (t (:default "CORE_RL_magick_"))) + +(use-foreign-library wsock32) +(use-foreign-library msvcr71) +(use-foreign-library x11) +(use-foreign-library core_rl_bzlib) +(use-foreign-library core_rl_jbig) +(use-foreign-library core_rl_jpeg) +(use-foreign-library core_rl_lcms) +(use-foreign-library core_rl_zlib) +(use-foreign-library core_rl_png) +(use-foreign-library core_rl_tiff) +(use-foreign-library core_rl_ttf) +(use-foreign-library core_rl_xlib) +(use-foreign-library core_rl_magick) + +;;; +;;; translated from constitute.h +;;; + +(defcfun + ("ConstituteImage" constitute-image) + :pointer ;; Image* + (columns :unsigned-long) + (rows :unsigned-long) + (map :pointer) ;; const char* + (storage storage-type) + (pixels :pointer) ;; void* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("PingImage" ping-image) + :pointer ;; Image* + (image-info :pointer) ;; ImageInfo* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("ReadImage" read-image) + :pointer ;; Image* + (image-info :pointer) ;; ImageInfo* + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("WriteImage" write-image) + boolean-type + (image-info :pointer) ;; ImageInfo* + (image :pointer)) ;; Image* + +;;; +;;; translated from exception.h +;;; + +(defcfun + ("AcquireExceptionInfo" acquire-exception-info) + :pointer) + +(defcfun + ("CatchException" catch-exception) + :void + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("ClearMagickException" clear-magick-exception) + :void + (exception :pointer)) ;; ExceptionInfo* + +(defcfun + ("DestroyExceptionInfo" destroy-exception-info) + :pointer ;; ExceptionInfo* + (exception :pointer)) ;; ExceptionInfo* + +;;; +;;; translated from image.h +;;; + +(defcfun + ("CloneImageInfo" clone-image-info) + :pointer ;; ImageInfo* + (orig :pointer)) ;; ImageInfo* + +(defcfun + ("DestroyImage" destroy-image) + :pointer ;; Image* + (victim :pointer)) ;; Image* + +(defcfun + ("DestroyImageInfo" destroy-image-info) + :pointer ;; ImageInfo* + (victim :pointer)) ;; ImageInfo* + +(defcfun + ("GetImagePixels" get-image-pixels) + :pointer ;; PixelPacket* + (image :pointer) ;; Image* + (x :long) + (y :long) + (width :unsigned-long) + (height :unsigned-long)) + +(defun scale-quantum-to-byte (quant) + (floor (/ quant 257))) + +;;; +;;; translated from magick.h +;;; + +(defcfun + ("DestroyMagick" destroy-magick) + :void) + +(defcfun + ("InitializeMagick" initialize-magick) + :void + (args :pointer)) ;; char* + +;;; +;;; translated from resize.h +;;; + +(defcfun + ("ResizeImage" resize-image) + :pointer ;; Image* + (orig :pointer) ;; Image* + (width :unsigned-long) + (height :unsigned-long) + (filter :int) ;; filter-type + (blur :double) + (exception :pointer)) ;; ExceptionInfo* + +;;; +;;; helper macros +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-image-path ((path info ex) &body body) + `(let ((,info (clone-image-info (cffi:null-pointer))) + (,ex (acquire-exception-info))) + (if (cffi:null-pointer-p ,info) + (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) + (unwind-protect + (cffi:with-foreign-string (str ,path) + (gfi::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) + str + (1- +magick-max-text-extent+)) + , at body)) + (destroy-image-info ,info) + (destroy-exception-info ,ex)))) Added: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 12:42:18 2006 @@ -0,0 +1,549 @@ +;;;; +;;;; magick-core-types.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.graphics) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +;;; +;;; see magick-type.h for the original C-language definitions +;;; of these types from ImageMagick Core. +;;; + +(defconstant +magick-max-text-extent+ 4096) +(defconstant +magick-signature+ #xABACADAB) + +(defconstant +undefined-channel+ #x00000000) +(defconstant +red-channel+ #x00000001) +(defconstant +gray-channel+ #x00000001) +(defconstant +cyan-channel+ #x00000001) +(defconstant +green-channel+ #x00000002) +(defconstant +magenta-channel+ #x00000002) +(defconstant +blue-channel+ #x00000004) +(defconstant +yellow-channel+ #x00000004) +(defconstant +alpha-channel+ #x00000008) +(defconstant +opacity-channel+ #x00000008) +(defconstant +matte-channel+ #x00000008) ;; deprecated +(defconstant +black-channel+ #x00000020) +(defconstant +index-channel+ #x00000020) +(defconstant +all-channels+ #x000000FF) +(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ;; (AllChannels &~ OpacityChannel) + +(defctype quantum :unsigned-short) + +(defcenum boolean-type + (:false 0) + (:true 1)) + +(defcenum class-type + :undefined + :direct + :pseudo) + +(defcenum colorspace-type + :undefined + :rgb + :gray + :transparent + :ohta + :lab + :xyz + :ycbcr + :ycc + :yiq + :ypbpr + :yuv + :cmyk + :srgb + :hsb + :hsl + :hwb + :rec601luma + :rec601ycbcr + :rec709luma + :rec709ycbcr + :log) + +(defcenum composite-operator + :undefined + :no + :add + :atop + :blend + :bump-map + :clear + :color-burn + :color-dodge + :colorize + :copy-black + :copy-blue + :copy + :copy-cyan + :copy-green + :copy-magenta + :copy-opacity + :copy-red + :copy-yellow + :darken + :dst-atop + :dst + :dst-in + :dst-out + :dst-over + :difference + :displace + :dissolve + :exclusion + :hard-light + :hue + :in + :lighten + :luminize + :minus + :modulate + :multiply + :out + :over + :overlay + :plus + :replace + :saturate + :screen + :soft-light + :src-atop + :src + :src-in + :src-out + :src-over + :subtract + :threshold + :xor-composite-op) + +(defcenum compression-type + :undefined + :no + :bzip + :fax + :group4 + :jpeg + :jpeg2000 + :lossless-jpeg + :lzw + :rle + :zip) + +(defcenum dispose-type + :unrecognized + (:undefined 0) + (:none 1) + (:background 2) + (:previous 3)) + +(defcenum endian-type + :undefined + :lsb + :msb) + +(defcenum exception-type + :undefined + (:warning 300) + (:resource-limit-warning 300) + (:type-warning 305) + (:option-warning 310) + (:delegate--warning 315) + (:missing-delegate-warning 320) + (:corrupt-image-warning 325) + (:file-open-warning 330) + (:blob-warning 335) + (:stream-warning 340) + (:cache-warning 345) + (:coder-warning 350) + (:module-warning 355) + (:draw-warning 360) + (:image-warning 365) + (:wand-warning 370) + (:xserver-warning 380) + (:monitor-warning 385) + (:registry-warning 390) + (:configure-warning 395) + (:error 400) + (:resource-limit-error 400) + (:type-error 405) + (:option-error 410) + (:delegate-error 415) + (:missing-delegate-error 420) + (:corrupt-image-error 425) + (:file-open-error 430) + (:blob-error 435) + (:stream-error 440) + (:cache-error 445) + (:coder-error 450) + (:module-error 455) + (:draw-error 460) + (:image-error 465) + (:wand-error 470) + (:xserver-error 480) + (:monitor-error 485) + (:registry-error 490) + (:configure-error 495) + (:fatal-error 700) + (:resource-limit-fatal-error 700) + (:type-fatal-error 705) + (:option-fatal-error 710) + (:delegate-fatal-error 715) + (:missing-delegate-fatal-error 720) + (:corrupt-image-fatal-error 725) + (:file-open-fatal-error 730) + (:blob-fatal-error 735) + (:stream-fatal-error 740) + (:cache-fatal-error 745) + (:coder-fatal-error 750) + (:module-fatal-error 755) + (:draw-fatal-error 760) + (:image-fatal-error 765) + (:wand-fatal-error 770) + (:xserver-fatal-error 780) + (:monitor-fatal-error 785) + (:registry-fatal-error 790) + (:configure-fatal-error 795)) + +(defcenum filter-types + :undefined + :point + :box + :triangle + :hermite + :hanning + :hamming + :blackman + :gaussian + :quadratic + :cubic + :catrom + :mitchell + :lanczos + :bessel + :sinc) + +(defcenum gravity-type + :undefined + (:forget 0) + (:north-west 1) + (:north 2) + (:north-east 3) + (:west 4) + (:center 5) + (:east 6) + (:south-west 7) + (:south 8) + (:south-east 9) + (:static 10)) + +(defcenum image-type + :undefined + :bi-level + :gray-scale + :gray-scale-matte + :palette + :palette-matte + :true-color + :true-color-matte + :color-separation + :color-separation-matte + :optimize) + +(defcenum interlace-type + :undefined + :no + :line + :plane + :partition) + +(defcenum orientation-type + :undefined + :top-left + :top-right + :bottom-right + :bottom-left + :left-top + :right-top + :right-bottom + :left-bottom) + +(defcenum preview-type + :undefined + :rotate + :shear + :roll + :hue + :saturation + :brightness + :gamma + :spiff + :dull + :gray-scale + :quantize + :despeckle + :reduce-noise + :add-noise + :sharpen + :blur + :threshold + :edge-detect + :spread + :solarize + :shade + :raise + :segment + :swirl + :implode + :wave + :oil-paint + :charcoal-drawing + :jpeg) + +(defcenum rendering-intent + :undefined + :saturation + :perceptual + :absolute + :relative) + +(defcenum resolution-type + :undefined + :pixels-per-inch + :pixels-per-centimeter) + + ;; from constitute.h + ;; +(defcenum storage-type + :undefined + :char + :double + :float + :integer + :long + :quantum + :short) + +(defcenum timer-state + :undefined + :stopped + :running) + +(defcstruct error-info + (mean-error-per-pixel :double) + (normalized-mean-error :double) + (normalized-maximum-error :double)) + +(defcstruct exception-info + (severity exception-type) + (error-number :int) + (reason :string) + (description :string) + (exceptions :pointer) ;; void* + (relinquish boolean-type) + (semaphore :pointer) ;; Semaphore* + (signature :unsigned-long)) + +(defcstruct primary-info + (x :double) + (y :double) + (z :double)) + +(defcstruct chromaticity-info + (red-primary primary-info) + (green-primary primary-info) + (blue-primary primary-info) + (white-point primary-info)) + +(defcstruct pixel-packet + (blue quantum) + (green quantum) + (red quantum) + (opacity quantum)) + +(defcstruct profile-info + (name :string) + (length :unsigned-long) + (info :pointer) ;; char* + (signature :unsigned-long)) + +(defcstruct rectangle-info + (width :unsigned-long) + (height :unsigned-long) + (x :long) + (y :long)) + +(defcstruct timer + (start :double) + (stop :double) + (total :double)) + +(defcstruct timer-info + (user timer) + (elapsed timer) + (state timer-state) + (signature :unsigned-long)) + +(defcstruct magick-image + (storage-class class-type) + (color-space colorspace-type) + (compression compression-type) + (quality :long) + (orientation orientation-type) + (taint boolean-type) + (matte boolean-type) + (columns :unsigned-long) + (rows :unsigned-long) + (depth :unsigned-long) + (colors :unsigned-long) + (colormap :pointer) ;; PixelPacket* + (background-color pixel-packet) + (border-color pixel-packet) + (matte-color pixel-packet) + (gamma :double) + (chromaticity chromaticity-info) + (render-intent rendering-intent) + (profiles :pointer) ;; void* + (units resolution-type) + (montage :pointer) ;; char* + (directory :pointer) ;; char* + (geometry :pointer) ;; char* + (offset :long) + (x-resolution :double) + (y-resolution :double) + (page rectangle-info) + (extract-info rectangle-info) + (tile-info rectangle-info) ;; deprecated + (bias :double) + (blur :double) + (fuzz :double) + (filter filter-types) + (interlace interlace-type) + (endian endian-type) + (gravity gravity-type) + (compose composite-operator) + (dispose dispose-type) + (clip-mask :pointer) ;; Image* + (scene :unsigned-long) + (delay :unsigned-long) + (ticks-per-second :unsigned-long) + (iterations :unsigned-long) + (total-colors :unsigned-long) + (start-loop :long) + (error error-info) + (timer timer-info) + (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args) + (client-data :pointer) ;; void* + (cache :pointer) ;; void* + (attributes :pointer) ;; void* + (ascii85 :pointer) ;; _Ascii85Info_* + (blob :pointer) ;; _BlobInfo_* + (filename :char :count 4096) + (magick-filename :char :count 4096) + (magick :char :count 4096) + (exception exception-info) + (debug boolean-type) + (reference-count :long) + (semaphore :pointer) ;; SemaphoreInfo* + (color-profile profile-info) + (iptc-profile profile-info) + (generic-profile :pointer) ;; ProfileInfo* + (generic-profiles :unsigned-long) ;; deprecated (and ProfileInfo too?) + (signature :unsigned-long) + (previous :pointer) ;; Image* + (list :pointer) ;; Image* + (next :pointer)) ;; Image* + +(defcstruct magick-image-info + (compression compression-type) + (orientation orientation-type) + (temporary boolean-type) + (adjoin boolean-type) + (affirm boolean-type) + (antialias boolean-type) + (size :pointer) ;; char* + (extract :pointer) ;; char* + (page :pointer) ;; char* + (scenes :pointer) ;; char* + (scene :unsigned-long) + (number-scenes :unsigned-long) + (depth :unsigned-long) + (interlace interlace-type) + (endian endian-type) + (units resolution-type) + (quality :unsigned-long) + (sampling-factor :pointer) ;; char* + (server-name :pointer) ;; char* + (font :pointer) ;; char* + (texture :pointer) ;; char* + (density :pointer) ;; char* + (point-size :double) + (fuzz :double) + (background-color pixel-packet) + (border-color pixel-packet) + (matte-color pixel-packet) + (dither boolean-type) + (monochrome boolean-type) + (colors :unsigned-long) + (colorspace colorspace-type) + (type image-type) + (prevu-type preview-type) + (group :long) + (ping boolean-type) + (verbose boolean-type) + (view :pointer) ;; char* + (authenticate :pointer) ;; char* + (channel :unsigned-int) ;; ChannelType + (attributes :pointer) ;; Image* + (options :pointer) ;; void* + (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args) + (client-data :pointer) ;; void* + (cache :pointer) ;; void* + (stream :pointer) ;; size_t (*StreamHandler)(args) + (file :pointer) ;; FILE* + (blob :pointer) ;; void* + (length :unsigned-int) + (magick :char :count 4096) + (unique :char :count 4096) + (zero :char :count 4096) + (filename :char :count 4906) + (debug boolean-type) + (tile :pointer) ;; deprecated + (subimage :unsigned-long) + (subrange :unsigned-long) + (pen pixel-packet) + (signature :unsigned-long)) + \ No newline at end of file Modified: trunk/src/uitoolkit/graphics/palette.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/palette.lisp (original) +++ trunk/src/uitoolkit/graphics/palette.lisp Sun Mar 19 12:42:18 2006 @@ -33,11 +33,13 @@ (in-package :graphic-forms.uitoolkit.graphics) +#| (defun pixel-color (pal pixel-val) "Returns the color struct corresponding to the given pixel value; the inverse of the pixel function." (if (direct-p pal) (error 'toolkit-error :detail "not yet implemented") (aref (palette-table pal) pixel-val))) +|# (defun dump-colors (pal) (let* ((tmp (palette-table pal)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 12:42:18 2006 @@ -73,6 +73,16 @@ (usage UINT)) (defcfun + ("CreateDIBSection" create-dib-section) + HANDLE + (hdc HANDLE) + (bmi LPTR) + (usage UINT) + (values LPTR) ;; VOID ** + (section HANDLE) + (offset DWORD)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Mar 19 12:42:18 2006 @@ -35,11 +35,13 @@ #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) + (gfg::initialize-magick (cffi:null-pointer)) (setf *the-thread-context* (make-instance 'thread-context)) (funcall start-fn) (run-default-message-loop)) #+lispworks (defun startup (thread-name start-fn) + (gfg::initialize-magick (cffi:null-pointer)) (when (null (mp:list-all-processes)) (mp:initialize-multiprocessing)) (mp:process-run-function thread-name @@ -49,6 +51,7 @@ (run-default-message-loop))))) (defun shutdown (exit-code) + (gfg::destroy-magick) (gfs::post-quit-message exit-code)) (defun clear-all (w) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Mar 19 12:42:18 2006 @@ -44,4 +44,5 @@ (defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*)) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (chdir *gf-tests-dir*)) From junrue at common-lisp.net Sun Mar 19 21:35:28 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 19 Mar 2006 16:35:28 -0500 (EST) Subject: [graphic-forms-cvs] r51 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system Message-ID: <20060319213528.C10B85903A@common-lisp.net> Author: junrue Date: Sun Mar 19 16:35:26 2006 New Revision: 51 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/graphics/magick-core-types.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: initial transparency work Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 19 16:35:26 2006 @@ -195,8 +195,10 @@ #:transform #:transform-coordinates #:translate - #:transparency-color + #:transparency + #:transparency-of #:transparency-mask + #:with-transparency #:xor-mode-p ;; conditions Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Sun Mar 19 16:35:26 2006 @@ -40,29 +40,54 @@ (defclass image-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d image-events) window time) - (declare (ignore window time)) +(defun dispose-images () (gfi:dispose *happy-image*) (setf *happy-image* nil) (gfi:dispose *bw-image*) (setf *bw-image* nil) (gfi:dispose *true-image*) - (setf *true-image* nil) + (setf *true-image* nil)) + +(defmethod gfw:event-close ((d image-events) window time) + (declare (ignore window time)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) - (let ((pnt (gfi:make-point))) + (let ((pnt (gfi:make-point)) + (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) + (gfg:with-transparency (*happy-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) + (incf (gfi:point-x pnt) 36) + (gfg:draw-image gc *happy-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:draw-image gc *true-image* pnt))) + (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) + (incf (gfi:point-x pnt) 24) + (gfg:draw-image gc *bw-image* pnt)) + + (setf (gfi:point-x pnt) 0) + (incf (gfi:point-y pnt) 20) + (gfg:draw-image gc *true-image* pnt) + (incf (gfi:point-x pnt) 20) + (gfg:with-transparency (*true-image* tr-color) + (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) + (incf (gfi:point-x pnt) 20) + (gfg:draw-image gc *true-image* pnt)))) (defun exit-image-fn (disp item time rect) (declare (ignorable disp item time rect)) + (dispose-images) (gfi:dispose *image-win*) (setf *image-win* nil) (gfw:shutdown 0)) @@ -77,6 +102,7 @@ (gfg::load *true-image* "truecolor16x16.bmp") (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) + (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Sun Mar 19 16:35:26 2006 @@ -33,13 +33,13 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) -(defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) -(defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) -(defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) -(defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) + (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) + (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) + (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) + (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) + (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 19 16:35:26 2006 @@ -87,10 +87,10 @@ (defclass image (gfi:native-object) ((transparency - :accessor transparency-color - :initarg :transparency-color - :initform (make-color))) - (:documentation "This class represents an image of a particular type (BMP, PNG, etc.).")) + :accessor transparency-of + :initarg :transparency + :initform nil)) + (:documentation "This class wraps a native image object.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 19 16:35:26 2006 @@ -82,30 +82,42 @@ 0 (cffi:null-pointer)))))) +;;; +;;; TODO: support addressing elements within bitmap as if it were an array +;;; (defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point)) (if (gfi:disposed-p gc) (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - ;; TODO: support addressing elements within bitmap as if it were an array - ;; - (let ((memdc (gfs::create-compatible-dc (gfi:handle gc))) - (oldhbm (cffi:null-pointer))) - (if (gfi:null-handle-p memdc) - (error 'gfs:win32-error :detail "create-compatible-dc failed")) - (setf oldhbm (gfs::select-object memdc (gfi:handle im))) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (gfs::bit-blt (gfi:handle gc) - (gfi:point-x pnt) - (gfi:point-y pnt) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width) - (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height) - memdc - 0 0 - gfs::+blt-srccopy+)) - (gfs::select-object memdc oldhbm) - (gfs::delete-dc memdc))) + (let* ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc gc-dc)) + (tr-color (transparency-of im)) + (op gfs::+blt-srccopy+)) + (unwind-protect + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (when (not (null tr-color)) + (setf op gfs::+blt-srcpaint+) + (gfs::select-object memdc (gfi:handle (transparency-mask im))) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+)) + (gfs::select-object memdc himage) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 op))) + (gfs::delete-dc memdc)))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 19 16:35:26 2006 @@ -175,7 +175,7 @@ (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) (defgeneric transparency-mask (object) - (:documentation "Returns an image-data object specifying the transparency mask for the image.")) + (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) (defgeneric xor-mode-p (object) (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Sun Mar 19 16:35:26 2006 @@ -145,12 +145,8 @@ (let* ((handle (gfi:handle data)) (sz (size data)) (pix-count (* (gfi:size-width sz) (gfi:size-height sz))) - (bit-count (depth data)) (hbmp (cffi:null-pointer)) (screen-dc (gfs::get-dc (cffi:null-pointer)))) -(format t "bi-size: ~a~%" (cffi:foreign-type-size 'gfs::bitmapinfoheader)) -(format t "bit-count: ~a~%" bit-count) -(format t "size: ~a ~a~%" (gfi:size-width sz) (gfi:size-height sz)) (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)) (setf gfs::biwidth (gfi:size-width sz)) (setf gfs::biheight (- 0 (gfi:size-height sz))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Sun Mar 19 16:35:26 2006 @@ -34,9 +34,18 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper functions +;;; helper macros ;;; +(defmacro with-transparency ((image color) &body body) + (let ((orig-color (gensym))) + `(let ((,orig-color (transparency-of ,image))) + (unwind-protect + (progn + (setf (transparency-of ,image) ,color) + , at body) + (setf (transparency-of ,image) ,orig-color))))) + ;;; ;;; methods ;;; @@ -45,7 +54,6 @@ (let ((hgdi (gfi:handle im))) (unless (gfi:null-handle-p hgdi) (gfs::delete-object hgdi))) - (setf (transparency-color im) nil) (setf (slot-value im 'gfi:handle) nil)) (defmethod data-obj ((im image)) @@ -63,3 +71,30 @@ (load data path) (setf (data-obj im) data) data)) + +(defmethod transparency-mask ((im image)) + (if (gfi:disposed-p im) + (error 'gfi:disposed-error)) + (let ((hbmp (gfi:handle im)) + (tr-color (transparency-of im)) + (hmask (cffi:null-pointer))) + (if (null tr-color) + (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (unwind-protect + (progn + (gfs::select-object memdc1 hbmp) + (gfs::select-object memdc2 hmask) + (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) + (gfs::delete-dc memdc1) + (gfs::delete-dc memdc2))))) + (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/graphics/magick-core-types.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-types.lisp Sun Mar 19 16:35:26 2006 @@ -41,8 +41,9 @@ ;;; of these types from ImageMagick Core. ;;; -(defconstant +magick-max-text-extent+ 4096) -(defconstant +magick-signature+ #xABACADAB) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +magick-max-text-extent+ 4096) + (defconstant +magick-signature+ #xABACADAB)) (defconstant +undefined-channel+ #x00000000) (defconstant +red-channel+ #x00000001) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 19 16:35:26 2006 @@ -53,11 +53,27 @@ (rop DWORD)) (defcfun + ("CreateBitmap" create-bitmap) + HANDLE + (width INT) + (height INT) + (planes UINT) + (bpp UINT) + (pixels LPTR)) + +(defcfun ("CreateBitmapIndirect" create-bitmap-indirect) HANDLE (lpbm LPTR)) (defcfun + ("CreateCompatibleBitmap" create-compatible-bitmap) + HANDLE + (hdc HANDLE) + (width INT) + (height INT)) + +(defcfun ("CreateCompatibleDC" create-compatible-dc) HANDLE (hdc HANDLE)) From junrue at common-lisp.net Mon Mar 20 05:18:26 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:18:26 -0500 (EST) Subject: [graphic-forms-cvs] r52 - in trunk/src: . tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets Message-ID: <20060320051826.22EFE4814D@common-lisp.net> Author: junrue Date: Mon Mar 20 00:18:25 2006 New Revision: 52 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/happy.bmp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/truecolor16x16.bmp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image-data.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: basic transparency working, need to allow caller to select the pixel that defines transparent color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:18:25 2006 @@ -94,8 +94,9 @@ ;; methods, functions, macros #:detail + #:with-compatible-dcs #:with-hfont-selected - #:with-retrieved-hdc + #:with-retrieved-dc ;; conditions #:toolkit-error Modified: trunk/src/tests/uitoolkit/happy.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 00:18:25 2006 @@ -58,11 +58,11 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (tr-color (gfg:make-color :red 192 :green 192 :blue 192))) + (color (gfg:make-color :red 0 :green 255 :blue 255))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* tr-color) + (gfg:with-transparency (*happy-image* color) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -80,7 +80,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* tr-color) + (gfg:with-transparency (*true-image* color) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) Modified: trunk/src/tests/uitoolkit/truecolor16x16.bmp ============================================================================== Binary files. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:18:25 2006 @@ -90,25 +90,42 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((gc-dc (gfi:handle gc)) + (let* ((color (transparency-of im)) + (gc-dc (gfi:handle gc)) (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc gc-dc)) - (tr-color (transparency-of im)) - (op gfs::+blt-srccopy+)) - (unwind-protect - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) - (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (when (not (null tr-color)) - (setf op gfs::+blt-srcpaint+) - (gfs::select-object memdc (gfi:handle (transparency-mask im))) - (gfs::bit-blt gc-dc - (gfi:point-x pnt) - (gfi:point-y pnt) - gfs::width - gfs::height - memdc - 0 0 gfs::+blt-srcand+)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (if (not (null color)) + (let ((hmask (gfi:handle (transparency-mask im))) + (hcopy (clone-bitmap himage)) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (gfs::select-object memdc hmask) + (gfs::select-object memdc2 hcopy) + (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) + (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::bit-blt memdc2 + 0 0 + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc + 0 0 gfs::+blt-srcand+) + (gfs::bit-blt gc-dc + (gfi:point-x pnt) + (gfi:point-y pnt) + gfs::width + gfs::height + memdc2 + 0 0 gfs::+blt-srcpaint+)) + (progn (gfs::select-object memdc himage) (gfs::bit-blt gc-dc (gfi:point-x pnt) @@ -116,8 +133,8 @@ gfs::width gfs::height memdc - 0 0 op))) - (gfs::delete-dc memdc)))) + 0 0 gfs::+blt-srccopy+))))) + (gfs::delete-dc memdc))) (defmethod draw-text ((gc graphics-context) text (pnt gfi:point)) (if (gfi:disposed-p gc) Modified: trunk/src/uitoolkit/graphics/image-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image-data.lisp (original) +++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Mar 20 00:18:25 2006 @@ -46,8 +46,6 @@ (data nil) (sz nil) (byte-count 0)) - (when (gfi:null-handle-p mem-dc) - (error 'gfs:win32-error :detail "create-compatible-dc failed")) (unwind-protect (progn (cffi:with-foreign-object (bc-ptr 'gfs::bitmapcoreheader) @@ -218,8 +216,9 @@ (with-image-path (path info ex) (setf handle (read-image info ex)) (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined)) - (error 'gfs:toolkit-error :detail (format nil "exception reason: ~s" - (cffi:foreign-string-to-lisp (cffi:foreign-slot-value ex 'exception-info 'reason))))) + (error 'gfs:toolkit-error :detail (format nil + "exception reason: ~s" + (cffi:foreign-slot-value ex 'exception-info 'reason)))) (if (cffi:null-pointer-p handle) (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path))) (setf (slot-value data 'gfi:handle) handle)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:18:25 2006 @@ -34,7 +34,7 @@ (in-package :graphic-forms.uitoolkit.graphics) ;;; -;;; helper macros +;;; helper macros and functions ;;; (defmacro with-transparency ((image color) &body body) @@ -46,6 +46,21 @@ , at body) (setf (transparency-of ,image) ,orig-color))))) +(defun clone-bitmap (horig) + (let ((hclone (cffi:null-pointer)) + (nptr (cffi:null-pointer))) + (gfs:with-compatible-dcs (nptr memdc-src memdc-dest) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (setf hclone (gfs::create-compatible-bitmap (gfs::get-dc (cffi:null-pointer)) + gfs::width + gfs::height)) + (gfs::select-object memdc-dest hclone) + (gfs::select-object memdc-src horig) + (gfs::bit-blt memdc-dest 0 0 gfs::width gfs::height memdc-src 0 0 gfs::+blt-srccopy+)))) + hclone)) + ;;; ;;; methods ;;; @@ -76,25 +91,19 @@ (if (gfi:disposed-p im) (error 'gfi:disposed-error)) (let ((hbmp (gfi:handle im)) - (tr-color (transparency-of im)) - (hmask (cffi:null-pointer))) - (if (null tr-color) - (setf tr-color +color-black+)) ;; FIXME: upper-left pixel might be better choice + (hmask (cffi:null-pointer)) + (nptr (cffi:null-pointer)) + (old-bg 0)) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) (if (gfi:null-handle-p hmask) (error 'gfs:win32-error :detail "create-bitmap failed")) - (let ((memdc1 (gfs::create-compatible-dc (cffi:null-pointer))) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) - (unwind-protect - (progn - (gfs::select-object memdc1 hbmp) - (gfs::select-object memdc2 hmask) - (gfs::set-bk-color memdc1 (color-as-rgb tr-color)) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::bit-blt memdc1 0 0 gfs::width gfs::height memdc2 0 0 gfs::+blt-srcinvert+)) - (gfs::delete-dc memdc1) - (gfs::delete-dc memdc2))))) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) (make-instance 'image :handle hmask))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 20 00:18:25 2006 @@ -164,6 +164,13 @@ (buffer LPTR)) (defcfun + ("GetPixel" get-pixel) + COLORREF + (hdc HANDLE) + (x INT) + (y INT)) + +(defcfun ("GetStockObject" get-stock-object) HANDLE (type INT)) @@ -180,6 +187,22 @@ (lpm LPTR)) (defcfun + ("MaskBlt" mask-blt) + BOOL + (hdest HANDLE) + (xdest INT) + (ydest INT) + (width INT) + (height INT) + (hsrc HANDLE) + (xsrc INT) + (ysrc INT) + (hmask HANDLE) + (xmask INT) + (ymask INT) + (rop DWORD)) + +(defcfun ("SelectObject" select-object) HANDLE (hdc HANDLE) @@ -219,3 +242,6 @@ COLORREF (hdc HANDLE) (color COLORREF)) + +(defun makerop4 (fore back) + (logior (logand (ash back 8) #xFF000000) fore)) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Mon Mar 20 00:18:25 2006 @@ -47,7 +47,7 @@ (unless (gfi:null-handle-p ,hfont-old) (gfs::select-object ,hdc ,hfont-old)))))) -(defmacro with-retrieved-hdc ((hwnd hdc-var) &body body) +(defmacro with-retrieved-dc ((hwnd hdc-var) &body body) `(let ((,hdc-var nil)) (unwind-protect (progn @@ -56,3 +56,12 @@ (error 'gfs:win32-error :detail "get-dc failed")) , at body) (gfs::release-dc ,hwnd ,hdc-var)))) + +(defmacro with-compatible-dcs ((orig-dc &rest hdc-vars) &body body) + `(let ,(loop for var in hdc-vars + collect `(,var (gfs::create-compatible-dc ,orig-dc))) + (unwind-protect + (progn + , at body) + ,@(loop for var2 in hdc-vars + collect `(gfs::delete-dc ,var2))))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Mar 20 00:18:25 2006 @@ -136,7 +136,7 @@ (sz (gfi:make-size)) (hfont nil)) (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) - (gfs:with-retrieved-hdc (hwnd hdc) + (gfs:with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs:with-hfont-selected (hdc hfont) (when (> len 0) From junrue at common-lisp.net Mon Mar 20 05:34:03 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:34:03 -0500 (EST) Subject: [graphic-forms-cvs] r53 - in trunk/src: . tests/uitoolkit uitoolkit/graphics Message-ID: <20060320053403.E9D7449034@common-lisp.net> Author: junrue Date: Mon Mar 20 00:34:03 2006 New Revision: 53 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/image.lisp Log: image transparency is now specified as a point in the image rather than a color Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:34:03 2006 @@ -197,7 +197,7 @@ #:transform-coordinates #:translate #:transparency - #:transparency-of + #:transparency-pixel-of #:transparency-mask #:with-transparency #:xor-mode-p Modified: trunk/src/tests/uitoolkit/image-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-tester.lisp (original) +++ trunk/src/tests/uitoolkit/image-tester.lisp Mon Mar 20 00:34:03 2006 @@ -58,11 +58,12 @@ (defmethod gfw:event-paint ((d image-events) window time gc rect) (declare (ignore window time rect)) (let ((pnt (gfi:make-point)) - (color (gfg:make-color :red 0 :green 255 :blue 255))) + (pixel-pnt1 (gfi:make-point)) + (pixel-pnt2 (gfi:make-point :x 0 :y 15))) (gfg:draw-image gc *happy-image* pnt) (incf (gfi:point-x pnt) 36) - (gfg:with-transparency (*happy-image* color) + (gfg:with-transparency (*happy-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *happy-image*) pnt) (incf (gfi:point-x pnt) 36) (gfg:draw-image gc *happy-image* pnt)) @@ -71,7 +72,7 @@ (incf (gfi:point-y pnt) 36) (gfg:draw-image gc *bw-image* pnt) (incf (gfi:point-x pnt) 24) - (gfg:with-transparency (*bw-image* gfg:+color-black+) + (gfg:with-transparency (*bw-image* pixel-pnt1) (gfg:draw-image gc (gfg:transparency-mask *bw-image*) pnt) (incf (gfi:point-x pnt) 24) (gfg:draw-image gc *bw-image* pnt)) @@ -80,7 +81,7 @@ (incf (gfi:point-y pnt) 20) (gfg:draw-image gc *true-image* pnt) (incf (gfi:point-x pnt) 20) - (gfg:with-transparency (*true-image* color) + (gfg:with-transparency (*true-image* pixel-pnt2) (gfg:draw-image gc (gfg:transparency-mask *true-image*) pnt) (incf (gfi:point-x pnt) 20) (gfg:draw-image gc *true-image* pnt)))) @@ -103,6 +104,7 @@ (setf *image-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'image-events) :style '(:style-workspace))) (setf (gfw:size *image-win*) (gfi:make-size :width 250 :height 200)) + (setf (gfw:text *image-win*) "Image Tester") (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :callback #'exit-image-fn)))))) (setf (gfw:menu-bar *image-win*) menubar) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Mar 20 00:34:03 2006 @@ -86,9 +86,9 @@ (:documentation "This class represents the context associated with drawing primitives.")) (defclass image (gfi:native-object) - ((transparency - :accessor transparency-of - :initarg :transparency + ((transparency-pixel + :accessor transparency-pixel-of + :initarg :transparency-pixel :initform nil)) (:documentation "This class wraps a native image object.")) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:34:03 2006 @@ -90,14 +90,13 @@ (error 'gfi:disposed-error)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let* ((color (transparency-of im)) - (gc-dc (gfi:handle gc)) - (himage (gfi:handle im)) - (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) + (let ((gc-dc (gfi:handle gc)) + (himage (gfi:handle im)) + (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (if (not (null color)) + (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Mon Mar 20 00:34:03 2006 @@ -37,14 +37,14 @@ ;;; helper macros and functions ;;; -(defmacro with-transparency ((image color) &body body) - (let ((orig-color (gensym))) - `(let ((,orig-color (transparency-of ,image))) +(defmacro with-transparency ((image pnt) &body body) + (let ((orig-pnt (gensym))) + `(let ((,orig-pnt (transparency-pixel-of ,image))) (unwind-protect (progn - (setf (transparency-of ,image) ,color) + (setf (transparency-pixel-of ,image) ,pnt) , at body) - (setf (transparency-of ,image) ,orig-color))))) + (setf (transparency-pixel-of ,image) ,orig-pnt))))) (defun clone-bitmap (horig) (let ((hclone (cffi:null-pointer)) @@ -90,20 +90,23 @@ (defmethod transparency-mask ((im image)) (if (gfi:disposed-p im) (error 'gfi:disposed-error)) - (let ((hbmp (gfi:handle im)) + (let ((pixel-pnt (transparency-pixel-of im)) + (hbmp (gfi:handle im)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer)) (old-bg 0)) - (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) - (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) - (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) - (if (gfi:null-handle-p hmask) - (error 'gfs:win32-error :detail "create-bitmap failed")) - (gfs::with-compatible-dcs (nptr memdc1 memdc2) - (gfs::select-object memdc1 hbmp) - (setf old-bg (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1 0 0))) - (gfs::select-object memdc2 hmask) - (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) - (gfs::set-bk-color memdc1 old-bg)))) - (make-instance 'image :handle hmask))) + (unless (null pixel-pnt) + (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) + (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) + (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) + (if (gfi:null-handle-p hmask) + (error 'gfs:win32-error :detail "create-bitmap failed")) + (gfs::with-compatible-dcs (nptr memdc1 memdc2) + (gfs::select-object memdc1 hbmp) + (setf old-bg (gfs::set-bk-color memdc1 + (gfs::get-pixel memdc1 (gfi:point-x pixel-pnt) (gfi:point-y pixel-pnt)))) + (gfs::select-object memdc2 hmask) + (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+) + (gfs::set-bk-color memdc1 old-bg)))) + (make-instance 'image :handle hmask)))) From junrue at common-lisp.net Mon Mar 20 05:38:50 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:38:50 -0500 (EST) Subject: [graphic-forms-cvs] r54 - trunk Message-ID: <20060320053850.9B01149034@common-lisp.net> Author: junrue Date: Mon Mar 20 00:38:50 2006 New Revision: 54 Modified: trunk/build.lisp Log: got rid of dependencies on practicals code from PCL Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Mon Mar 20 00:38:50 2006 @@ -48,8 +48,6 @@ (defvar *closer-mop-dir* (concatenate 'string *asdf-root* "closer-mop/")) (defvar *imagemagick-dir* "c:/Program Files/ImageMagick-6.2.6-Q16/") (defvar *lw-compat-dir* (concatenate 'string *asdf-root* "lw-compat/")) -(defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/")) -(defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/")) (defvar *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) (defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/") @@ -59,22 +57,16 @@ (defvar *asdf-dirs* (list *cffi-dir* *closer-mop-dir* *lw-compat-dir* - *pcl-ch08-dir* - *pcl-ch24-dir* *gf-dir*)) (defvar *library-build-root* (concatenate 'string *library-root* "build/")) (defvar *cffi-build-dir* (concatenate 'string *library-build-root* "cffi/")) (defvar *closer-mop-build-dir* (concatenate 'string *library-build-root* "closer-mop/")) (defvar *lw-compat-build-dir* (concatenate 'string *library-build-root* "lw-compat/")) -(defvar *pcl-ch08-build-dir* (concatenate 'string *library-build-root* "pcl-macro-utilities/")) -(defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/")) (defvar *build-dirs* (list *cffi-build-dir* *closer-mop-build-dir* *lw-compat-build-dir* - *pcl-ch08-build-dir* - *pcl-ch24-build-dir* *gf-build-dir*)) #+lispworks (defmacro chdir (path) @@ -101,13 +93,5 @@ (asdf:operate 'asdf:load-op :closer-mop) (if *external-build-dirs* - (chdir *pcl-ch08-build-dir*)) - (asdf:operate 'asdf:load-op :macro-utilities) - - (if *external-build-dirs* - (chdir *pcl-ch24-build-dir*)) - (asdf:operate 'asdf:load-op :binary-data) - - (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit)) From junrue at common-lisp.net Mon Mar 20 05:51:29 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 00:51:29 -0500 (EST) Subject: [graphic-forms-cvs] r55 - in trunk/src: . tests/uitoolkit uitoolkit/graphics Message-ID: <20060320055129.3471D4C001@common-lisp.net> Author: junrue Date: Mon Mar 20 00:51:28 2006 New Revision: 55 Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp Log: changed color constants to be defvars not defconstants Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 00:51:28 2006 @@ -124,11 +124,11 @@ #:transform ;; constants - #:+color-black+ - #:+color-blue+ - #:+color-green+ - #:+color-red+ - #:+color-white+ + #:*color-black* + #:*color-blue* + #:*color-green* + #:*color-red* + #:*color-white* ;; methods, functions, macros #:alpha Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Mar 20 00:51:28 2006 @@ -48,8 +48,8 @@ (defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect) (declare (ignorable time rect)) - (setf (gfg:background-color gc) gfg:+color-white+) - (setf (gfg:foreground-color gc) gfg:+color-blue+) + (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) (let* ((sz (gfw:client-size window)) (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2))))) (gfg:draw-text gc *event-tester-text* pnt))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Mon Mar 20 00:51:28 2006 @@ -46,10 +46,10 @@ (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+) + (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+) + (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) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Mon Mar 20 00:51:28 2006 @@ -49,7 +49,7 @@ (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+) + (setf (gfg:background-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Mon Mar 20 00:51:28 2006 @@ -34,12 +34,6 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +color-black+ (make-color :red 0 :green 0 :blue 0)) - (defconstant +color-blue+ (make-color :red 0 :green 0 :blue #xFF)) - (defconstant +color-green+ (make-color :red 0 :green #xFF :blue 0)) - (defconstant +color-red+ (make-color :red #xFF :green 0 :blue 0)) - (defconstant +color-white+ (make-color :red #xFF :green #xFF :blue #xFF)) - (defmacro color-as-rgb (color) (let ((result (gensym))) `(let ((,result 0)) @@ -48,6 +42,12 @@ (setf (ldb (byte 8 16) ,result) (color-blue ,color)) ,result)))) +(defvar *color-black* (make-color :red 0 :green 0 :blue 0)) +(defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) +(defvar *color-green* (make-color :red 0 :green #xFF :blue 0)) +(defvar *color-red* (make-color :red #xFF :green 0 :blue 0)) +(defvar *color-white* (make-color :red #xFF :green #xFF :blue #xFF)) + (defmethod print-object ((obj color) stream) (print-unreadable-object (obj stream :type t) (format stream "~a,~a,~a" (color-red obj) (color-green obj) (color-blue obj)))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 20 00:51:28 2006 @@ -99,11 +99,13 @@ (if (not (null (transparency-pixel-of im))) (let ((hmask (gfi:handle (transparency-mask im))) (hcopy (clone-bitmap himage)) - (memdc2 (gfs::create-compatible-dc (cffi:null-pointer)))) + (memdc2 (gfs::create-compatible-dc (cffi:null-pointer))) + (black (make-color :red 0 :green 0 :blue 0)) + (white (make-color :red #xFF :green #xFF :blue #xFF))) (gfs::select-object memdc hmask) (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color-as-rgb +color-black+)) - (gfs::set-text-color memdc2 (color-as-rgb +color-white+)) + (gfs::set-bk-color memdc2 (color-as-rgb black)) + (gfs::set-text-color memdc2 (color-as-rgb white)) (gfs::bit-blt memdc2 0 0 gfs::width From junrue at common-lisp.net Mon Mar 20 06:03:15 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 01:03:15 -0500 (EST) Subject: [graphic-forms-cvs] r56 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060320060315.9E06D5300E@common-lisp.net> Author: junrue Date: Mon Mar 20 01:03:14 2006 New Revision: 56 Added: trunk/src/uitoolkit/widgets/label.lisp - copied, changed from r46, trunk/src/uitoolkit/widgets/text-label.lisp Removed: trunk/src/uitoolkit/widgets/text-label.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: reverted back to single label class which will distinguish text vs image via style flags Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Mar 20 01:03:14 2006 @@ -101,7 +101,7 @@ (:file "item") (:file "widget") (:file "control") - (:file "text-label") + (:file "label") (:file "button") (:file "widget-with-items") (:file "menu") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 20 01:03:14 2006 @@ -394,6 +394,7 @@ #:items #:key-down-p #:key-toggled-p + #:label #:layout #:layout-of #:layout-p Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 20 01:03:14 2006 @@ -342,7 +342,7 @@ (add-btn-disp (make-instance 'add-child-dispatcher)) (add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel :subtype :panel)) - (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label + (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher Copied: trunk/src/uitoolkit/widgets/label.lisp (from r46, trunk/src/uitoolkit/widgets/text-label.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/text-label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Mon Mar 20 01:03:14 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; text-label.lisp +;;;; label.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -37,7 +37,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((label text-label) &rest style) +(defmethod compute-style-flags ((label label) &rest style) (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) @@ -72,7 +72,7 @@ (setf std-flags (logior std-flags gfs::+ss-left+))))) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((label text-label) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys) (if (not (listp style)) (setf style (list style))) (multiple-value-bind (std-style ex-style) @@ -88,7 +88,7 @@ (init-control label)) -(defmethod preferred-size ((label text-label) width-hint height-hint) +(defmethod preferred-size ((label label) width-hint height-hint) (let* ((hwnd (gfi:handle label)) (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) (b-width (border-width label)) @@ -106,8 +106,8 @@ (incf (gfi:size-height sz) (* b-width 2)) sz)) -(defmethod text ((label text-label)) +(defmethod text ((label label)) (get-widget-text label)) -(defmethod (setf text) (str (label text-label)) +(defmethod (setf text) (str (label label)) (set-widget-text label str)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Mar 20 01:03:14 2006 @@ -65,11 +65,8 @@ (defclass button (control) () (:documentation "This class represents selectable controls that issue notifications when clicked.")) -(defclass image-label (control) () - (:documentation "This class represents non-selectable controls that display an image.")) - -(defclass text-label (control) () - (:documentation "This class represents non-selectable controls that display a string.")) +(defclass label (control) () + (:documentation "This class represents non-selectable controls that display a string or image.")) (defclass widget-with-items (widget) ((items From junrue at common-lisp.net Mon Mar 20 06:52:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 20 Mar 2006 01:52:48 -0500 (EST) Subject: [graphic-forms-cvs] r57 - in trunk: docs/website src src/tests/uitoolkit src/uitoolkit/widgets Message-ID: <20060320065248.A0DE15D087@common-lisp.net> Author: junrue Date: Mon Mar 20 01:52:46 2006 New Revision: 57 Modified: trunk/docs/website/index.html trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/image-tester.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/menu-language.lisp Log: last round of fixes before screenshot upload; renamed menu language macro to defmenu Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Mar 20 01:52:46 2006 @@ -15,7 +15,7 @@The first release will be version 0.2.0 and should be - available shortly.
+The first release, version 0.2.0, is now available.
This library is in the early implementation stage. Brave souls who experiment with the code should expect significant API and Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/image-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/image-unit-tests.lisp Wed Mar 22 10:28:06 2006 @@ -69,5 +69,7 @@ (unless (gfs:null-handle-p hbmp) (gfs::delete-object hbmp)))))) +#| (define-test image-data-loading-test (mapc #'image-data-tester '("blackwhite20x16.bmp" "happy.bmp" "truecolor16x16.bmp"))) +|# From junrue at common-lisp.net Fri Mar 24 07:38:26 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 24 Mar 2006 02:38:26 -0500 (EST) Subject: [graphic-forms-cvs] r70 - trunk/src/uitoolkit/widgets Message-ID: <20060324073826.679BD704B@common-lisp.net> Author: junrue Date: Fri Mar 24 02:38:26 2006 New Revision: 70 Added: trunk/src/uitoolkit/widgets/root-window.lisp Log: missed this in last checkin Added: trunk/src/uitoolkit/widgets/root-window.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/root-window.lisp Fri Mar 24 02:38:26 2006 @@ -0,0 +1,83 @@ +;;;; +;;;; root-window.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 gfs:dispose ((self root-window)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod (setf dispatcher) (disp (self root-window)) + (declare (ignore disp)) + (error 'gfs:toolkit-error :detail "The root window cannot be assigned an event-dispatcher.")) + +(defmethod enable ((self root-window) flag) + (declare (ignore flag)) + (error 'gfs:toolkit-error :detail "The root window cannot be enabled or disabled.")) + +(defmethod enable-layout ((self root-window) flag) + (declare (ignore flag)) + (error 'gfs:toolkit-error :detail "The root window has no layout functionality.")) + +(defmethod initialize-instance :after ((self root-window) &key) + (setf (slot-value self 'gfs:handle) (gfs::get-desktop-window))) + +(defmethod (setf location) (pnt (self root-window)) + (declare (ignore pnt)) + (error 'gfs:toolkit-error :detail "The root window cannot be repositioned.")) + +(defmethod layout ((self root-window)) + (error 'gfs:toolkit-error :detail "The root window has no layout functionality.")) + +(defmethod owner ((self root-window)) + nil) + +(defmethod pack ((self root-window)) + (error 'gfs:toolkit-error :detail "The root window has no layout functionality.")) + +(defmethod parent ((self root-window)) + nil) + +(defmethod show ((self root-window) flag) + (declare (ignore flag)) + (error 'gfs:toolkit-error :detail "The root window cannot be shown or hidden.")) + +(defmethod text ((self root-window)) + (error 'gfs:toolkit-error :detail "The root window has no title.")) + +(defmethod (setf text) (str (self root-window)) + (declare (ignore str)) + (error 'gfs:toolkit-error :detail "The root window has no title.")) From junrue at common-lisp.net Fri Mar 24 07:37:41 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 24 Mar 2006 02:37:41 -0500 (EST) Subject: [graphic-forms-cvs] r69 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060324073741.5D6BE704B@common-lisp.net> Author: junrue Date: Fri Mar 24 02:37:39 2006 New Revision: 69 Added: trunk/src/uitoolkit/widgets/display.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: formalized concepts of 'parent' vs. 'owner' and implemented associated functions and classes; implemented display class representing the monitor and provided access function; modified windlg test program to place the borderless window centered within the main window client area Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Mar 24 02:37:39 2006 @@ -186,6 +186,19 @@ @ref{widget}. @end deftp + at anchor{display} + at deftp Class display primary +Instances of this class describe characteristics of monitors attached +to the system. Applications may call @ref{obtain-displays} to get a +list of all @code{display}s (more than one if the system has multiple +monitors), or @ref{obtain-primary-display} to get the primary. It +derives from @ref{native-object}. + at deffn Reader primary-p +Returns T if the system regards this display as the primary +display; nil otherwise. + at end deffn + at end deftp + @anchor{event-dispatcher} @deftp Class event-dispatcher This is the base class of objects responsible for processing events on @@ -197,10 +210,17 @@ @anchor{event-source} @deftp Class event-source dispatcher -This is the base class for user interface objects that generate events. It -derives from @ref{native-object}. The @code{dispatcher} slot holds an -instance of @ref{event-dispatcher} that is responsible for processing -events on behalf of an @code{event-source}. +This is the base class for user interface objects that generate +events. It derives from @ref{native-object}. The @code{dispatcher} +slot holds an instance of @ref{event-dispatcher} that is responsible +for processing events on behalf of an @code{event-source}. + at deffn Initarg :callbacks +The @code{:callbacks} initarg value specifies an association list +where the @code{CAR} of each entry is the symbol of an @code{event-*} +method (e.g., @ref{event-select}) and the @code{CDR} is a function +pointer. As such, this constitutes a specification for a new + at ref{event-dispatcher} class and associated methods. + at end deffn @deffn Initarg :dispatcher @end deffn @deffn Accessor dispatcher @@ -208,8 +228,10 @@ @end deftp @anchor{item} - at deftp Class item -The item class is the base class for all non-windowed user interface objects. + at deftp Class item item-id +The @code{item} class is the base class for all non-windowed user +interface objects serving as subcomponents of a + at ref{widget-with-items} object. It derives from @ref{event-source}. @deffn Initarg :item-id @end deffn @deffn Accessor item-id @@ -221,6 +243,7 @@ display a string or image. @end deftp + at anchor{menu} @deftp Class menu The menu class represents a container for menu items and submenus. It derives from @ref{widget-with-items}. @@ -230,14 +253,38 @@ A subclass of @ref{item} representing a menu item. @end deftp + at anchor{panel} @deftp Class panel -Base class for @ref{window}s that are children of @ref{top-level} @ref{window}s (or -other panels). +Base class for @ref{window}s that are children of @ref{top-level} + at ref{window}s (or other panels). + at end deftp + + at anchor{root-window} + at deftp Class root-window +This class encapsulates the root of the desktop window hierarchy. Note +that applications may create multiple instances that are not + at code{eq}, yet all such instances will have the same underlying +handle, so they in fact refer to the same native object. Operations +on the root @ref{window} are somewhat constrained, therefore not all +functions normally implemented for other @ref{window} types are +available for this @ref{window} type. If an application attempts to +set @code{root-window} as the @ref{owner} of a dialog or + at ref{top-level}, a @ref{toolkit-error} will be thrown. +In a reply to an entry at + at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: + at quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. + at end quotation @end deftp @deftp Class timer -A timer is a non-windowed object that generates events at a regular (adjustable) frequency. -It derives from @ref{event-source}. +A timer is a non-windowed object that generates events at a regular +(adjustable) frequency. It derives from @ref{event-source}. @deffn Reader id-of @end deffn @deffn Initarg :initial-delay @@ -353,7 +400,8 @@ @end deffn @deffn GenericFunction event-move dispatcher widget time point -Implement this to respond to an object being moved within its parent's coordinate system. +Implement this to respond to an object being moved within its parent's +coordinate system. @end deffn @anchor{event-paint} @@ -365,6 +413,7 @@ Implement this to respond to an object being resized. @end deffn + at anchor{event-select} @deffn GenericFunction event-select dispatcher item time rect Implement this to respond to an object (or item within) being selected. @end deffn @@ -385,139 +434,225 @@ Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn - at deffn GenericFunction append-item object text image dispatcher -Adds the new item with the specified text to the object, and returns the newly-created item. + at deffn GenericFunction append-item self text image dispatcher +Adds the new item with the specified text to the object, and returns +the newly-created item. @end deffn - at deffn GenericFunction append-submenu object text submenu dispatcher + at deffn GenericFunction append-submenu self text submenu dispatcher Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn - at deffn GenericFunction check object flag + at anchor{center-on-owner} + at deffn GenericFunction center-on-owner self +Position @code{self} such that it is centrally located relative to its + at ref{owner}, based on @code{self}'s current outermost size. +See also @ref{center-on-parent}. + at end deffn + + at anchor{center-on-parent} + at deffn GenericFunction center-on-parent self +Position @code{self} such that it is centrally located relative to its + at ref{parent}, based on @code{self}'s current outermost size. +See also @ref{center-on-owner}. + at end deffn + + at deffn GenericFunction check self flag Sets the object into the checked state. @end deffn - at deffn GenericFunction checked-p object + at deffn GenericFunction checked-p self Returns T if the object is in the checked state; nil otherwise. @end deffn - at deffn GenericFunction clear-item object index + at deffn GenericFunction clear-item self index Clears the item at the zero-based index. @end deffn - at deffn GenericFunction clear-span object sp + at deffn GenericFunction clear-span self sp Clears the items whose zero-based indices lie within the specified span. @end deffn - at deffn GenericFunction client-size object -Returns a size object that describes the region of the object that can be drawn within or can display data. + at deffn GenericFunction client-size self +Returns a size object that describes the region of the object that can +be drawn within or can display data. @end deffn - at deffn GenericFunction compute-style-flags object &rest style -Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. + at deffn GenericFunction compute-style-flags self &rest style +Convert a list of keyword symbols to a pair of native bitmasks; the +first conveys normal/standard flags, whereas the second any extended +flags that the system supports. @end deffn - at deffn GenericFunction compute-outer-size object desired-client-size -Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim. + at deffn GenericFunction compute-outer-size self desired-client-size +Return a size object describing the dimensions of the area required to +enclose the specified desired client area and this object's trim. @end deffn - at deffn GenericFunction display-to-object object pnt -Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. + at deffn GenericFunction display-to-object self pnt +Return a point that is the result of transforming the specified point +from display-relative coordinates to this object's coordinate system. @end deffn - at deffn GenericFunction enable object flag -Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected. + at deffn GenericFunction enable self flag +Enables or disables the object, causing it to be redrawn with its +default look and allows it to be selected. @end deffn - at deffn GenericFunction enable-layout object flag + at deffn GenericFunction enable-layout self flag Cause the object to allow or disallow layout management. @end deffn - at deffn GenericFunction enabled-p object + at deffn GenericFunction enabled-p self Returns T if the object is enabled; nil otherwise. @end deffn - at deffn GenericFunction item-at object index + at deffn GenericFunction item-at self index Return the item at the given zero-based index from the object. @end deffn - at deffn GenericFunction item-count object + at deffn GenericFunction item-count self Return the number of items possessed by the object. @end deffn - at deffn GenericFunction item-index object item + at deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn - at deffn GenericFunction item-owner item -Return the widget containing this item. - at end deffn - - at deffn GenericFunction layout object + at deffn GenericFunction layout self Set the size and location of this object's children. @end deffn - at deffn GenericFunction location object -Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. + at deffn GenericFunction location self +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 - at deffn GenericFunction menu-bar object + at deffn GenericFunction menu-bar self Returns the menu object serving as the menubar for this object. @end deffn - at deffn GenericFunction object-to-display object pnt -Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates. + at deffn GenericFunction object-to-display self pnt +Return a point that is the result of transforming the specified point +from this object's coordinate system to display-relative coordinates. + at end deffn + + at anchor{obtain-displays} + at deffn Function obtain-displays +Returns a list of @ref{display} objects, each of which describes +a monitor attached to the system. The system specifies that one +of these is the primary @ref{display}. + at end deffn + + at anchor{obtain-primary-display} + at deffn Function obtain-primary-display +Return a @ref{display} object that is regarded by the system as +being the primary. + at end deffn + + at anchor{owner} + at deffn GenericFunction owner self +Returns the @code{owner} of @code{self}, which may be different from + at code{self}'s @ref{parent} because the window ownership hierarchy +includes the relationships between physically separate + at ref{top-level}s and dialogs. And it is possible for a window to be +unowned but still have a @ref{parent}. Consequently, calling + at ref{parent} on a @ref{top-level} will return an instance of + at ref{root-window}, but calling @ref{owner} may return @code{nil}. In +a reply to an entry at + at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: + at quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. + at end quotation @end deffn @anchor{pack} - at deffn GenericFunction pack object -Causes the object to be resized to its preferred size. + at deffn GenericFunction pack self +Causes @code{self} to be resized to its preferred @ref{size}. @end deffn - at deffn GenericFunction parent object -Returns the object's parent. + at anchor{parent} + at deffn GenericFunction parent self +Returns the @code{parent} of @code{self}. In the case of @ref{panel}s +and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or + at ref{top-level} window. In the case of a dialog or @ref{top-level}, +then a @ref{root-window} is returned. In the case of a @code{submenu}, +this will be the @ref{menu}'s ancestor in the hierarchy; but for a +menubar or context @ref{menu}, @code{parent} returns @code{nil}. In a +reply to an entry at + at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: + at quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. + at end quotation + at end deffn + + at deffn GenericFunction preferred-size self width-hint height-hint +Implement this function to return @code{self}'s preferred @ref{size}; +that is, the dimensions that @code{self} computes as being the best +fit for itself and/or its children. If one or both of + at code{width-hint} and @code{height-hint} are positive, then each such +parameter is used as a constraint on the @ref{size} calculation -- if +for example @code{width-hint} is some positive value, then @code{self} +must determine how tall it would be given that width. @end deffn - at deffn GenericFunction preferred-size object width-hint height-hint -Returns a size object representing the object's 'preferred' size. - at end deffn - - at deffn GenericFunction redraw object + at deffn GenericFunction redraw self Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn - at deffn GenericFunction running-p object + at deffn GenericFunction running-p self Returns T if the object is in event generation mode; nil otherwise. @end deffn - at deffn GenericFunction show object flag -Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. + at deffn GenericFunction show self flag +Causes the object to be visible or hidden on the screen, but not +necessarily top-most in the display z-order. @end deffn - at deffn GenericFunction size object -Returns a size object describing the size of the object in its parent's coordinate system. + at deffn GenericFunction size self +Returns a size object describing the size of the object in its +parent's coordinate system. @end deffn - at deffn GenericFunction start object + at deffn GenericFunction start self Enable event generation at regular intervals. @end deffn - at deffn GenericFunction stop object + at deffn GenericFunction stop self Stop producing events. @end deffn - at deffn GenericFunction text object + at deffn GenericFunction text self Returns the object's text. @end deffn - at deffn GenericFunction update object -Forces all outstanding paint requests for the object to be processed before this function returns. + at deffn GenericFunction update self +Forces all outstanding paint requests for the object to be processed +before this function returns. @end deffn - at deffn GenericFunction visible-p object + at deffn GenericFunction visible-p self Returns T if the object is visible (not necessarily top-most); nil otherwise. @end deffn + at html + at deffn GenericFunction window->display self +Return the @ref{display} object representing the monitor that is nearest +to @code{self}. The @ref{rectangle} bounding @code{self} is not required +to intersect the returned @ref{display}. + at end deffn + at end html + @node layout functions @section layout functions @@ -578,46 +713,49 @@ in future releases, they just aren't all documented or implemented at this time. - at deffn GenericFunction background-color object + at deffn GenericFunction background-color self Returns a color object corresponding to the current background color. @end deffn - at deffn GenericFunction data-obj object + at deffn GenericFunction data-obj self Returns the data structure representing the raw form of the object. @end deffn - at deffn GenericFunction depth object + at deffn GenericFunction depth self Returns the bits-per-pixel depth of the object. @end deffn - at deffn GenericFunction draw-filled-rectangle object rect + at deffn GenericFunction draw-filled-rectangle self rect Fills the interior of the rectangle in the current background color. @end deffn - at deffn GenericFunction draw-image object im pnt + at deffn GenericFunction draw-image self im pnt Draws the given image in the receiver at the specified coordinates. @end deffn - at deffn GenericFunction draw-text object text pnt -Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string. + at deffn GenericFunction draw-text self text pnt +Draws the given string in the current font and foreground color, with +(x, y) being the top-left coordinate of a bounding box for the string. @end deffn - at deffn GenericFunction font object + at deffn GenericFunction font self Returns the current font. @end deffn - at deffn GenericFunction foreground-color object + at deffn GenericFunction foreground-color self Returns a color object corresponding to the current foreground color. @end deffn - at deffn GenericFunction metrics object + at deffn GenericFunction metrics self Returns a metrics object describing key attributes of the specified object. @end deffn - at deffn GenericFunction size object + at deffn GenericFunction size self Returns a size object describing the size of the object. @end deffn - at deffn GenericFunction transparency-mask object -Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. + at deffn GenericFunction transparency-mask self +Returns an image object that will serve as the transparency mask for +the original image, based on the original image's assigned +transparency. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Mar 24 02:37:39 2006 @@ -88,6 +88,7 @@ (:file "event-generics") (:file "layout-generics") (:file "widget-generics") + (:file "display") (:file "event-source") (:file "widget-utils") (:file "timer") @@ -102,6 +103,7 @@ (:file "menu-language") (:file "event") (:file "window") + (:file "root-window") (:file "top-level") (:file "panel") (:file "layout") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Mar 24 02:37:39 2006 @@ -198,6 +198,7 @@ #:button #:caret #:control + #:display #:event-dispatcher #:event-source #:flow-layout @@ -206,6 +207,7 @@ #:menu #:menu-item #:panel + #:root-window #:timer #:top-level #:widget @@ -292,6 +294,8 @@ #:border-width #:bottom-margin-of #:caret + #:center-on-owner + #:center-on-parent #:check #:check-all #:checked-p @@ -400,12 +404,16 @@ #:move-below #:moveable-p #:object-to-display + #:obtain-displays + #:obtain-primary-display + #:owner #:pack #:page-increment #:parent #:paste #:peer #:preferred-size + #:primary-p #:redraw #:redrawing-p #:remove-all Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 02:37:39 2006 @@ -69,8 +69,8 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:style-borderless)))) - (setf (gfw:location window) (gfs:make-point :x 400 :y 250)) (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) + (gfw:center-on-owner window) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 24 02:37:39 2006 @@ -92,6 +92,8 @@ (defconstant +cbm-init+ #x04) +(defconstant +cchdevicename+ 32) + (defconstant +color-scrollbar+ 0) (defconstant +color-background+ 1) (defconstant +color-activecaption+ 2) @@ -279,6 +281,12 @@ (defconstant +mns-notifybypos+ #x08000000) (defconstant +mns-checkorbmp+ #x04000000) +(defconstant +monitor-defaulttonull+ #x00000000) +(defconstant +monitor-defaulttoprimary+ #x00000001) +(defconstant +monitor-defaulttonearest+ #x00000002) + +(defconstant +monitorinfoof-primary+ #x00000001) + (defconstant +obm-lfarrowi+ 32734) (defconstant +obm-rgarrowi+ 32735) (defconstant +obm-dnarrowi+ 32736) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 24 02:37:39 2006 @@ -65,6 +65,7 @@ (defctype LPVOID :long) (defctype LRESULT :unsigned-long) (defctype SHORT :unsigned-short) +(defctype TCHAR :char) (defctype UINT :unsigned-int) (defctype ULONG :unsigned-long) (defctype WORD :short) @@ -165,6 +166,13 @@ (right LONG) (bottom LONG)) +(defcstruct monitorinfoex + (cbsize UINT) + (monitor rect) + (work rect) + (flags DWORD) + (device TCHAR :count 32)) ; CCHDEVICENAME + (defcstruct rgbquad (rgbblue BYTE) (rgbgreen BYTE) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Fri Mar 24 02:37:39 2006 @@ -187,6 +187,47 @@ (lparam ffi:long)) (:return-type ffi:int)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("EnumDisplayMonitors" enum-display-monitors) + BOOL + (hdc HANDLE) + (cliprect LPTR) + (enumproc LPTR) + (data LPARAM)) +|# + +#+lispworks +(fli:define-foreign-function + (enum-display-monitors "EnumDisplayMonitors") + ((hdc :pointer) + (cliprect :pointer) + (enumproc :pointer) + (data :long)) + :result-type :int) + +#+clisp +(ffi:def-call-out enum-display-monitors + (:name "EnumDisplayMonitors") + (:library "user32.dll") + (:language :stdc) + (:arguments (hdc ffi:c-pointer) + (cliprect ffi:c-pointer) + (func (ffi:c-function + (:arguments + (hmonitor ffi:c-pointer) + (hdc ffi:c-pointer) + (monitorrect ffi:c-pointer) + (data ffi:long)) + (:return-type ffi:int) + (:language :stdc-stdcall))) + (data ffi:c-pointer)) + (:return-type ffi:int)) + (defcfun ("GetAncestor" get-ancestor) HANDLE @@ -229,6 +270,10 @@ (hwnd HANDLE)) (defcfun + ("GetDesktopWindow" get-desktop-window) + HANDLE) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) @@ -261,6 +306,17 @@ (filter-max UINT)) (defcfun + ("GetMonitorInfoA" get-monitor-info) + BOOL + (hmonitor HANDLE) + (monitor-info LPTR)) + +(defcfun + ("GetParent" get-parent) + HANDLE + (hwnd HANDLE)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -349,6 +405,12 @@ (type UINT)) (defcfun + ("MonitorFromWindow" monitor-from-window) + HANDLE + (hwnd HANDLE) + (flags DWORD)) + +(defcfun ("PeekMessageA" peek-message) BOOL (msg LPTR) Added: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/display.lisp Fri Mar 24 02:37:39 2006 @@ -0,0 +1,133 @@ +;;;; +;;;; display.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) + +;;; +;;; helper functions +;;; + +#+lispworks +(fli:define-foreign-callable + ("display_visitor" :result-type :integer :calling-convention :stdcall) + ((hmonitor :pointer) + (hdc :pointer) + (monitorrect :pointer) + (data :long)) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +#+clisp +(defun display_visitor (hmonitor hdc monitorrect data) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +(defun visit-displays (func) + ;; + ;; supplied closure should expect three parameters: + ;; display handle + ;; flag data + ;; + (let ((tc (thread-context))) + (setf (display-visitor-func tc) func) + (unwind-protect +#+lispworks (let ((ptr (fli:make-pointer :address 0))) + (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) +#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) + (setf (display-visitor-func tc) nil))) + nil) + +(defun obtain-displays () + (let ((display-list nil)) + (visit-displays #'(lambda (hmonitor data) + (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) + gfs::+monitorinfoof-primary+)) + (display (make-instance 'display :handle hmonitor))) + (setf (slot-value display 'primary) pflag) + (push display display-list)))) + display-list)) + +(defun obtain-primary-display () + (find-if #'primary-p (obtain-displays))) + +;;; +;;; methods +;;; + +(defmethod client-size ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((size (gfs::make-size))) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::work) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (setf (gfs:size-width size) (- gfs::right gfs::left)) + (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + size)) + +(defmethod gfs:dispose ((self display)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod size ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((size (gfs::make-size))) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (setf (gfs:size-width size) (- gfs::right gfs::left)) + (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + size)) + +(defmethod text ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((name "")) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::device) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) + (setf name (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)))))) + name)) Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Fri Mar 24 02:37:39 2006 @@ -65,11 +65,19 @@ :specializers (make-specializer-list class arg-info)))) class)) -(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys) - "The :callbacks parameter specifies an association list where the CAR is the \ -name of an event-* method (e.g., event-select) and the CDR is a function \ -pointer. As such, this constitutes a specification for a new event-dispatcher \ -object and associated methods." +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((self event-source) &key callbacks &allow-other-keys) (unless (null callbacks) (let ((class (define-dispatcher callbacks))) - (setf (dispatcher src) (make-instance (class-name class)))))) + (setf (dispatcher self) (make-instance (class-name class)))))) + +(defmethod owner :before ((self event-source)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod parent :before ((self event-source)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Fri Mar 24 02:37:39 2006 @@ -198,7 +198,7 @@ (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) (let ((id (item-id it)) - (owner (item-owner it))) + (owner (owner it))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) (let* ((index (item-index owner it)) @@ -220,7 +220,7 @@ gfs::+mfs-enabled+) gfs::+mfs-enabled+)) -(defmethod item-owner ((it menu-item)) +(defmethod owner ((it menu-item)) (let ((hmenu (gfs:handle it))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 24 02:37:39 2006 @@ -49,7 +49,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win panel) &rest style) +(defmethod compute-style-flags ((self panel) &rest style) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) @@ -61,11 +61,11 @@ (flatten style)) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) (if (not (listp style)) (setf style (list style))) - (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) + (init-window self +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Mar 24 02:37:39 2006 @@ -35,6 +35,7 @@ (defclass thread-context () ((child-visitor-stack :initform nil) + (display-visitor-func :initform nil :accessor display-visitor-func) (image-loaders-by-type :initform (make-hash-table :test #'equal)) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) @@ -88,6 +89,11 @@ "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty." (pop (slot-value tc 'child-visitor-stack))) +(defmethod call-display-visitor-func ((tc thread-context) hmonitor data) + (let ((func (display-visitor-func tc))) + (unless (null func) + (funcall func hmonitor data)))) + (defmethod get-widget ((tc thread-context) hwnd) "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 24 02:37:39 2006 @@ -33,6 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defclass display (gfs:native-object) + ((primary + :reader primary-p + :initform nil)) + (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) + (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) @@ -91,6 +97,9 @@ (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) +(defclass root-window (window) () + (:documentation "This class encapsulates the root of the desktop window hierarchy.")) + (defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 24 02:37:39 2006 @@ -33,344 +33,353 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric accelerator (object) +(defgeneric accelerator (self) (:documentation "Returns a bitmask indicating the key and any modifiers corresponding to the accelerator set for this object.")) -(defgeneric activate (object) +(defgeneric activate (self) (:documentation "If the object is visible, move it to the top of the display z-order and request the window manager to set it active.")) -(defgeneric alignment (object) +(defgeneric alignment (self) (:documentation "Returns a keyword symbol describing the position of internal content within the object.")) (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (object text image dispatcher) +(defgeneric append-item (self text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) -(defgeneric append-submenu (object text submenu dispatcher) +(defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) -(defgeneric background-color (object) +(defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric border-width (object) +(defgeneric border-width (self) (:documentation "Returns the object's border width.")) -(defgeneric caret (object) +(defgeneric caret (self) (:documentation "Returns the object's caret.")) -(defgeneric caret-position (object) +(defgeneric caret-position (self) (:documentation "Returns a point describing the line number and character position of the caret.")) -(defgeneric check (object flag) +(defgeneric center-on-owner (self) + (:documentation "Position self such that it is centrally located relative to its owner.")) + +(defgeneric center-on-parent (self) + (:documentation "Position self such that it is centrally located relative to its parent.")) + +(defgeneric check (self flag) (:documentation "Sets the object into the checked state.")) -(defgeneric check-all (object flag) +(defgeneric check-all (self flag) (:documentation "Sets all items in this object to the checked state.")) -(defgeneric checked-p (object) +(defgeneric checked-p (self) (:documentation "Returns T if the object is in the checked state; nil otherwise.")) -(defgeneric clear-item (object index) +(defgeneric clear-item (self index) (:documentation "Clears the item at the zero-based index.")) -(defgeneric clear-selection (object) +(defgeneric clear-selection (self) (:documentation "Sets the object's selection status to empty or not selected.")) -(defgeneric clear-span (object sp) +(defgeneric clear-span (self sp) (:documentation "Clears the items whose zero-based indices lie within the specified span.")) -(defgeneric client-size (object) +(defgeneric client-size (self) (:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data.")) -(defgeneric column-at (object index) +(defgeneric column-at (self index) (:documentation "Returns the column object at the zero-based index.")) -(defgeneric column-count (object) +(defgeneric column-count (self) (:documentation "Returns the number of columns displayed by the object.")) -(defgeneric column-index (object col) +(defgeneric column-index (self col) (:documentation "Return the zero-based index of the location of the column in this object.")) -(defgeneric column-order (object) +(defgeneric column-order (self) (:documentation "Returns a list of zero-based indices, each of whose positions represents the column creation order and whose element value represents the current column order.")) -(defgeneric columns (object) +(defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (object &rest style) +(defgeneric compute-style-flags (self &rest style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) -(defgeneric compute-outer-size (object desired-client-size) +(defgeneric compute-outer-size (self desired-client-size) (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim.")) -(defgeneric copy (object) +(defgeneric copy (self) (:documentation "Copies the current selection to the clipboard.")) -(defgeneric cursor (object) +(defgeneric cursor (self) (:documentation "Returns the cursor object associated with this object.")) -(defgeneric cut (object) +(defgeneric cut (self) (:documentation "Copies the current selection to the clipboard and removes it from the object.")) -(defgeneric default-item (object) +(defgeneric default-item (self) (:documentation "Returns the item in this object that has the default emphasis.")) -(defgeneric disabled-image (object) +(defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) -(defgeneric display-to-object (object pnt) +(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 (object) +(defgeneric echo-char (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 (object flag) +(defgeneric enable (self flag) (:documentation "Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected.")) -(defgeneric enable-layout (object flag) +(defgeneric enable-layout (self flag) (:documentation "Cause the object to allow or disallow layout management.")) -(defgeneric enable-redraw (object flag) +(defgeneric enable-redraw (self flag) (:documentation "Cause the object to resume or suspend painting.")) -(defgeneric enabled-p (object) +(defgeneric enabled-p (self) (:documentation "Returns T if the object is enabled; nil otherwise.")) -(defgeneric expand (object deep flag) +(defgeneric expand (self deep flag) (:documentation "Set the object (and optionally it's children) to the expanded or collapsed state.")) -(defgeneric expanded-p (object) +(defgeneric expanded-p (self) (:documentation "Returns T if the object is in the expanded state; nil otherwise.")) -(defgeneric focus-index (object) +(defgeneric focus-index (self) (:documentation "Return a zero-based index of the object's sub-item that has focus; nil otherwise.")) -(defgeneric focus-p (object) +(defgeneric focus-p (self) (:documentation "Returns T if this object has the keyboard focus; nil otherwise.")) -(defgeneric foreground-color (object) +(defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric give-focus (object) +(defgeneric give-focus (self) (:documentation "Causes this object to have the keyboard focus.")) -(defgeneric grid-line-width (object) +(defgeneric grid-line-width (self) (:documentation "Returns the width of a grid line.")) -(defgeneric header-height (object) +(defgeneric header-height (self) (:documentation "Returns the height of the item's header.")) -(defgeneric header-visible-p (object) +(defgeneric header-visible-p (self) (:documentation "Returns T if the object's header is visible; nil otherwise.")) -(defgeneric horizontal-scrollbar (object) +(defgeneric horizontal-scrollbar (self) (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise.")) -(defgeneric iconify (object flag) +(defgeneric iconify (self flag) (:documentation "Set the object to the iconified or restored state.")) -(defgeneric iconified-p (object) +(defgeneric iconified-p (self) (:documentation "Returns T if the object is in its iconified state.")) -(defgeneric image (object) +(defgeneric image (self) (:documentation "Returns the object's image object if it has one, or nil otherwise.")) -(defgeneric item-at (object index) +(defgeneric item-at (self index) (:documentation "Return the item at the given zero-based index from the object.")) -(defgeneric item-count (object) +(defgeneric item-count (self) (:documentation "Return the number of items possessed by the object.")) -(defgeneric item-height (object) +(defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) -(defgeneric item-index (object item) +(defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object.")) -(defgeneric item-owner (item) - (:documentation "Return the widget containing this item.")) - -(defgeneric layout (object) +(defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) -(defgeneric lines-visible-p (object) +(defgeneric lines-visible-p (self) (:documentation "Returns T if the object's lines are visible; nil otherwise.")) -(defgeneric location (object) +(defgeneric location (self) (:documentation "Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system.")) -(defgeneric lock (object flag) +(defgeneric lock (self flag) (:documentation "Prevents or enables modification of the object's contents.")) -(defgeneric locked-p (object) +(defgeneric locked-p (self) (:documentation "Returns T if this object's contents are locked from being modified.")) -(defgeneric maximize (object flag) +(defgeneric maximize (self flag) (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size).")) -(defgeneric maximized-p (object) +(defgeneric maximized-p (self) (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) -(defgeneric maximum-size (object) +(defgeneric maximum-size (self) (:documentation "Returns a size object describing the largest size this object can exist.")) -(defgeneric menu-bar (object) +(defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) -(defgeneric minimum-size (object) +(defgeneric minimum-size (self) (:documentation "Returns a size object describing the smallest size this object can exist.")) -(defgeneric mouse-over-image (object) +(defgeneric mouse-over-image (self) (:documentation "Returns the image displayed when the mouse is hovering over this object.")) -(defgeneric move-above (object other) +(defgeneric move-above (self other) (:documentation "Moves this object above the other object in the drawing order.")) -(defgeneric move-below (object other) +(defgeneric move-below (self other) (:documentation "Moves this object below the other object in the drawing order.")) -(defgeneric moveable-p (object) +(defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (object pnt) +(defgeneric object-to-display (self pnt) (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) -(defgeneric pack (object) +(defgeneric owner (self) + (:documentation "Returns self's owner (which is not necessarily the same as parent).")) + +(defgeneric pack (self) (:documentation "Causes the object to be resized to its preferred size.")) -(defgeneric page-increment (object) +(defgeneric page-increment (self) (:documentation "Return an integer representing the configured page size for the object.")) -(defgeneric parent (object) +(defgeneric parent (self) (:documentation "Returns the object's parent.")) -(defgeneric paste (object) +(defgeneric paste (self) (:documentation "Copies content from the clipboard into the object.")) -(defgeneric peer (object) +(defgeneric peer (self) (:documentation "Returns the visual object associated with this object (not the underlying window system handle).")) -(defgeneric preferred-size (object width-hint height-hint) +(defgeneric preferred-size (self width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) -(defgeneric redraw (object) +(defgeneric redraw (self) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) -(defgeneric redrawing-p (object) +(defgeneric redrawing-p (self) (:documentation "Returns T if the object is set to allow processing of paint events.")) -(defgeneric remove-all (object) +(defgeneric remove-all (self) (:documentation "Removes all items from the object.")) -(defgeneric remove-item (object index) +(defgeneric remove-item (self index) (:documentation "Removes the item at the zero-based index from the object.")) -(defgeneric remove-span (object sp) +(defgeneric remove-span (self sp) (:documentation "Removes the sequence of items represented by the specified span object.")) -(defgeneric reparentable-p (object) +(defgeneric reparentable-p (self) (:documentation "Returns T if the window system allows this object to be reparented; nil otherwise.")) -(defgeneric replace-selection (object content) +(defgeneric replace-selection (self content) (:documentation "Replaces the content of the current selection with new content.")) -(defgeneric resizable-p (object) +(defgeneric resizable-p (self) (:documentation "Returns T if the object is resizable; nil otherwise.")) -(defgeneric retrieve-span (object) +(defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) -(defgeneric running-p (object) +(defgeneric running-p (self) (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) -(defgeneric scroll (object dest-pnt src-rect children-too) +(defgeneric scroll (self dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting.")) -(defgeneric select (object flag) +(defgeneric select (self flag) (:documentation "Set this object into (or take it out of) the selected state.")) -(defgeneric select-all (object flag) +(defgeneric select-all (self flag) (:documentation "Set all items of this object into (or take them out of) the selected state.")) -(defgeneric selected-p (object) +(defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) -(defgeneric selection-count (object) +(defgeneric selection-count (self) (:documentation "Returns the number of this object's items that are selected.")) -(defgeneric selection-index (object) +(defgeneric selection-index (self) (:documentation "Returns the zero-based index of the currently-selected item, or nil if no item is selected.")) -(defgeneric selection-indices (object) +(defgeneric selection-indices (self) (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) -(defgeneric selection-span (object) +(defgeneric selection-span (self) (:documentation "Returns a span object describing the start and end indices of the object selection.")) -(defgeneric show (object flag) +(defgeneric show (self flag) (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order.")) -(defgeneric show-column (object col) +(defgeneric show-column (self col) (:documentation "This object's colums are scrolled until the specified column is visible.")) -(defgeneric show-header (object flag) +(defgeneric show-header (self flag) (:documentation "Causes the object's header to be made visible or hidden.")) -(defgeneric show-item (object index) +(defgeneric show-item (self index) (:documentation "This object's items are scrolled until the specified item is visible.")) -(defgeneric show-lines (object flag) +(defgeneric show-lines (self flag) (:documentation "Causes the object's lines to be made visible or hidden.")) -(defgeneric show-selection (object) +(defgeneric show-selection (self) (:documentation "This object's items are scrolled until the selection is visible.")) -(defgeneric size (object) +(defgeneric size (self) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) -(defgeneric start (object) +(defgeneric start (self) (:documentation "Enable event generation at regular intervals.")) -(defgeneric step-increment (object) +(defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) -(defgeneric stop (object) +(defgeneric stop (self) (:documentation "Stop producing events.")) -(defgeneric text (object) +(defgeneric text (self) (:documentation "Returns the object's text.")) -(defgeneric text-height (object) +(defgeneric text-height (self) (:documentation "Returns the height of the object's text field.")) -(defgeneric text-limit (object) +(defgeneric text-limit (self) (:documentation "Returns the number of characters that the object's text field is capable of holding.")) -(defgeneric thumb-size (object) +(defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) -(defgeneric tooltip-text (object) +(defgeneric tooltip-text (self) (:documentation "Returns the text that will appear within a tooltip when the mouse hovers over this object.")) -(defgeneric top-index (object) +(defgeneric top-index (self) (:documentation "Returns the zero-based index of the item currently at the top of the object.")) -(defgeneric traverse (object arg) +(defgeneric traverse (self arg) (:documentation "Execute a traversal action within this object.")) -(defgeneric traverse-order (object) +(defgeneric traverse-order (self) (:documentation "Returns a list of this object's layout-managed children in the order in which tab traversal would visit them.")) -(defgeneric update (object) +(defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) -(defgeneric vertical-scrollbar (object) +(defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) -(defgeneric visible-item-count (object) +(defgeneric visible-item-count (self) (:documentation "Return the number of items that are currently visible in the object.")) -(defgeneric visible-p (object) +(defgeneric visible-p (self) (:documentation "Returns T if the object is visible (not necessarily top-most); nil otherwise.")) + +(defgeneric window->display (self) + (:documentation "Return the display object representing the monitor that is nearest to self.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 24 02:37:39 2006 @@ -37,6 +37,31 @@ ;;; helper functions ;;; +(defun centered-coord-inside (ancest-coord ancest-size desc-size) + (+ ancest-coord (floor (- (/ ancest-size 2) (/ desc-size 2))))) + +(defun centered-coord-outside (ancest-coord ancest-size desc-size) + (- ancest-coord (floor (/ (- desc-size ancest-size) 2)))) + +(defun center-object (ancestor descendant) + (let* ((ancest-size (client-size ancestor)) + (ancest-width (gfs:size-width ancest-size)) + (ancest-height (gfs:size-height ancest-size)) + (ancest-pnt (location ancestor)) + (desc-size (size descendant)) + (desc-width (gfs:size-width desc-size)) + (desc-height (gfs:size-height desc-size)) + (new-x 0) + (new-y 0)) + (incf (gfs:point-y ancest-pnt) (- (gfs:size-height (size ancestor)) ancest-height)) + (if (> ancest-width desc-width) + (setf new-x (centered-coord-inside (gfs:point-x ancest-pnt) ancest-width desc-width)) + (setf new-x (centered-coord-outside (gfs:point-x ancest-pnt) ancest-width desc-width))) + (if (> ancest-height desc-height) + (setf new-y (centered-coord-inside (gfs:point-y ancest-pnt) ancest-height desc-height)) + (setf new-y (centered-coord-outside (gfs:point-y ancest-pnt) ancest-height desc-height))) + (setf (location descendant) (gfs:make-point :x new-x :y new-y)))) + ;;; ;;; widget methods ;;; @@ -70,6 +95,23 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0)) +(defmethod center-on-owner :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod center-on-owner ((self widget)) + (let ((owner (owner self))) + (if (null owner) + nil + (center-object owner self)))) + +(defmethod center-on-parent :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod center-on-parent ((self widget)) + (center-object (parent self) self)) + (defmethod checked-p :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) @@ -155,6 +197,21 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) +(defmethod owner ((self widget)) + ;; I know the following is confusing, but the docs + ;; for MSDN state that GetParent() returns the owner + ;; when the window in question is a top-level, + ;; whereas for child windows the owner and parent + ;; are the same. + ;; + ;; And since GetParent() can return owners, this + ;; means it can return NULL, too. + ;; + (let ((hwnd (gfs::get-parent (gfs:handle self)))) + (if (gfs:null-handle-p hwnd) + nil + (get-widget (thread-context) hwnd)))) + (defmethod pack :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) @@ -162,6 +219,20 @@ (defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1))) +(defmethod parent ((self widget)) + ;; Unlike the owner method, this method should + ;; only return nil if self is the root window, + ;; which is taken care of by a specialization + ;; on root-window (see root-window.lisp). + ;; + (let* ((hwnd (gfs::get-ancestor (gfs:handle self) gfs::+ga-parent+)) + (widget (get-widget (thread-context) hwnd))) + (when (null widget) + (if (cffi:pointer-eq hwnd (gfs::get-desktop-window)) + (setf widget (make-instance 'root-window :handle hwnd)) + (error 'gfs:toolkit-error :detail "no widget for hwnd"))) + widget)) + (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 24 02:37:39 2006 @@ -207,3 +207,13 @@ (let ((sz (gfs:make-size))) (outer-size win sz) sz)) + +(defmethod window->display :before ((self top-level)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod window->display ((self top-level)) + (let* ((hmonitor (gfs::monitor-from-window (gfs:handle self) gfs::+monitor-defaulttonearest+)) + (display (make-instance 'display))) + (setf (slot-value display 'gfs:handle) hmonitor) + display)) From junrue at common-lisp.net Fri Mar 24 21:59:39 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 24 Mar 2006 16:59:39 -0500 (EST) Subject: [graphic-forms-cvs] r71 - in trunk: . src/tests/uitoolkit src/uitoolkit/graphics Message-ID: <20060324215939.9DA4921001@common-lisp.net> Author: junrue Date: Fri Mar 24 16:59:39 2006 New Revision: 71 Added: trunk/src/tests/uitoolkit/drawing-tester.lisp Modified: trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp Log: started drawing test program Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Mar 24 16:59:39 2006 @@ -60,4 +60,5 @@ (:file "event-tester") (:file "layout-tester") (:file "image-tester") + (:file "drawing-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 24 16:59:39 2006 @@ -0,0 +1,86 @@ +;;;; +;;;; drawing-tester.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) + +(defvar *drawing-dispatcher* nil) +(defvar *drawing-win* nil) + +(defun drawing-exit-fn (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *drawing-win*) + (setf *drawing-win* nil) + (gfw:shutdown 0)) + +(defclass drawing-win-events (gfw:event-dispatcher) + ((draw-func + :accessor draw-func-of + :initform nil))) + +(defmethod gfw:event-close ((self drawing-win-events) window time) + (declare (ignore window time)) + (drawing-exit-fn self nil nil 0)) + +(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect) + (declare (ignore window time)) + (setf (gfg:background-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc rect) + (let ((func (draw-func-of self))) + (unless (null func) + (funcall func gc)))) + +(defun draw-rects (gc) + (setf (gfg:background-color gc) gfg:*color-blue*) + (gfg:draw-filled-rectangle gc + (make-instance 'gfs:rectangle :location (gfs:make-point :x 10 :y 10) + :size (gfs:make-size :width 100 :height 75)))) + +(defun select-rects (disp item time rect) + (declare (ignore disp item time rect)) + (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) + (gfw:redraw *drawing-win*)) + +(defun run-drawing-tester-internal () + (let ((menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) + (:item "&Tests" + :submenu ((:item "&Rectangles" :checked :callback #'select-rects))))))) + (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) + (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) + (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* + :style '(:style-workspace))) + (setf (gfw:menu-bar *drawing-win*) menubar) + (gfw:show *drawing-win* t))) + +(defun run-drawing-tester () + (gfw:startup "Drawing Tester" #'run-drawing-tester-internal)) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 16:59:39 2006 @@ -37,12 +37,16 @@ (defclass main-win-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d main-win-events) window time) - (declare (ignore time)) +(defun windlg-exit-fn (disp item time rect) + (declare (ignore disp item time rect)) + (gfs:dispose *main-win*) (setf *main-win* nil) - (gfs:dispose window) (gfw:shutdown 0)) +(defmethod gfw:event-close ((self main-win-events) window time) + (declare (ignore window time)) + (windlg-exit-fn self nil nil 0)) + (defclass test-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-paint ((d test-win-events) window time gc rect) @@ -93,18 +97,12 @@ (setf (gfw:text window) "Palette") (gfw:show window t))) -(defun exit-callback (disp item time rect) - (declare (ignore disp item time rect)) - (gfs:dispose *main-win*) - (setf *main-win* nil) - (gfw:shutdown 0)) - (defun run-windlg-internal () (let ((menubar nil)) (setf *main-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'main-win-events) :style '(:style-workspace))) (setf menubar (gfw:defmenu ((:item "&File" - :submenu ((:item "E&xit" :callback #'exit-callback))) + :submenu ((:item "E&xit" :callback #'windlg-exit-fn))) (:item "&Windows" :submenu ((:item "&Borderless" :callback #'create-borderless-win) (:item "&Mini Frame" :callback #'create-miniframe-win) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Fri Mar 24 16:59:39 2006 @@ -60,12 +60,18 @@ (defgeneric depth (object) (:documentation "Returns the bits-per-pixel depth of the object.")) -(defgeneric draw-arc (object rect start-angle arc-angle) - (:documentation "Draws the outline of a circular or elliptical arc within the specified rectangular area.")) +(defgeneric draw-arc (object rect start-pnt end-pnt direction) + (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) -(defgeneric draw-filled-arc (object rect start-angle arc-angle) +(defgeneric draw-chord (object rect start-pnt end-pnt direction) + (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) + +(defgeneric draw-filled-wedge (object rect start-pnt end-pnt direction) (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) +(defgeneric draw-filled-chord (object rect start-pnt end-pnt) + (:documentation "Fills a region bounded by the intersection of an ellipse and a line segment.")) + (defgeneric draw-filled-oval (object rect) (:documentation "Fills the interior of the oval defined by a rectangle in the current background color.")) From junrue at common-lisp.net Sat Mar 25 04:23:25 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 24 Mar 2006 23:23:25 -0500 (EST) Subject: [graphic-forms-cvs] r72 - in trunk/src: tests/uitoolkit uitoolkit/graphics uitoolkit/system uitoolkit/widgets Message-ID: <20060325042325.36F9F6D183@common-lisp.net> Author: junrue Date: Fri Mar 24 23:23:24 2006 New Revision: 72 Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/event.lisp Log: overhauled graphics-context to make use of ExtCreatePen for all pen attribute settings; updated wm-paint process-message accordingly Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 24 23:23:24 2006 @@ -52,18 +52,25 @@ (drawing-exit-fn self nil nil 0)) (defmethod gfw:event-paint ((self drawing-win-events) window time gc rect) - (declare (ignore window time)) + (declare (ignore time rect)) (setf (gfg:background-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect) + (setf (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc + (make-instance 'gfs:rectangle :location (gfs:make-point) + :size (gfw:client-size window))) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) (defun draw-rects (gc) - (setf (gfg:background-color gc) gfg:*color-blue*) - (gfg:draw-filled-rectangle gc - (make-instance 'gfs:rectangle :location (gfs:make-point :x 10 :y 10) - :size (gfs:make-size :width 100 :height 75)))) + (let ((pnt (gfs:make-point :x 10 :y 10)) + (size (gfs:make-size :width 80 :height 65))) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:background-color gc) gfg:*color-green*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:foreground-color gc) gfg:*color-green*) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun select-rects (disp item time rect) (declare (ignore disp item time rect)) @@ -80,6 +87,7 @@ (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* :style '(:style-workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) + (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) (gfw:show *drawing-win* t))) (defun run-drawing-tester () Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Fri Mar 24 23:23:24 2006 @@ -47,6 +47,7 @@ (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-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*) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 23:23:24 2006 @@ -54,6 +54,7 @@ (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) (setf (gfg:background-color gc) gfg:*color-white*) + (setf (gfg:foreground-color gc) gfg:*color-white*) (gfg:draw-filled-rectangle gc rect)) (defclass test-mini-events (test-win-events) ()) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Fri Mar 24 23:23:24 2006 @@ -82,7 +82,31 @@ (defclass font (gfs:native-object) () (:documentation "This class encapsulates a realized native font.")) -(defclass graphics-context (gfs:native-object) () +(defclass graphics-context (gfs:native-object) + ((owns-dc + :accessor owns-dc + :initform nil) + (logbrush-style + :accessor logbrush-style-of + :initform gfs::+bs-solid+) + (logbrush-color + :accessor logbrush-color-of + :initform 0) ; initialize-instance sets this to black + (logbrush-hatch + :accessor logbrush-hatch-of + :initform gfs::+hs-bdiagonal+) ; doesn't matter because +bs-solid+ is set + (pen-style + :accessor pen-style-of + :initform (logior gfs::+ps-cosmetic+ gfs::+ps-solid+)) ; fast by default + (pen-width + :accessor pen-width-of + :initform 1) + (pen-handle + :accessor pen-handle-of + :initform (cffi:null-pointer)) + (orig-pen-handle + :accessor orig-pen-handle-of + :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) (defclass image (gfs:native-object) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Mar 24 23:23:24 2006 @@ -37,33 +37,85 @@ ;;; helper functions ;;; +(defun update-pen-for-gc (gc) + (cffi:with-foreign-object (lb-ptr 'gfs::logbrush) + (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr gfs::logbrush) + (setf gfs::style (logbrush-style-of gc)) + (setf gfs::color (logbrush-color-of gc)) + (setf gfs::hatch (logbrush-hatch-of gc)) + (let ((old-hpen (cffi:null-pointer)) + (new-hpen (gfs::ext-create-pen (pen-style-of gc) + (pen-width-of gc) + lb-ptr 0 + (cffi:null-pointer)))) + (if (gfs:null-handle-p new-hpen) + (error 'gfs:win32-error :detail "ext-create-pen failed")) + (setf (pen-handle-of gc) new-hpen) + (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen)) + (if (gfs:null-handle-p (orig-pen-handle-of gc)) + (setf (orig-pen-handle-of gc) old-hpen) + (unless (gfs:null-handle-p old-hpen) + (gfs::delete-object old-hpen))))))) + ;;; ;;; methods ;;; -(defmethod gfs:dispose ((gc graphics-context)) - (gfs::delete-dc (gfs:handle gc)) - (setf (slot-value gc 'gfs:handle) nil)) - -(defmethod background-color ((gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod background-color ((self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-bk-color (gfs:handle gc))) + (gfs::get-bk-color (gfs:handle self))) -(defmethod (setf background-color) ((clr color) (gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod (setf background-color) ((clr color) (self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle gc)) + (let ((hdc (gfs:handle self)) (hbrush (gfs::get-stock-object gfs::+dc-brush+)) (rgb (color-as-rgb clr))) (gfs::select-object hdc hbrush) (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) -(defmethod draw-filled-rectangle ((gc graphics-context) (rect gfs:rectangle)) - (if (gfs:disposed-p gc) +(defmethod gfs:dispose ((self graphics-context)) + (unless (gfs:null-handle-p (orig-pen-handle-of self)) + (gfs::select-object (gfs:handle self) (orig-pen-handle-of self))) + (setf (orig-pen-handle-of self) nil) + (gfs::delete-object (pen-handle-of self)) + (setf (pen-handle-of self) nil) + (if (owns-dc self) + (gfs::delete-dc (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle gc)) + (let ((hdc (gfs:handle self)) + (pnt (gfs:location rect)) + (size (gfs:size rect))) + (gfs::rectangle hdc + (gfs:point-x pnt) + (gfs:point-y pnt) + (+ (gfs:point-x pnt) (gfs:size-width size)) + (+ (gfs:point-y pnt) (gfs:size-height size))))) + +(defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let* ((hdc (gfs:handle self)) + (tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) + (orig-hbr (gfs::select-object hdc tmp-hbr))) + (unwind-protect + (draw-filled-rectangle self rect) + (gfs::select-object hdc orig-hbr)))) + +;;; FIXME: consider preserving this version as a "fast path" +;;; rectangle filler. +;;; +#| +(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle self)) (pnt (gfs:location rect)) (size (gfs:size rect))) (cffi:with-foreign-object (rect-ptr 'gfs::rect) @@ -81,16 +133,17 @@ "" 0 (cffi:null-pointer)))))) +|# ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; -(defmethod draw-image ((gc graphics-context) (im image) (pnt gfs:point)) - (if (gfs:disposed-p gc) +(defmethod draw-image ((self graphics-context) (im image) (pnt gfs:point)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (if (gfs:disposed-p im) (error 'gfs:disposed-error)) - (let ((gc-dc (gfs:handle gc)) + (let ((gc-dc (gfs:handle self)) (himage (gfs:handle im)) (memdc (gfs::create-compatible-dc (cffi:null-pointer)))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) @@ -137,21 +190,21 @@ 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc))) -(defmethod draw-text ((gc graphics-context) text (pnt gfs:point)) - (if (gfs:disposed-p gc) +(defmethod draw-text ((self graphics-context) text (pnt gfs:point)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (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::left (gfs:point-x pnt)) (setf gfs::top (gfs:point-y pnt)) - (gfs::draw-text (gfs:handle gc) + (gfs::draw-text (gfs:handle self) text -1 rect-ptr (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) (cffi:null-pointer)) - (gfs::draw-text (gfs:handle gc) + (gfs::draw-text (gfs:handle self) text (length text) rect-ptr @@ -161,17 +214,22 @@ gfs::+dt-vcenter+) (cffi:null-pointer))))) -(defmethod foreground-color ((gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod foreground-color ((self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-text-color (gfs:handle gc))) + (gfs::get-text-color (gfs:handle self))) -(defmethod (setf foreground-color) ((clr color) (gc graphics-context)) - (if (gfs:disposed-p gc) +(defmethod (setf foreground-color) ((clr color) (self graphics-context)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle gc)) - (hpen (gfs::get-stock-object gfs::+dc-pen+)) - (rgb (color-as-rgb clr))) - (gfs::select-object hdc hpen) - (gfs::set-dc-pen-color hdc rgb) - (gfs::set-text-color hdc rgb))) + (let ((rgb (color-as-rgb clr))) + (gfs::set-text-color (gfs:handle self) rgb) + (setf (logbrush-color-of self) rgb) + (update-pen-for-gc self))) + +(defmethod initialize-instance :after ((self graphics-context) &key) + (when (null (gfs:handle self)) + (setf (owns-dc self) t) + (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + (setf (logbrush-color-of self) (color-as-rgb (make-color :red 0 :green 0 :blue 0))) + (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Mar 24 23:23:24 2006 @@ -99,6 +99,13 @@ (offset DWORD)) (defcfun + ("CreatePen" create-pen) + HANDLE + (style INT) + (width INT) + (color COLORREF)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE)) @@ -119,6 +126,15 @@ (params LPTR)) (defcfun + ("ExtCreatePen" ext-create-pen) + HANDLE + (style DWORD) + (width DWORD) + (logbrush LPTR) + (count DWORD) + (stylearray LPTR)) + +(defcfun ("ExtTextOutA" ext-text-out) BOOL (hdc HANDLE) @@ -203,6 +219,15 @@ (rop DWORD)) (defcfun + ("Rectangle" rectangle) + BOOL + (hdc HANDLE) + (x1 INT) + (y1 INT) + (x2 INT) + (y2 INT)) + +(defcfun ("SelectObject" select-object) HANDLE (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 Fri Mar 24 23:23:24 2006 @@ -61,6 +61,18 @@ (defconstant +blt-captureblt+ #x40000000) (defconstant +blt-nomirrorbitmap+ #x80000000) +(defconstant +bs-solid+ 0) +(defconstant +bs-null+ 1) +(defconstant +bs-hollow+ 1) +(defconstant +bs-hatched+ 2) +(defconstant +bs-pattern+ 3) +(defconstant +bs-indexed+ 4) +(defconstant +bs-dibpattern+ 5) +(defconstant +bs-dibpatternpt+ 6) +(defconstant +bs-pattern8x8+ 7) +(defconstant +bs-dibpattern8x8+ 8) +(defconstant +bs-monopattern+ 9) + (defconstant +bs-pushbutton+ #x00000000) (defconstant +bs-defpushbutton+ #x00000001) (defconstant +bs-checkbox+ #x00000002) @@ -208,6 +220,13 @@ (defconstant +gwl-exstyle+ -20) (defconstant +gwl-userdata+ -21) +(defconstant +hs-horizontal+ 0) +(defconstant +hs-vertical+ 1) +(defconstant +hs-fdiagonal+ 2) +(defconstant +hs-bdiagonal+ 3) +(defconstant +hs-cross+ 4) +(defconstant +hs-diagcross+ 5) + (defconstant +image-bitmap+ 0) (defconstant +image-icon+ 1) (defconstant +image-cursor+ 2) @@ -384,6 +403,28 @@ (defconstant +pm-qs-paint+ (ash +qs-paint+ 16)) (defconstant +pm-qs-sendmessage+ (ash +qs-sendmessage+ 16)) +(defconstant +ps-solid+ 0) +(defconstant +ps-dash+ 1) +(defconstant +ps-dot+ 2) +(defconstant +ps-dashdot+ 3) +(defconstant +ps-dashdotdot+ 4) +(defconstant +ps-null+ 5) +(defconstant +ps-insideframe+ 6) +(defconstant +ps-userstyle+ 7) +(defconstant +ps-alternate+ 8) +(defconstant +ps-style_mask+ #x0000000f) +(defconstant +ps-endcap_round+ #x00000000) +(defconstant +ps-endcap_square+ #x00000100) +(defconstant +ps-endcap_flat+ #x00000200) +(defconstant +ps-endcap_mask+ #x00000f00) +(defconstant +ps-join_round+ #x00000000) +(defconstant +ps-join_bevel+ #x00001000) +(defconstant +ps-join_miter+ #x00002000) +(defconstant +ps-join_mask+ #x0000f000) +(defconstant +ps-cosmetic+ #x00000000) +(defconstant +ps-geometric+ #x00010000) +(defconstant +ps-type_mask+ #x000f0000) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 24 23:23:24 2006 @@ -114,6 +114,11 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct logbrush + (style UINT) + (color COLORREF) + (hatch LONG)) + (defcstruct menuinfo (cbsize DWORD) (mask DWORD) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Mar 24 23:23:24 2006 @@ -285,9 +285,8 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) (declare (ignore wparam lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) - (gc (make-instance 'gfg:graphics-context))) - (if w + (widget (get-widget tc hwnd))) + (if widget (let ((rct (make-instance 'gfs:rectangle))) (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct) (cffi:with-foreign-slots ((gfs::rcpaint-x @@ -295,14 +294,15 @@ gfs::rcpaint-width gfs::rcpaint-height) ps-ptr gfs::paintstruct) - (setf (slot-value gc 'gfs:handle) (gfs::begin-paint hwnd ps-ptr)) (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x - :y gfs::rcpaint-y)) + :y gfs::rcpaint-y)) (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width - :height gfs::rcpaint-height)) - (unwind-protect - (event-paint (dispatcher w) w (event-time tc) gc rct) - (gfs::end-paint hwnd ps-ptr))))) + :height gfs::rcpaint-height)) + (let* ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) + (unwind-protect + (event-paint (dispatcher widget) widget (event-time tc) gc rct) + (gfs:dispose gc) + (gfs::end-paint hwnd ps-ptr)))))) (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0) From junrue at common-lisp.net Mon Mar 27 00:05:17 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 26 Mar 2006 19:05:17 -0500 (EST) Subject: [graphic-forms-cvs] r73 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060327000517.546E65080@common-lisp.net> Author: junrue Date: Sun Mar 26 19:05:16 2006 New Revision: 73 Added: trunk/src/tests/uitoolkit/color-unit-tests.lisp trunk/src/tests/uitoolkit/graphics-context-unit-tests.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/color.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: filled out pen-related slots and functions for graphics-context; implemented draw-rectangle function and started drawing tester program Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Mar 26 19:05:16 2006 @@ -699,6 +699,77 @@ This subclass of @ref{native-object} wraps a native device context, hence instances of this class are used to perform drawing operations. One normally obtains a graphics-context via @ref{event-paint}. + at anchor{miter-limit} + at deffn Accessor miter-limit +This accessor accepts or returns a floating point value that +describes the allowable ratio of miter length to line width, +which affects the behavior of the @code{:miter-join} pen style. +The miter length is the distance from the intersection of the +line walls on the inside of a join to the intersection of the +line walls on the outside of the same join. +The default value is @code{10.0}. + at end deffn + at anchor{pen-style} + at deffn Accessor pen-style +This accessor accepts or returns a list of pen style keywords. The +primary style keywords are: + at table @code + at item :alternate +Draws a line in which every other pixel is set. + + at item :dash +Draws a dashed line. + + at item :dashdot +Draws a line with alternating dashes and dots. + + at item :dashdotdot +Draws a line with alternating dashes and double dots. + + at item :dot +Draws a dotted line. + + at item :solid +Draws a solid line. + at end table + +One of the following end cap style keywords may also be specified: + at table @code + at item :flat-endcap +Line end caps will be flat. + + at item :round-endcap +Line end caps will be round. + + at item :square-endcap +Line end caps will be square. + at end table + +One of the following join style keywords may also be specified: + at table @code + at item :bevel-join +Line joins will be beveled. + + at item :miter-join +Line joins will be mitered if the ratio of miter length to line width +is within the @ref{miter-limit}. + + at item :round-join +Line joins will be rounded. + at end table + +The default pen style is equivalent to @code{(:flat :square-endcap +:round-bevel)}. + +Specifying @code{nil} for @code{pen-style} equates to selecting the +Win32 @sc{PS_NULL} pen style, meaning that the pen is invisible. + at end deffn + at anchor{pen-width} + at deffn Accessor pen-width +This accessor accepts or returns the pen width. The minimum allowed +value is 0, which translates to a 1 pixel-wide line drawn with an +optimized drawing algorithm. + at end deffn @end deftp @deftp Class image-data @@ -713,6 +784,7 @@ in future releases, they just aren't all documented or implemented at this time. + at anchor{background-color} @deffn GenericFunction background-color self Returns a color object corresponding to the current background color. @end deffn @@ -726,13 +798,22 @@ @end deffn @deffn GenericFunction draw-filled-rectangle self rect -Fills the interior of the rectangle in the current background color. +Fills the interior of a rectangle in the current background color. +The current foreground color, pen width, and pen style will be used to +draw an outline for the rectangle. See also @ref{background-color}, + at ref{foreground-color}, @ref{pen-style}, and @ref{pen-width}. @end deffn @deffn GenericFunction draw-image self im pnt Draws the given image in the receiver at the specified coordinates. @end deffn + at deffn GenericFunction draw-rectangle self rect +Draws the outline of a rectangle in the current foreground color, +using the current pen width and style. See also @ref{background-color}, + at ref{pen-style} and @ref{pen-width}. + at end deffn + @deffn GenericFunction draw-text self text pnt Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string. @@ -742,6 +823,7 @@ Returns the current font. @end deffn + at anchor{foreground-color} @deffn GenericFunction foreground-color self Returns a color object corresponding to the current foreground color. @end deffn Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 26 19:05:16 2006 @@ -54,6 +54,8 @@ ((:module "uitoolkit" :components ((:file "mock-objects") + (:file "color-unit-tests") + (:file "graphics-context-unit-tests") (:file "image-unit-tests") (:file "layout-unit-tests") (:file "hello-world") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 26 19:05:16 2006 @@ -122,7 +122,7 @@ #:blue-shift #:clipped-p #:clipping-rectangle - #:color-as-rgb + #:color->rgb #:color-blue #:color-green #:color-red @@ -167,6 +167,8 @@ #:maximum-char-width #:metrics #:multiply + #:pen-style + #:pen-width #:red-mask #:red-shift #:rotate Added: trunk/src/tests/uitoolkit/color-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/color-unit-tests.lisp Sun Mar 26 19:05:16 2006 @@ -0,0 +1,45 @@ +;;;; +;;;; color-unit-tests.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) + +(define-test color-conversion-test + (let ((c1 (gfg:make-color)) + (c2 (gfg:make-color :red 12 :green 34 :blue 56)) + (c3 (gfg:make-color :red 255 :green 128 :blue 0)) + (c4 (gfg:make-color :red 255 :green 255 :blue 255))) + (loop for clr in (list c1 c2 c3 c4) + do (let ((rgb (gfg::color->rgb clr))) + (assert-equal (gfg:color-red clr) (gfg:color-red (gfg::rgb->color rgb))) + (assert-equal (gfg:color-green clr) (gfg:color-green (gfg::rgb->color rgb))) + (assert-equal (gfg:color-blue clr) (gfg:color-blue (gfg::rgb->color rgb))))))) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Mar 26 19:05:16 2006 @@ -63,14 +63,42 @@ (funcall func gc)))) (defun draw-rects (gc) - (let ((pnt (gfs:make-point :x 10 :y 10)) + (let ((pnt (gfs:make-point :x 15 :y 15)) (size (gfs:make-size :width 80 :height 65))) + (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 1) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) (setf (gfg:foreground-color gc) gfg:*color-green*) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) + (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + + (setf (gfs:point-x pnt) 15) + (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun select-rects (disp item time rect) (declare (ignore disp item time rect)) @@ -88,6 +116,7 @@ :style '(:style-workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) (setf (gfw:size *drawing-win*) (gfs:make-size :width 390 :height 310)) + (setf (gfw:text *drawing-win*) "Drawing Tester") (gfw:show *drawing-win* t))) (defun run-drawing-tester () Added: trunk/src/tests/uitoolkit/graphics-context-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/graphics-context-unit-tests.lisp Sun Mar 26 19:05:16 2006 @@ -0,0 +1,66 @@ +;;;; +;;;; graphics-context-unit-tests.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) + +(define-test pen-styles-test + (let ((style1 nil) + (style2 '(:solid)) + (style3 '(:dash :flat-endcap)) + (style4 '(:dot :miter-join)) + (style5 '(:alternate :flat-endcap :bevel-join))) + (dotimes (width 3) + (assert-equal (logior gfs::+ps-cosmetic+ + gfs::+ps-null+) + (gfg::compute-pen-style style1 width) + (list style1 width)) + (assert-equal (logior (if (< width 2) gfs::+ps-cosmetic+ gfs::+ps-geometric+) + gfs::+ps-solid+) + (gfg::compute-pen-style style2 width) + (list style2 width)) + (assert-equal (logior gfs::+ps-geometric+ + gfs::+ps-dash+ + gfs::+ps-endcap-flat+) + (gfg::compute-pen-style style3 width) + (list style3 width)) + (assert-equal (logior gfs::+ps-geometric+ + gfs::+ps-dot+ + gfs::+ps-join-miter+) + (gfg::compute-pen-style style4 width) + (list style4 width)) + (assert-equal (logior gfs::+ps-geometric+ + gfs::+ps-alternate+ + gfs::+ps-endcap-flat+ + gfs::+ps-join-bevel+) + (gfg::compute-pen-style style5 width) + (list style5 width))))) Modified: trunk/src/uitoolkit/graphics/color.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/color.lisp (original) +++ trunk/src/uitoolkit/graphics/color.lisp Sun Mar 26 19:05:16 2006 @@ -34,13 +34,20 @@ (in-package :graphic-forms.uitoolkit.graphics) (eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro color-as-rgb (color) + (defmacro color->rgb (color) (let ((result (gensym))) `(let ((,result 0)) (setf (ldb (byte 8 0) ,result) (color-red ,color)) (setf (ldb (byte 8 8) ,result) (color-green ,color)) (setf (ldb (byte 8 16) ,result) (color-blue ,color)) - ,result)))) + ,result))) + + (defmacro rgb->color (colorref) + (let ((color (gensym))) + `(let ((,color (make-color :red (ldb (byte 8 0) ,colorref) + :green (ldb (byte 8 8) ,colorref) + :blue (ldb (byte 8 16) ,colorref)))) + ,color)))) (defvar *color-black* (make-color :red 0 :green 0 :blue 0)) (defvar *color-blue* (make-color :red 0 :green 0 :blue #xFF)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sun Mar 26 19:05:16 2006 @@ -91,15 +91,18 @@ :initform gfs::+bs-solid+) (logbrush-color :accessor logbrush-color-of - :initform 0) ; initialize-instance sets this to black + :initform 0) (logbrush-hatch :accessor logbrush-hatch-of - :initform gfs::+hs-bdiagonal+) ; doesn't matter because +bs-solid+ is set + :initform gfs::+hs-bdiagonal+) + (miter-limit + :accessor miter-limit + :initform 10.0) (pen-style - :accessor pen-style-of - :initform (logior gfs::+ps-cosmetic+ gfs::+ps-solid+)) ; fast by default + :accessor pen-style + :initform '(:solid)) (pen-width - :accessor pen-width-of + :accessor pen-width :initform 1) (pen-handle :accessor pen-handle-of Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 26 19:05:16 2006 @@ -37,6 +37,44 @@ ;;; helper functions ;;; +(defun compute-pen-style (style width) + (let ((main-styles (list (cons :alternate gfs::+ps-alternate+) + (cons :dash gfs::+ps-dash+) + (cons :dashdotdot gfs::+ps-dashdotdot+) + (cons :dot gfs::+ps-dot+) + (cons :solid gfs::+ps-solid+))) + (endcap-styles (list (cons :flat-endcap gfs::+ps-endcap-flat+) + (cons :round-endcap gfs::+ps-endcap-round+) + (cons :square-endcap gfs::+ps-endcap-square+))) + (join-styles (list (cons :bevel-join gfs::+ps-join-bevel+) + (cons :miter-join gfs::+ps-join-miter+) + (cons :round-join gfs::+ps-join-round+))) + (native-style (if (> width 1) gfs::+ps-geometric+ gfs::+ps-cosmetic+)) + (tmp nil)) + (if (null style) + (return-from compute-pen-style (logior gfs::+ps-cosmetic+ gfs::+ps-null+))) + (setf tmp (intersection style (mapcar #'first main-styles))) + (if (/= (length tmp) 1) + (error 'gfs:toolkit-error :detail "one main pen style keyword is required")) + (setf native-style (logior native-style (cdr (assoc (car tmp) main-styles)))) + (setf tmp (intersection style (mapcar #'first endcap-styles))) + (if (> (length tmp) 1) + (error 'gfs:toolkit-error :detail "only one end cap pen style keyword is allowed")) + (setf native-style (logior native-style (if tmp + (cdr (assoc (car tmp) endcap-styles)) 0))) + (unless (null tmp) + (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+)) + gfs::+ps-geometric+))) + (setf tmp (intersection style (mapcar #'first join-styles))) + (if (> (length tmp) 1) + (error 'gfs:toolkit-error :detail "only one join pen style keyword is allowed")) + (setf native-style (logior native-style (if tmp + (cdr (assoc (car tmp) join-styles)) 0))) + (unless (null tmp) + (setf native-style (logior (logand native-style (lognot gfs::+ps-cosmetic+)) + gfs::+ps-geometric+))) + native-style)) + (defun update-pen-for-gc (gc) (cffi:with-foreign-object (lb-ptr 'gfs::logbrush) (cffi:with-foreign-slots ((gfs::style gfs::color gfs::hatch) lb-ptr gfs::logbrush) @@ -44,14 +82,15 @@ (setf gfs::color (logbrush-color-of gc)) (setf gfs::hatch (logbrush-hatch-of gc)) (let ((old-hpen (cffi:null-pointer)) - (new-hpen (gfs::ext-create-pen (pen-style-of gc) - (pen-width-of gc) + (new-hpen (gfs::ext-create-pen (compute-pen-style (pen-style gc) (pen-width gc)) + (pen-width gc) lb-ptr 0 (cffi:null-pointer)))) (if (gfs:null-handle-p new-hpen) (error 'gfs:win32-error :detail "ext-create-pen failed")) (setf (pen-handle-of gc) new-hpen) (setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen)) + (gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer)) (if (gfs:null-handle-p (orig-pen-handle-of gc)) (setf (orig-pen-handle-of gc) old-hpen) (unless (gfs:null-handle-p old-hpen) @@ -64,14 +103,14 @@ (defmethod background-color ((self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-bk-color (gfs:handle self))) + (rgb->color (gfs::get-bk-color (gfs:handle self)))) (defmethod (setf background-color) ((clr color) (self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((hdc (gfs:handle self)) (hbrush (gfs::get-stock-object gfs::+dc-brush+)) - (rgb (color-as-rgb clr))) + (rgb (color->rgb clr))) (gfs::select-object hdc hbrush) (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) @@ -157,8 +196,8 @@ (white (make-color :red #xFF :green #xFF :blue #xFF))) (gfs::select-object memdc hmask) (gfs::select-object memdc2 hcopy) - (gfs::set-bk-color memdc2 (color-as-rgb black)) - (gfs::set-text-color memdc2 (color-as-rgb white)) + (gfs::set-bk-color memdc2 (color->rgb black)) + (gfs::set-text-color memdc2 (color->rgb white)) (gfs::bit-blt memdc2 0 0 gfs::width @@ -217,12 +256,12 @@ (defmethod foreground-color ((self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (gfs::get-text-color (gfs:handle self))) + (rgb->color (gfs::get-text-color (gfs:handle self)))) (defmethod (setf foreground-color) ((clr color) (self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((rgb (color-as-rgb clr))) + (let ((rgb (color->rgb clr))) (gfs::set-text-color (gfs:handle self) rgb) (setf (logbrush-color-of self) rgb) (update-pen-for-gc self))) @@ -231,5 +270,16 @@ (when (null (gfs:handle self)) (setf (owns-dc self) t) (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) - (setf (logbrush-color-of self) (color-as-rgb (make-color :red 0 :green 0 :blue 0))) + (update-pen-for-gc self)) + +(defmethod (setf pen-style) :around (style (self graphics-context)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (setf (slot-value self 'pen-style) style) + (update-pen-for-gc self)) + +(defmethod (setf pen-width) :around (width (self graphics-context)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (setf (slot-value self 'pen-width) width) (update-pen-for-gc self)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 26 19:05:16 2006 @@ -33,155 +33,155 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defgeneric alpha (object) +(defgeneric alpha (self) (:documentation "Returns an integer representing an alpha value.")) -(defgeneric anti-alias (object) +(defgeneric anti-alias (self) (:documentation "Returns an int representing the current anti-alias setting.")) -(defgeneric background-color (object) +(defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric background-pattern (object) +(defgeneric background-pattern (self) (:documentation "Returns a pattern object representing the current background pattern.")) -(defgeneric clipped-p (object) +(defgeneric clipped-p (self) (:documentation "Returns T if a clipping region is set; nil otherwise.")) -(defgeneric clipping-rectangle (object) +(defgeneric clipping-rectangle (self) (:documentation "Returns a rectangle object representing the current clipping rectangle.")) -(defgeneric copy-area (object src-rect dest-pnt) +(defgeneric copy-area (self src-rect dest-pnt) (:documentation "Copies a rectangular area of the source onto the destination.")) -(defgeneric data-obj (object) +(defgeneric data-obj (self) (:documentation "Returns the data structure representing the raw form of the object.")) -(defgeneric depth (object) +(defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) -(defgeneric draw-arc (object rect start-pnt end-pnt direction) +(defgeneric draw-arc (self rect start-pnt end-pnt direction) (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) -(defgeneric draw-chord (object rect start-pnt end-pnt direction) +(defgeneric draw-chord (self rect start-pnt end-pnt direction) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) -(defgeneric draw-filled-wedge (object rect start-pnt end-pnt direction) - (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) - -(defgeneric draw-filled-chord (object rect start-pnt end-pnt) +(defgeneric draw-filled-chord (self rect start-pnt end-pnt) (:documentation "Fills a region bounded by the intersection of an ellipse and a line segment.")) -(defgeneric draw-filled-oval (object rect) +(defgeneric draw-filled-oval (self rect) (:documentation "Fills the interior of the oval defined by a rectangle in the current background color.")) -(defgeneric draw-filled-polygon (object points) +(defgeneric draw-filled-polygon (self points) (:documentation "Fills the interior of the closed polygon defined by points in the current background color.")) -(defgeneric draw-filled-rectangle (object rect) - (:documentation "Fills the interior of the rectangle in the current background color.")) +(defgeneric draw-filled-rectangle (self rect) + (:documentation "Fills the interior of a rectangle in the current background color.")) -(defgeneric draw-filled-rounded-rectangle (object rect arc-width arc-height) +(defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) (:documentation "Fills the interior of the rectangle with rounded corners in the current background color.")) -(defgeneric draw-focus (object rect) +(defgeneric draw-filled-wedge (self rect start-pnt end-pnt direction) + (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) + +(defgeneric draw-focus (self rect) (:documentation "Draws a rectangle having the appearance of a focus rectangle.")) -(defgeneric draw-image (object im pnt) +(defgeneric draw-image (self im pnt) (:documentation "Draws the given image in the receiver at the specified coordinates.")) -(defgeneric draw-line (object pnt-1 pnt-2) +(defgeneric draw-line (self pnt-1 pnt-2) (:documentation "Draws a line using the foreground color between (x1, y1) and (x2, y2).")) -(defgeneric draw-oval (object rect) +(defgeneric draw-oval (self rect) (:documentation "Draws the outline of an oval in the foreground color with the specified rectangular area.")) -(defgeneric draw-point (object pnt) +(defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) -(defgeneric draw-polygon (object points) +(defgeneric draw-polygon (self points) (:documentation "Draws the closed polygon defined by the list of points in the current foreground color.")) -(defgeneric draw-polyline (object points) +(defgeneric draw-polyline (self points) (:documentation "Draws the polyline defined by the list of points in the current foreground color.")) -(defgeneric draw-rectangle (object rect) - (:documentation "Draws the outline of the rectangle in the current foreground color.")) +(defgeneric draw-rectangle (self rect) + (:documentation "Draws the outline of a rectangle in the current foreground color.")) -(defgeneric draw-rounded-rectangle (object rect arc-width arc-height) +(defgeneric draw-rounded-rectangle (self rect arc-width arc-height) (:documentation "Draws the outline of the rectangle with rounded corners in the current foreground color.")) -(defgeneric draw-text (object text pnt) +(defgeneric draw-text (self text pnt) (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string.")) -(defgeneric fill-rule (object) +(defgeneric fill-rule (self) (:documentation "Returns an integer specifying the current fill rule.")) -(defgeneric font (object) +(defgeneric font (self) (:documentation "Returns the current font.")) -(defgeneric foreground-color (object) +(defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric foreground-pattern (object) +(defgeneric foreground-pattern (self) (:documentation "Returns a pattern object representing the current foreground pattern.")) -(defgeneric invert (object) +(defgeneric invert (self) (:documentation "Returns a modified version of the object which is the mathematical inverse of the original.")) -(defgeneric line-cap-style (object) +(defgeneric line-cap-style (self) (:documentation "Returns an integer representing the line cap style.")) -(defgeneric line-dash-style (object) +(defgeneric line-dash-style (self) (:documentation "Returns a list of integers representing the line dash style.")) -(defgeneric line-join-style (object) +(defgeneric line-join-style (self) (:documentation "Returns an integer representing the line join style.")) -(defgeneric line-style (object) +(defgeneric line-style (self) (:documentation "Returns an integer representing the line style.")) -(defgeneric line-width (object) +(defgeneric line-width (self) (:documentation "Returns an integer representing the line width.")) -(defgeneric load (object path) +(defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) -(defgeneric matrix (object) +(defgeneric matrix (self) (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) -(defgeneric metrics (object) +(defgeneric metrics (self) (:documentation "Returns a metrics object describing key attributes of the specified object.")) -(defgeneric multiply (object other) +(defgeneric multiply (self other) (:documentation "Returns a modified version of the object which is the result of multiplying the original with the other parameter.")) -(defgeneric rotate (object angle) +(defgeneric rotate (self angle) (:documentation "Returns a modified version of the object which is the result of rotating the original by the specified angle.")) -(defgeneric scale (object delta-x delta-y) +(defgeneric scale (self delta-x delta-y) (:documentation "Returns a modified version of the object which is the result of scaling the original by the specified mathematical vector.")) -(defgeneric size (object) +(defgeneric size (self) (:documentation "Returns a size object describing the size of the object.")) -(defgeneric text-anti-alias (object) +(defgeneric text-anti-alias (self) (:documentation "Returns an integer representing the text anti-alias setting.")) -(defgeneric text-extent (object str) +(defgeneric text-extent (self str) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) -(defgeneric transform (object) +(defgeneric transform (self) (:documentation "Returns a transform object indicating how coordinates are transformed in the context of this object.")) -(defgeneric transform-coordinates (object pnts) +(defgeneric transform-coordinates (self pnts) (:documentation "Returns a list of point objects that are the result of applying a transformation against the specified list of points.")) -(defgeneric translate (object delta-x delta-y) +(defgeneric translate (self delta-x delta-y) (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) -(defgeneric transparency-mask (object) +(defgeneric transparency-mask (self) (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) -(defgeneric xor-mode-p (object) +(defgeneric xor-mode-p (self) (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 26 19:05:16 2006 @@ -263,6 +263,13 @@ (color-use UINT)) (defcfun + ("SetMiterLimit" set-miter-limit) + BOOL + (hdc HANDLE) + (newlimit :float) + (oldlimit LPTR)) + +(defcfun ("SetTextColor" set-text-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 Sun Mar 26 19:05:16 2006 @@ -412,18 +412,18 @@ (defconstant +ps-insideframe+ 6) (defconstant +ps-userstyle+ 7) (defconstant +ps-alternate+ 8) -(defconstant +ps-style_mask+ #x0000000f) -(defconstant +ps-endcap_round+ #x00000000) -(defconstant +ps-endcap_square+ #x00000100) -(defconstant +ps-endcap_flat+ #x00000200) -(defconstant +ps-endcap_mask+ #x00000f00) -(defconstant +ps-join_round+ #x00000000) -(defconstant +ps-join_bevel+ #x00001000) -(defconstant +ps-join_miter+ #x00002000) -(defconstant +ps-join_mask+ #x0000f000) +(defconstant +ps-style-mask+ #x0000000f) +(defconstant +ps-endcap-round+ #x00000000) +(defconstant +ps-endcap-square+ #x00000100) +(defconstant +ps-endcap-flat+ #x00000200) +(defconstant +ps-endcap-mask+ #x00000f00) +(defconstant +ps-join-round+ #x00000000) +(defconstant +ps-join-bevel+ #x00001000) +(defconstant +ps-join-miter+ #x00002000) +(defconstant +ps-join-mask+ #x0000f000) (defconstant +ps-cosmetic+ #x00000000) (defconstant +ps-geometric+ #x00010000) -(defconstant +ps-type_mask+ #x000f0000) +(defconstant +ps-type-mask+ #x000f0000) (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) From junrue at common-lisp.net Mon Mar 27 04:52:48 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 26 Mar 2006 23:52:48 -0500 (EST) Subject: [graphic-forms-cvs] r74 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060327045248.A98697E000@common-lisp.net> Author: junrue Date: Sun Mar 26 23:52:47 2006 New Revision: 74 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp Log: implemented draw-arc, draw-chord, and draw-filled-chord graphics functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Mar 26 23:52:47 2006 @@ -797,11 +797,62 @@ Returns the bits-per-pixel depth of the object. @end deffn + at anchor{draw-arc} + at deffn GenericFunction draw-arc self rect start-pnt end-pnt +Draws an arc whose curve is formed by the ellipse bound by + at code{rect}, in a counter-clockwise direction from the point + at code{start-point} where it intersects a radial originating at the +center of the bounding rectangle. The arc ends at the point + at code{end-pnt} where it intersects another radial also originating at +the center of the rectangle. The shape is drawn using the current pen +style, pen width, and foreground color. If @code{start-pnt} and + at code{end-pnt} are the same, a complete ellipse is drawn. See also + at ref{draw-chord}. + at end deffn + + at anchor{draw-chord} + at deffn GenericFunction draw-chord self rect start-pnt end-pnt +Draws a closed shape comprised of: + at itemize @bullet + at item +an arc whose curve is formed by the ellipse bound by @code{rect}, in a +counter-clockwise direction from the point @code{start-point} where it +intersects a radial originating at the center of the bounding +rectangle. The arc ends at the point @code{end-pnt} where it +intersects another radial also originating at the center of the +rectangle. + at item +a line drawn between start-pnt and end-pnt + at end itemize +The shape is drawn using the current pen style, pen width and +foreground color. If @code{start-pnt} and @code{end-pnt} are the +same, a complete ellipse is drawn. See also @ref{draw-arc}. + at end deffn + + at anchor{draw-filled-chord} + at deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt +Draws a closed shape comprised of: + at itemize @bullet + at item +an arc whose curve is formed by the ellipse bound by @code{rect}, in a +counter-clockwise direction from the point @code{start-point} where it +intersects a radial originating at the center of the bounding +rectangle. The arc ends at the point @code{end-pnt} where it +intersects another radial also originating at the center of the +rectangle. + at item +a line drawn between start-pnt and end-pnt + at end itemize +The shape is drawn using the current pen style, pen width and +foreground color and filled with the current background color. If + at code{start-pnt} and @code{end-pnt} are the same, a complete ellipse +is drawn. + at end deffn + @deffn GenericFunction draw-filled-rectangle self rect Fills the interior of a rectangle in the current background color. The current foreground color, pen width, and pen style will be used to -draw an outline for the rectangle. See also @ref{background-color}, - at ref{foreground-color}, @ref{pen-style}, and @ref{pen-width}. +draw an outline for the rectangle. @end deffn @deffn GenericFunction draw-image self im pnt @@ -810,8 +861,7 @@ @deffn GenericFunction draw-rectangle self rect Draws the outline of a rectangle in the current foreground color, -using the current pen width and style. See also @ref{background-color}, - at ref{pen-style} and @ref{pen-width}. +using the current pen width and style. @end deffn @deffn GenericFunction draw-text self text pnt Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Mar 26 23:52:47 2006 @@ -132,7 +132,9 @@ #:depth #:descent #:draw-arc + #:draw-chord #:draw-filled-arc + #:draw-filled-chord #:draw-filled-oval #:draw-filled-polygon #:draw-filled-rectangle Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Mar 26 23:52:47 2006 @@ -35,6 +35,20 @@ (defvar *drawing-dispatcher* nil) (defvar *drawing-win* nil) +(defvar *last-checked-drawing-item* nil) + +(defun update-drawing-item-check (item) + (unless (null *last-checked-drawing-item*) + (gfw:check *last-checked-drawing-item* nil)) + (gfw:check item t)) + +(defun find-checked-item (disp menu time) + (declare (ignore disp time)) + (dotimes (i (gfw:item-count menu)) + (let ((item (gfw:item-at menu i))) + (when (gfw:checked-p item) + (setf *last-checked-drawing-item* item) + (return))))) (defun drawing-exit-fn (disp item time rect) (declare (ignore disp item time rect)) @@ -62,6 +76,91 @@ (unless (null func) (funcall func gc)))) +(defun draw-arcs (gc) + (let ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (start-pnt (gfs:make-point :x 15 :y 60)) + (end-pnt (gfs:make-point :x 75 :y 25)) + (delta-x 0) + (delta-y 0)) + + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (setf delta-x (+ (gfs:size-width rect-size) 10)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + + (setf (gfs:point-x rect-pnt) 15) + (setf (gfs:point-x start-pnt) 15) + (setf (gfs:point-x end-pnt) 75) + (setf delta-y (gfs:size-height rect-size)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-y pnt) delta-y)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (setf delta-x (+ (gfs:size-width rect-size) 10)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + + (setf (gfs:point-x rect-pnt) 15) + (setf (gfs:point-x start-pnt) 15) + (setf (gfs:point-x end-pnt) 75) + (setf delta-y (gfs:size-height rect-size)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-y pnt) delta-y)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + +(defun select-arcs (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) + (gfw:redraw *drawing-win*)) + (defun draw-rects (gc) (let ((pnt (gfs:make-point :x 15 :y 15)) (size (gfs:make-size :width 80 :height 65))) @@ -79,7 +178,7 @@ (setf (gfg:pen-width gc) 1) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) (setf (gfs:point-x pnt) 15) @@ -101,17 +200,21 @@ (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun select-rects (disp item time rect) - (declare (ignore disp item time rect)) + (declare (ignore disp time rect)) + (update-drawing-item-check item) (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) (defun run-drawing-tester-internal () + (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'drawing-exit-fn))) (:item "&Tests" - :submenu ((:item "&Rectangles" :checked :callback #'select-rects))))))) + :callback #'find-checked-item + :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) + (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) - (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) + (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* :style '(:style-workspace))) (setf (gfw:menu-bar *drawing-win*) menubar) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 26 23:52:47 2006 @@ -125,6 +125,48 @@ (gfs::delete-dc (gfs:handle self))) (setf (slot-value self 'gfs:handle) nil)) +(defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((rect-pnt (gfs:location rect)) + (rect-size (gfs:size rect))) + (if (zerop (gfs::arc (gfs:handle self) + (gfs:point-x rect-pnt) + (gfs:point-y rect-pnt) + (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) + (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) + (gfs:point-x start-pnt) + (gfs:point-y start-pnt) + (gfs:point-x end-pnt) + (gfs:point-y end-pnt))) + (error 'gfs:win32-error :detail "arc failed")))) + +(defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let* ((hdc (gfs:handle self)) + (tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) + (orig-hbr (gfs::select-object hdc tmp-hbr))) + (unwind-protect + (draw-filled-chord self rect start-pnt end-pnt) + (gfs::select-object hdc orig-hbr)))) + +(defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((rect-pnt (gfs:location rect)) + (rect-size (gfs:size rect))) + (if (zerop (gfs::chord (gfs:handle self) + (gfs:point-x rect-pnt) + (gfs:point-y rect-pnt) + (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) + (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) + (gfs:point-x start-pnt) + (gfs:point-y start-pnt) + (gfs:point-x end-pnt) + (gfs:point-y end-pnt))) + (error 'gfs:win32-error :detail "arc failed")))) + (defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 26 23:52:47 2006 @@ -60,10 +60,10 @@ (defgeneric depth (self) (:documentation "Returns the bits-per-pixel depth of the object.")) -(defgeneric draw-arc (self rect start-pnt end-pnt direction) +(defgeneric draw-arc (self rect start-pnt end-pnt) (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) -(defgeneric draw-chord (self rect start-pnt end-pnt direction) +(defgeneric draw-chord (self rect start-pnt end-pnt) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) (defgeneric draw-filled-chord (self rect start-pnt end-pnt) @@ -81,7 +81,7 @@ (defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) (:documentation "Fills the interior of the rectangle with rounded corners in the current background color.")) -(defgeneric draw-filled-wedge (self rect start-pnt end-pnt direction) +(defgeneric draw-filled-wedge (self rect start-pnt end-pnt) (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) (defgeneric draw-focus (self rect) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 26 23:52:47 2006 @@ -40,6 +40,19 @@ (load-foreign-library "msimg32.dll") (defcfun + ("Arc" arc) + BOOL + (hdc HANDLE) + (leftrect INT) + (toprect INT) + (rightrect INT) + (bottomrect INT) + (startx INT) + (starty INT) + (endx INT) + (endy INT)) + +(defcfun ("BitBlt" bit-blt) BOOL (hdc HANDLE) @@ -53,6 +66,19 @@ (rop DWORD)) (defcfun + ("Chord" chord) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) + (radial1x INT) + (radial1y INT) + (radial2x INT) + (radial2y INT)) + +(defcfun ("CreateBitmap" create-bitmap) HANDLE (width INT) @@ -234,6 +260,12 @@ (hgdiobj HANDLE)) (defcfun + ("SetArcDirection" set-arc-direction) + INT + (hdc HANDLE) + (direction INT)) + +(defcfun ("SetBkColor" set-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 Sun Mar 26 23:52:47 2006 @@ -36,6 +36,9 @@ (defconstant +button-classname+ "button") (defconstant +static-classname+ "static") +(defconstant +ad-counterclockwise+ 1) +(defconstant +ad-clockwise+ 2) + (defconstant +bi-rgb+ 0) (defconstant +bi-rle8+ 1) (defconstant +bi-rle4+ 2) From junrue at common-lisp.net Mon Mar 27 06:21:14 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 27 Mar 2006 01:21:14 -0500 (EST) Subject: [graphic-forms-cvs] r75 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060327062114.C8F776F23C@common-lisp.net> Author: junrue Date: Mon Mar 27 01:21:13 2006 New Revision: 75 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: implemented ellipse drawing functions; refactored shape drawing code Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 01:21:13 2006 @@ -829,6 +829,12 @@ same, a complete ellipse is drawn. See also @ref{draw-arc}. @end deffn + at deffn GenericFunction draw-ellipse self rect +Draws the outline of an ellipse whose center is the center of + at code{rect}. The shape is drawn using the current pen style, pen +width, and foreground color. + at end deffn + @anchor{draw-filled-chord} @deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt Draws a closed shape comprised of: @@ -849,6 +855,13 @@ is drawn. @end deffn + at deffn GenericFunction draw-filled-ellipse self rect +Fills the interior of an ellipse whose center is the center of + at code{rect}. The shape is drawn using the current pen style, pen +width, and foreground color, and filled with the current background +color. + at end deffn + @deffn GenericFunction draw-filled-rectangle self rect Fills the interior of a rectangle in the current background color. The current foreground color, pen width, and pen style will be used to Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 27 01:21:13 2006 @@ -133,16 +133,16 @@ #:descent #:draw-arc #:draw-chord + #:draw-ellipse #:draw-filled-arc #:draw-filled-chord - #:draw-filled-oval + #:draw-filled-ellipse #:draw-filled-polygon #:draw-filled-rectangle #:draw-filled-rounded-rectangle #:draw-focus #:draw-image #:draw-line - #:draw-oval #:draw-point #:draw-polygon #:draw-polyline Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 01:21:13 2006 @@ -76,6 +76,54 @@ (unless (null func) (funcall func gc)))) +(defun draw-simple-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) + (let ((pnt (gfs:make-point :x 15 :y 15)) + (size (gfs:make-size :width 80 :height 65))) + + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) + (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:solid)) + (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 1) + (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + + (setf (gfs:point-x pnt) 15) + (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) + (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) + +(defun draw-ellipses (gc) + (draw-simple-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) + +(defun select-ellipses (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) + (gfw:redraw *drawing-win*)) + (defun draw-arcs (gc) (let ((rect-pnt (gfs:make-point :x 15 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) @@ -162,42 +210,7 @@ (gfw:redraw *drawing-win*)) (defun draw-rects (gc) - (let ((pnt (gfs:make-point :x 15 :y 15)) - (size (gfs:make-size :width 80 :height 65))) - - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 1) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - - (setf (gfs:point-x pnt) 15) - (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10)) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) - (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:dot)) - (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size)))) + (draw-simple-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) (defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -212,6 +225,7 @@ (:item "&Tests" :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) + (:item "&Ellipses" :callback #'select-ellipses) (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 01:21:13 2006 @@ -96,6 +96,45 @@ (unless (gfs:null-handle-p old-hpen) (gfs::delete-object old-hpen))))))) +(defun call-rect-function (fn name hdc rect) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (if (zerop (funcall fn + hdc + (gfs:point-x pnt) + (gfs:point-y pnt) + (+ (gfs:point-x pnt) (gfs:size-width size)) + (+ (gfs:point-y pnt) (gfs:size-height size)))) + (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) + +(defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt) + (let ((rect-pnt (gfs:location rect)) + (rect-size (gfs:size rect))) + (if (zerop (funcall fn + hdc + (gfs:point-x rect-pnt) + (gfs:point-y rect-pnt) + (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) + (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) + (gfs:point-x start-pnt) + (gfs:point-y start-pnt) + (gfs:point-x end-pnt) + (gfs:point-y end-pnt))) + (error 'gfs:win32-error :detail (format nil "~a failed" name))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-null-brush ((gc) &body body) + (let ((hdc (gensym)) + (tmp-hbr (gensym)) + (orig-hbr (gensym))) + `(let* ((,hdc (gfs:handle ,gc)) + (,tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) + (,orig-hbr (gfs::select-object ,hdc ,tmp-hbr))) + (unwind-protect + (progn + , at body) + (gfs::select-object ,hdc ,orig-hbr)))))) + ;;; ;;; methods ;;; @@ -128,66 +167,40 @@ (defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((rect-pnt (gfs:location rect)) - (rect-size (gfs:size rect))) - (if (zerop (gfs::arc (gfs:handle self) - (gfs:point-x rect-pnt) - (gfs:point-y rect-pnt) - (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) - (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) - (gfs:point-x start-pnt) - (gfs:point-y start-pnt) - (gfs:point-x end-pnt) - (gfs:point-y end-pnt))) - (error 'gfs:win32-error :detail "arc failed")))) + (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt)) (defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let* ((hdc (gfs:handle self)) - (tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) - (orig-hbr (gfs::select-object hdc tmp-hbr))) - (unwind-protect - (draw-filled-chord self rect start-pnt end-pnt) - (gfs::select-object hdc orig-hbr)))) + (with-null-brush (self) + (draw-filled-chord self rect start-pnt end-pnt))) + +(defmethod draw-ellipse ((self graphics-context) rect) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (draw-filled-ellipse self rect))) (defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((rect-pnt (gfs:location rect)) - (rect-size (gfs:size rect))) - (if (zerop (gfs::chord (gfs:handle self) - (gfs:point-x rect-pnt) - (gfs:point-y rect-pnt) - (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size)) - (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size)) - (gfs:point-x start-pnt) - (gfs:point-y start-pnt) - (gfs:point-x end-pnt) - (gfs:point-y end-pnt))) - (error 'gfs:win32-error :detail "arc failed")))) + (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt)) + +(defmethod draw-filled-ellipse ((self graphics-context) rect) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)) (defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle self)) - (pnt (gfs:location rect)) - (size (gfs:size rect))) - (gfs::rectangle hdc - (gfs:point-x pnt) - (gfs:point-y pnt) - (+ (gfs:point-x pnt) (gfs:size-width size)) - (+ (gfs:point-y pnt) (gfs:size-height size))))) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) (defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let* ((hdc (gfs:handle self)) - (tmp-hbr (gfs::get-stock-object gfs::+null-brush+)) - (orig-hbr (gfs::select-object hdc tmp-hbr))) - (unwind-protect - (draw-filled-rectangle self rect) - (gfs::select-object hdc orig-hbr)))) + (with-null-brush (self) + (draw-filled-rectangle self rect))) ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Mar 27 01:21:13 2006 @@ -66,11 +66,14 @@ (defgeneric draw-chord (self rect start-pnt end-pnt) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) +(defgeneric draw-ellipse (self rect) + (:documentation "Draws an ellipse defined by a rectangle.")) + (defgeneric draw-filled-chord (self rect start-pnt end-pnt) (:documentation "Fills a region bounded by the intersection of an ellipse and a line segment.")) -(defgeneric draw-filled-oval (self rect) - (:documentation "Fills the interior of the oval defined by a rectangle in the current background color.")) +(defgeneric draw-filled-ellipse (self rect) + (:documentation "Fills the interior of the ellipse defined by a rectangle.")) (defgeneric draw-filled-polygon (self points) (:documentation "Fills the interior of the closed polygon defined by points in the current background color.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 01:21:13 2006 @@ -152,6 +152,15 @@ (params LPTR)) (defcfun + ("Ellipse" ellipse) + BOOL + (hdc HANDLE) + (leftrect INT) + (toprect INT) + (rightrect INT) + (bottomrect INT)) + +(defcfun ("ExtCreatePen" ext-create-pen) HANDLE (style DWORD) From junrue at common-lisp.net Mon Mar 27 23:29:40 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 27 Mar 2006 18:29:40 -0500 (EST) Subject: [graphic-forms-cvs] r76 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060327232940.B8286200A@common-lisp.net> Author: junrue Date: Mon Mar 27 18:29:40 2006 New Revision: 76 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: implement line, polyline, and polygon drawing functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 18:29:40 2006 @@ -862,14 +862,45 @@ color. @end deffn + at deffn GenericFunction draw-filled-polygon self points +Fills the interior of a closed shape comprised by the line segments +defined by @code{points} in the current background color. The current +foreground color, pen width, and pen style will be used to draw the +line segments. If @code{points} contains less than three points, then +this function does nothing. + at end deffn + @deffn GenericFunction draw-filled-rectangle self rect Fills the interior of a rectangle in the current background color. The current foreground color, pen width, and pen style will be used to draw an outline for the rectangle. @end deffn - at deffn GenericFunction draw-image self im pnt -Draws the given image in the receiver at the specified coordinates. + at deffn GenericFunction draw-image self image point +Draws @code{image} in the receiver at the specified @ref{point}. + at end deffn + + at deffn GenericFunction draw-line self start-point end-point +Draws a line from @code{start-point} to @code{end-point} using the +current pen style, pen width, and foreground color. + at end deffn + + at anchor{draw-polygon} + at deffn GenericFunction draw-polygon self points +Draws a series of connected line segments determined by the list of + at code{points} using the current pen style, pen width, and foreground +color. The last point in the list is connected with the first. If + at code{points} contains less than three points, then this function does +nothing. See also @ref{draw-polyline}. + at end deffn + + at anchor{draw-polyline} + at deffn GenericFunction draw-polyline self points +Draws a series of connected line segments determined by the list of + at code{points} using the current pen style, pen width, and foreground +color. The last point in the list is not connected with the first. If + at code{points} contains less than two points, then this function does +nothing. See also @ref{draw-polygon}. @end deffn @deffn GenericFunction draw-rectangle self rect Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 18:29:40 2006 @@ -76,7 +76,53 @@ (unless (null func) (funcall func gc)))) -(defun draw-simple-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) +(defun draw-line-test (gc start-pnt end-pnt pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (gfg:draw-line gc start-pnt end-pnt) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) + :y (gfs:point-y end-pnt))) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) + :y (gfs:point-y end-pnt))) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) + :y (gfs:point-y end-pnt)))) + +(defun draw-lines-test (gc draw-fn points pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (funcall draw-fn gc points) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 90) + :y (gfs:point-y pnt))) + points)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 180) + :y (gfs:point-y pnt))) + points)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 270) + :y (gfs:point-y pnt))) + points))) + +(defun draw-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) (let ((pnt (gfs:make-point :x 15 :y 15)) (size (gfs:make-size :width 80 :height 65))) @@ -107,7 +153,6 @@ (setf (gfg:pen-style gc) '(:dot)) (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 1) (setf (gfg:pen-style gc) '(:solid)) (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) @@ -116,7 +161,7 @@ (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) (defun draw-ellipses (gc) - (draw-simple-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) + (draw-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) (defun select-ellipses (disp item time rect) (declare (ignore disp time rect)) @@ -209,8 +254,38 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) +(defun draw-lines (gc) + (let ((orig-points (list (gfs:make-point :x 15 :y 60) + (gfs:make-point :x 75 :y 30) + (gfs:make-point :x 40 :y 10)))) + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (draw-lines-test gc #'gfg:draw-filled-polygon orig-points '((:dashdotdot :bevel-join) (:solid) (:solid))) + (draw-lines-test gc + #'gfg:draw-polygon + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 60))) + orig-points) + '((:dot :round-join :flat-endcap) (:dot) (:solid))) + (draw-lines-test gc + #'gfg:draw-polyline + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 120))) + orig-points) + '((:dot :round-join :flat-endcap) (:dot) (:solid))) + (let ((tmp (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 180))) + orig-points))) + (draw-line-test gc (first tmp) (second tmp) '((:dot :round-join :flat-endcap) (:dot) (:solid)))))) + +(defun select-lines (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) + (gfw:redraw *drawing-win*)) + (defun draw-rects (gc) - (draw-simple-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) + (draw-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) (defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -226,6 +301,7 @@ :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) (:item "&Ellipses" :callback #'select-ellipses) + (:item "&Lines and Polylines" :callback #'select-lines) (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 18:29:40 2006 @@ -55,11 +55,11 @@ (return-from compute-pen-style (logior gfs::+ps-cosmetic+ gfs::+ps-null+))) (setf tmp (intersection style (mapcar #'first main-styles))) (if (/= (length tmp) 1) - (error 'gfs:toolkit-error :detail "one main pen style keyword is required")) + (error 'gfs:toolkit-error :detail "main pen style keyword [:alternate | :dash | :dashdotdot | :dot | :solid] is required")) (setf native-style (logior native-style (cdr (assoc (car tmp) main-styles)))) (setf tmp (intersection style (mapcar #'first endcap-styles))) (if (> (length tmp) 1) - (error 'gfs:toolkit-error :detail "only one end cap pen style keyword is allowed")) + (error 'gfs:toolkit-error :detail "only one end cap pen style keyword [:flat-endcap | :round-endcap | :square-endcap] is allowed")) (setf native-style (logior native-style (if tmp (cdr (assoc (car tmp) endcap-styles)) 0))) (unless (null tmp) @@ -67,7 +67,7 @@ gfs::+ps-geometric+))) (setf tmp (intersection style (mapcar #'first join-styles))) (if (> (length tmp) 1) - (error 'gfs:toolkit-error :detail "only one join pen style keyword is allowed")) + (error 'gfs:toolkit-error :detail "only one join pen style keyword [:bevel-join | :miter-join | :round-join] is allowed")) (setf native-style (logior native-style (if tmp (cdr (assoc (car tmp) join-styles)) 0))) (unless (null tmp) @@ -122,6 +122,23 @@ (gfs:point-y end-pnt))) (error 'gfs:win32-error :detail (format nil "~a failed" name))))) +(defun call-points-function (fn name hdc points) + (let* ((count (length points)) + (array (cffi:foreign-alloc 'gfs::point :count count))) + (unwind-protect + (progn + (loop for pnt in points + with i = 0 + do (progn + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:mem-aref array 'gfs::point i) gfs::point) + (setf gfs::x (gfs:point-x pnt)) + (setf gfs::y (gfs:point-y pnt))) + (incf i))) + (if (zerop (funcall fn hdc array count)) + (error 'gfs:win32-error :detail (format nil "~a failed" name)))) + (cffi:foreign-free array)))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-null-brush ((gc) &body body) (let ((hdc (gensym)) @@ -173,13 +190,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-chord self rect start-pnt end-pnt))) + (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt))) (defmethod draw-ellipse ((self graphics-context) rect) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-ellipse self rect))) + (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect))) (defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) @@ -191,16 +208,40 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)) +(defmethod draw-filled-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points))) + (defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) +(defmethod draw-line ((self graphics-context) start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) + +(defmethod draw-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (with-null-brush (self) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) + +(defmethod draw-polyline ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 2) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) + (defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-rectangle self rect))) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Mar 27 18:29:40 2006 @@ -76,43 +76,37 @@ (:documentation "Fills the interior of the ellipse defined by a rectangle.")) (defgeneric draw-filled-polygon (self points) - (:documentation "Fills the interior of the closed polygon defined by points in the current background color.")) + (:documentation "Fills the interior of the closed polygon defined by points.")) (defgeneric draw-filled-rectangle (self rect) (:documentation "Fills the interior of a rectangle in the current background color.")) (defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) - (:documentation "Fills the interior of the rectangle with rounded corners in the current background color.")) + (:documentation "Fills the interior of the rectangle with rounded corners.")) (defgeneric draw-filled-wedge (self rect start-pnt end-pnt) - (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) - -(defgeneric draw-focus (self rect) - (:documentation "Draws a rectangle having the appearance of a focus rectangle.")) + (:documentation "Fills the interior of an elliptical arc within the rectangle.")) (defgeneric draw-image (self im pnt) (:documentation "Draws the given image in the receiver at the specified coordinates.")) -(defgeneric draw-line (self pnt-1 pnt-2) - (:documentation "Draws a line using the foreground color between (x1, y1) and (x2, y2).")) - -(defgeneric draw-oval (self rect) - (:documentation "Draws the outline of an oval in the foreground color with the specified rectangular area.")) +(defgeneric draw-line (self start-pnt end-pnt) + (:documentation "Draws a line using the foreground color between start-pnt and end-pnt.")) (defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) (defgeneric draw-polygon (self points) - (:documentation "Draws the closed polygon defined by the list of points in the current foreground color.")) + (:documentation "Draws the closed polygon defined by the list of points.")) (defgeneric draw-polyline (self points) - (:documentation "Draws the polyline defined by the list of points in the current foreground color.")) + (:documentation "Draws the polyline defined by the list of points.")) (defgeneric draw-rectangle (self rect) (:documentation "Draws the outline of a rectangle in the current foreground color.")) (defgeneric draw-rounded-rectangle (self rect arc-width arc-height) - (:documentation "Draws the outline of the rectangle with rounded corners in the current foreground color.")) + (:documentation "Draws the outline of the rectangle with rounded corners.")) (defgeneric draw-text (self text pnt) (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 18:29:40 2006 @@ -254,6 +254,20 @@ (rop DWORD)) (defcfun + ("Polygon" polygon) + BOOL + (hdc HANDLE) + (points LPTR) + (count INT)) + +(defcfun + ("Polyline" polyline) + BOOL + (hdc HANDLE) + (points LPTR) + (count INT)) + +(defcfun ("Rectangle" rectangle) BOOL (hdc HANDLE) From junrue at common-lisp.net Tue Mar 28 01:34:52 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 27 Mar 2006 20:34:52 -0500 (EST) Subject: [graphic-forms-cvs] r77 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060328013452.67D8D200A@common-lisp.net> Author: junrue Date: Mon Mar 27 20:34:51 2006 New Revision: 77 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: implement bezier curve drawing functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 20:34:51 2006 @@ -810,6 +810,13 @@ @ref{draw-chord}. @end deffn + at deffn GenericFunction draw-bezier self start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 +Draws a B@'ezier curve between @code{start-pnt} and @code{end-pnt} +using @code{ctrl-pnt-1} and @code{ctrl-pnt-2} as the control +points. The curve is drawn using the current pen style, pen widget, +and foreground color. + at end deffn + @anchor{draw-chord} @deffn GenericFunction draw-chord self rect start-pnt end-pnt Draws a closed shape comprised of: @@ -885,6 +892,21 @@ current pen style, pen width, and foreground color. @end deffn + at deffn GenericFunction draw-poly-bezier self start-pnt points +Draws a sequence of connected B@'ezier curves starting with @code{start-pnt}. + at code{points} is a list of lists, each sublist containing three points, +where: + at itemize @bullet + at item + at code{(first points)} is the current segment's end point + at item + at code{(second points)} and @code{(third points)} are the segment's +control points. + at end itemize +The aggregate curve is drawn using the current pen style, pen widget, +and foreground color. + at end deffn + @anchor{draw-polygon} @deffn GenericFunction draw-polygon self points Draws a series of connected line segments determined by the list of Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Mar 27 20:34:51 2006 @@ -132,6 +132,7 @@ #:depth #:descent #:draw-arc + #:draw-bezier #:draw-chord #:draw-ellipse #:draw-filled-arc @@ -144,6 +145,7 @@ #:draw-image #:draw-line #:draw-point + #:draw-poly-bezier #:draw-polygon #:draw-polyline #:draw-rectangle Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 20:34:51 2006 @@ -76,6 +76,44 @@ (unless (null func) (funcall func gc)))) +(defun draw-bezier-test (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (gfg:draw-bezier gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (gfg:draw-bezier gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) + :y (gfs:point-y end-pnt)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 90) + :y (gfs:point-y ctrl-pnt-1)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 90) + :y (gfs:point-y ctrl-pnt-2))) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (gfg:draw-bezier gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) + :y (gfs:point-y end-pnt)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 180) + :y (gfs:point-y ctrl-pnt-1)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 180) + :y (gfs:point-y ctrl-pnt-2))) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-bezier gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) + :y (gfs:point-y end-pnt)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 270) + :y (gfs:point-y ctrl-pnt-1)) + (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 270) + :y (gfs:point-y ctrl-pnt-2)))) + (defun draw-line-test (gc start-pnt end-pnt pen-styles) (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:pen-width gc) 5) @@ -254,6 +292,31 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*)) +(defun draw-beziers (gc) + (let ((start-pnt (gfs:make-point :x 10 :y 32)) + (end-pnt (gfs:make-point :x 70 :y 32)) + (ctrl-pnt-1 (gfs:make-point :x 40 :y 0)) + (ctrl-pnt-2 (gfs:make-point :x 40 :y 65))) + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (draw-bezier-test gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 '((:dashdotdot :bevel-join) (:solid) (:solid))) + (let ((poly-pnts (list (list (gfs:make-point :x 40 :y 100) + (gfs:make-point :x 35 :y 200) + (gfs:make-point :x 300 :y 180)) + (list (gfs:make-point :x 260 :y 190) + (gfs:make-point :x 140 :y 150) + (gfs:make-point :x 80 :y 200))))) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot :square-endcap)) + (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 100) poly-pnts)))) + +(defun select-beziers (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) + (gfw:redraw *drawing-win*)) + (defun draw-lines (gc) (let ((orig-points (list (gfs:make-point :x 15 :y 60) (gfs:make-point :x 75 :y 30) @@ -300,6 +363,7 @@ (:item "&Tests" :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) + (:item "&B?zier Curves" :callback #'select-beziers) (:item "&Ellipses" :callback #'select-ellipses) (:item "&Lines and Polylines" :callback #'select-lines) (:item "&Rectangles" :callback #'select-rects))))))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 20:34:51 2006 @@ -186,6 +186,14 @@ (error 'gfs:disposed-error)) (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt)) +(defmethod draw-bezier ((self graphics-context) start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::poly-bezier + "poly-bezier" + (gfs:handle self) + (list start-pnt ctrl-pnt-1 ctrl-pnt-2 end-pnt))) + (defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) @@ -224,6 +232,15 @@ (error 'gfs:disposed-error)) (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) +(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (null points) + (let ((tmp (loop for triplet in points + append (list (second triplet) (third triplet) (first triplet))))) + (push start-pnt tmp) + (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) + (defmethod draw-polygon ((self graphics-context) points) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Mar 27 20:34:51 2006 @@ -63,6 +63,9 @@ (defgeneric draw-arc (self rect start-pnt end-pnt) (:documentation "Draws the outline of an elliptical arc within the specified rectangular area.")) +(defgeneric draw-bezier (self start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (:documentation "Draws a Bezier curve between start-pnt and end-pnt.")) + (defgeneric draw-chord (self rect start-pnt end-pnt) (:documentation "Draws a region bounded by the intersection of an ellipse and a line segment.")) @@ -96,6 +99,9 @@ (defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) +(defgeneric draw-poly-bezier (self start-pnt points) + (:documentation "Draws a series of connected Bezier curves.")) + (defgeneric draw-polygon (self points) (:documentation "Draws the closed polygon defined by the list of points.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 20:34:51 2006 @@ -254,6 +254,13 @@ (rop DWORD)) (defcfun + ("PolyBezier" poly-bezier) + BOOL + (hdc HANDLE) + (points LPTR) + (count DWORD)) + +(defcfun ("Polygon" polygon) BOOL (hdc HANDLE) From junrue at common-lisp.net Tue Mar 28 05:30:06 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 28 Mar 2006 00:30:06 -0500 (EST) Subject: [graphic-forms-cvs] r78 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060328053006.1186E6F23C@common-lisp.net> Author: junrue Date: Tue Mar 28 00:30:06 2006 New Revision: 78 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: implemented pie wedge drawing functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 00:30:06 2006 @@ -798,41 +798,41 @@ @end deffn @anchor{draw-arc} - at deffn GenericFunction draw-arc self rect start-pnt end-pnt + at deffn GenericFunction draw-arc self rect start-point end-point Draws an arc whose curve is formed by the ellipse bound by @code{rect}, in a counter-clockwise direction from the point @code{start-point} where it intersects a radial originating at the center of the bounding rectangle. The arc ends at the point - at code{end-pnt} where it intersects another radial also originating at + at code{end-point} where it intersects another radial also originating at the center of the rectangle. The shape is drawn using the current pen -style, pen width, and foreground color. If @code{start-pnt} and - at code{end-pnt} are the same, a complete ellipse is drawn. See also +style, pen width, and foreground color. If @code{start-point} and + at code{end-point} are the same, a complete ellipse is drawn. See also @ref{draw-chord}. @end deffn - at deffn GenericFunction draw-bezier self start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 -Draws a B@'ezier curve between @code{start-pnt} and @code{end-pnt} -using @code{ctrl-pnt-1} and @code{ctrl-pnt-2} as the control -points. The curve is drawn using the current pen style, pen widget, + at deffn GenericFunction draw-bezier self start-point end-point ctrl-point-1 ctrl-point-2 +Draws a B@'ezier curve between @code{start-point} and @code{end-point} +using @code{ctrl-point-1} and @code{ctrl-point-2} as the control +points. The curve is drawn using the current pen style, pen width, and foreground color. @end deffn @anchor{draw-chord} - at deffn GenericFunction draw-chord self rect start-pnt end-pnt + at deffn GenericFunction draw-chord self rect start-point end-point Draws a closed shape comprised of: @itemize @bullet @item an arc whose curve is formed by the ellipse bound by @code{rect}, in a counter-clockwise direction from the point @code{start-point} where it intersects a radial originating at the center of the bounding -rectangle. The arc ends at the point @code{end-pnt} where it +rectangle. The arc ends at the point @code{end-point} where it intersects another radial also originating at the center of the rectangle. @item -a line drawn between start-pnt and end-pnt +a line drawn between start-point and end-point @end itemize The shape is drawn using the current pen style, pen width and -foreground color. If @code{start-pnt} and @code{end-pnt} are the +foreground color. If @code{start-point} and @code{end-point} are the same, a complete ellipse is drawn. See also @ref{draw-arc}. @end deffn @@ -843,22 +843,22 @@ @end deffn @anchor{draw-filled-chord} - at deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt + at deffn GenericFunction draw-filled-chord self rect start-point end-point Draws a closed shape comprised of: @itemize @bullet @item an arc whose curve is formed by the ellipse bound by @code{rect}, in a counter-clockwise direction from the point @code{start-point} where it intersects a radial originating at the center of the bounding -rectangle. The arc ends at the point @code{end-pnt} where it +rectangle. The arc ends at the point @code{end-point} where it intersects another radial also originating at the center of the rectangle. @item -a line drawn between start-pnt and end-pnt +a line drawn between start-point and end-point @end itemize The shape is drawn using the current pen style, pen width and foreground color and filled with the current background color. If - at code{start-pnt} and @code{end-pnt} are the same, a complete ellipse + at code{start-point} and @code{end-point} are the same, a complete ellipse is drawn. @end deffn @@ -869,6 +869,14 @@ color. @end deffn + at deffn GenericFunction draw-filled-pie-wedge self rect start-point end-point +Fills a pie-shaped wedge whose arc is defined by the ellipse bound by + at code{rect} and its intersection with the radials defined by + at code{start-point} and @code{end-point}. The shape is drawn using the +current pen style, pen width, and foreground color, and filled with +the current background color. + at end deffn + @deffn GenericFunction draw-filled-polygon self points Fills the interior of a closed shape comprised by the line segments defined by @code{points} in the current background color. The current @@ -892,8 +900,15 @@ current pen style, pen width, and foreground color. @end deffn - at deffn GenericFunction draw-poly-bezier self start-pnt points -Draws a sequence of connected B@'ezier curves starting with @code{start-pnt}. + at deffn GenericFunction draw-pie-wedge self rect start-point end-point +Draws a pie-shaped wedge whose arc is defined by the ellipse bound +by @code{rect} and its intersection with the radials defined by + at code{start-point} and @code{end-point}. The shape is drawn using the +current pen style, pen width, and foreground color. + at end deffn + + at deffn GenericFunction draw-poly-bezier self start-point points +Draws a sequence of connected B@'ezier curves starting with @code{start-point}. @code{points} is a list of lists, each sublist containing three points, where: @itemize @bullet @@ -903,7 +918,7 @@ @code{(second points)} and @code{(third points)} are the segment's control points. @end itemize -The aggregate curve is drawn using the current pen style, pen widget, +The combined curve is drawn using the current pen style, pen width, and foreground color. @end deffn Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 28 00:30:06 2006 @@ -138,12 +138,14 @@ #:draw-filled-arc #:draw-filled-chord #:draw-filled-ellipse + #:draw-filled-pie-wedge #:draw-filled-polygon #:draw-filled-rectangle #:draw-filled-rounded-rectangle #:draw-focus #:draw-image #:draw-line + #:draw-pie-wedge #:draw-point #:draw-poly-bezier #:draw-polygon Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 00:30:06 2006 @@ -356,6 +356,66 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) +(defun draw-wedges (gc) + (let ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (start-pnt (gfs:make-point :x 35 :y 75)) + (end-pnt (gfs:make-point :x 85 :y 35)) + (delta-x 0) + (delta-y 0)) + + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) + (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (setf delta-x (+ (gfs:size-width rect-size) 10)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + + (setf (gfs:point-x rect-pnt) 15) + (setf (gfs:point-x start-pnt) 35) + (setf (gfs:point-x end-pnt) 85) + (setf delta-y (gfs:size-height rect-size)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-y pnt) delta-y)) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) + (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (setf delta-x (+ (gfs:size-width rect-size) 10)) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) '(:dot)) + (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid)) + (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) + (loop for pnt in (list rect-pnt start-pnt end-pnt) + do (incf (gfs:point-x pnt) delta-x)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + +(defun select-wedges (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges) + (gfw:redraw *drawing-win*)) + (defun run-drawing-tester-internal () (setf *last-checked-drawing-item* nil) (let ((menubar (gfw:defmenu ((:item "&File" @@ -366,6 +426,7 @@ (:item "&B?zier Curves" :callback #'select-beziers) (:item "&Ellipses" :callback #'select-ellipses) (:item "&Lines and Polylines" :callback #'select-lines) + (:item "&Pie Wedges" :callback #'select-wedges) (:item "&Rectangles" :callback #'select-rects))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 00:30:06 2006 @@ -216,6 +216,11 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)) +(defmethod draw-filled-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt)) + (defmethod draw-filled-polygon ((self graphics-context) points) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) @@ -232,6 +237,12 @@ (error 'gfs:disposed-error)) (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) +(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) + (defmethod draw-poly-bezier ((self graphics-context) start-pnt points) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Tue Mar 28 00:30:06 2006 @@ -78,6 +78,9 @@ (defgeneric draw-filled-ellipse (self rect) (:documentation "Fills the interior of the ellipse defined by a rectangle.")) +(defgeneric draw-filled-pie-wedge (self rect start-pnt end-pnt) + (:documentation "Filles the interior of a pie-shaped wedge.")) + (defgeneric draw-filled-polygon (self points) (:documentation "Fills the interior of the closed polygon defined by points.")) @@ -90,12 +93,15 @@ (defgeneric draw-filled-wedge (self rect start-pnt end-pnt) (:documentation "Fills the interior of an elliptical arc within the rectangle.")) -(defgeneric draw-image (self im pnt) - (:documentation "Draws the given image in the receiver at the specified coordinates.")) +(defgeneric draw-image (self image pnt) + (:documentation "Draws an image at the specified coordinates.")) (defgeneric draw-line (self start-pnt end-pnt) (:documentation "Draws a line using the foreground color between start-pnt and end-pnt.")) +(defgeneric draw-pie-wedge (self rect start-pnt end-pnt) + (:documentation "Draws a pie-shaped wedge defined by the intersection of an ellipse and two radials.")) + (defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 00:30:06 2006 @@ -43,10 +43,10 @@ ("Arc" arc) BOOL (hdc HANDLE) - (leftrect INT) - (toprect INT) - (rightrect INT) - (bottomrect INT) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) (startx INT) (starty INT) (endx INT) @@ -155,10 +155,10 @@ ("Ellipse" ellipse) BOOL (hdc HANDLE) - (leftrect INT) - (toprect INT) - (rightrect INT) - (bottomrect INT)) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT)) (defcfun ("ExtCreatePen" ext-create-pen) @@ -254,6 +254,19 @@ (rop DWORD)) (defcfun + ("Pie" pie) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rightrect INT) + (bottomrect INT) + (radial1x INT) + (radial1y INT) + (radial2x INT) + (radial2y INT)) + +(defcfun ("PolyBezier" poly-bezier) BOOL (hdc HANDLE) From junrue at common-lisp.net Tue Mar 28 18:16:15 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 28 Mar 2006 13:16:15 -0500 (EST) Subject: [graphic-forms-cvs] r79 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060328181615.9212E79000@common-lisp.net> Author: junrue Date: Tue Mar 28 13:16:14 2006 New Revision: 79 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp Log: implemented rounded rectangle drawing functions; refactored drawing-tester program Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 13:16:14 2006 @@ -891,6 +891,14 @@ draw an outline for the rectangle. @end deffn + at deffn GenericFunction draw-filled-rounded-rectangle self rect arc-size +Fills the interior of a rectangle with rounded corners in the current +background color. The current foreground color, pen width, and pen +style will be used to draw an outline for the rectangle. The rounding +of the corners is determined by an ellipse whose height and width are +determined by @code{arc-size}. + at end deffn + @deffn GenericFunction draw-image self image point Draws @code{image} in the receiver at the specified @ref{point}. @end deffn @@ -940,6 +948,13 @@ nothing. See also @ref{draw-polygon}. @end deffn + at deffn GenericFunction draw-rounded-rectangle self rect arc-size +Draws the outline of a rectangle with rounded corners using the +current foreground color, pen width, and pen style. The rounding of +the corners is determined by an ellipse whose height and width are +determined by @code{arc-size}. + at end deffn + @deffn GenericFunction draw-rectangle self rect Draws the outline of a rectangle in the current foreground color, using the current pen width and style. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 13:16:14 2006 @@ -76,215 +76,93 @@ (unless (null func) (funcall func gc)))) -(defun draw-bezier-test (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 pen-styles) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) (first pen-styles)) - (gfg:draw-bezier gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (gfg:draw-bezier gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) - :y (gfs:point-y end-pnt)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 90) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 90) - :y (gfs:point-y ctrl-pnt-2))) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (gfg:draw-bezier gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) - :y (gfs:point-y end-pnt)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 180) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 180) - :y (gfs:point-y ctrl-pnt-2))) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-bezier gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) - :y (gfs:point-y end-pnt)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 270) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 270) - :y (gfs:point-y ctrl-pnt-2)))) - -(defun draw-line-test (gc start-pnt end-pnt pen-styles) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) (first pen-styles)) - (gfg:draw-line gc start-pnt end-pnt) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (gfg:draw-line gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) - :y (gfs:point-y end-pnt))) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (gfg:draw-line gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) - :y (gfs:point-y end-pnt))) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-line gc - (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) - :y (gfs:point-y start-pnt)) - (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) - :y (gfs:point-y end-pnt)))) - -(defun draw-lines-test (gc draw-fn points pen-styles) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) (first pen-styles)) - (funcall draw-fn gc points) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 90) - :y (gfs:point-y pnt))) - points)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 180) - :y (gfs:point-y pnt))) - points)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 270) - :y (gfs:point-y pnt))) - points))) - -(defun draw-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) - (let ((pnt (gfs:make-point :x 15 :y 15)) - (size (gfs:make-size :width 80 :height 65))) - - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) - (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:solid)) - (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 1) - (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - - (setf (gfs:point-x pnt) 15) - (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10)) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) - (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:dot)) - (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) '(:solid)) - (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) +(defun clone-point (orig) + (gfs:make-point :x (gfs:point-x orig) :y (gfs:point-y orig))) -(defun draw-ellipses (gc) - (draw-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) +(defun clone-size (orig) + (gfs:make-size :width (gfs:size-width orig) :height (gfs:size-height orig))) -(defun select-ellipses (disp item time rect) - (declare (ignore disp time rect)) - (update-drawing-item-check item) - (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) - (gfw:redraw *drawing-win*)) +(defun set-gc-params (gc column filled) + (ecase column + (0 + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:background-color gc) gfg:*color-green*) + (if filled + (progn + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join))) + (progn + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap))))) + (1 + (setf (gfg:pen-width gc) 3) + (if filled + (setf (gfg:pen-style gc) '(:solid)) + (setf (gfg:pen-style gc) '(:dot)))) + (2 + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid))) + (3 + (setf (gfg:foreground-color gc) (gfg:background-color gc))))) + +(defun draw-rectangular (gc rect arc-size delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (if arc-size + (funcall draw-fn gc rect arc-size) + (funcall draw-fn gc rect)) + (incf (gfs:point-x (gfs:location rect)) delta-x))) + +(defun draw-start-end (gc start-pnt end-pnt delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc start-pnt end-pnt) + (loop for pnt in (list start-pnt end-pnt) do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-rect-start-end (gc rect start-pnt end-pnt delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc rect start-pnt end-pnt) + (loop for pnt in (list start-pnt end-pnt) do (incf (gfs:point-x pnt) delta-x)) + (incf (gfs:point-x (gfs:location rect)) delta-x))) + +(defun draw-points (gc points delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc points) + (loop for pnt in points do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-start-points (gc start-pnt points delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc start-pnt points) + (loop for pnt in (append (list start-pnt) points) do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-start-end-controls (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 delta-x draw-fn) + (dotimes (i 4) + (set-gc-params gc i nil) + (funcall draw-fn gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (loop for pnt in (list start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) do (incf (gfs:point-x pnt) delta-x)))) (defun draw-arcs (gc) - (let ((rect-pnt (gfs:make-point :x 15 :y 10)) - (rect-size (gfs:make-size :width 80 :height 65)) - (start-pnt (gfs:make-point :x 15 :y 60)) - (end-pnt (gfs:make-point :x 75 :y 25)) - (delta-x 0) - (delta-y 0)) - - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) - (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (setf delta-x (+ (gfs:size-width rect-size) 10)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 1) - (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - - (setf (gfs:point-x rect-pnt) 15) - (setf (gfs:point-x start-pnt) 15) - (setf (gfs:point-x end-pnt) 75) - (setf delta-y (gfs:size-height rect-size)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-y pnt) delta-y)) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) - (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (setf delta-x (+ (gfs:size-width rect-size) 10)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:dot)) - (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - - (setf (gfs:point-x rect-pnt) 15) - (setf (gfs:point-x start-pnt) 15) - (setf (gfs:point-x end-pnt) 75) - (setf delta-y (gfs:size-height rect-size)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-y pnt) delta-y)) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) - (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:dot)) - (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + (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)) + (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)) + (delta-y (+ (gfs:size-height rect-size) 10))) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-filled-chord t) + (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)) + (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)) + (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) (declare (ignore disp time rect)) @@ -297,9 +175,7 @@ (end-pnt (gfs:make-point :x 70 :y 32)) (ctrl-pnt-1 (gfs:make-point :x 40 :y 0)) (ctrl-pnt-2 (gfs:make-point :x 40 :y 65))) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (draw-bezier-test gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 '((:dashdotdot :bevel-join) (:solid) (:solid))) + (draw-start-end-controls gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 85 #'gfg:draw-bezier) (let ((poly-pnts (list (list (gfs:make-point :x 40 :y 100) (gfs:make-point :x 35 :y 200) (gfs:make-point :x 300 :y 180)) @@ -309,7 +185,7 @@ (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:pen-width gc) 3) (setf (gfg:pen-style gc) '(:dot :square-endcap)) - (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 100) poly-pnts)))) + (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts)))) (defun select-beziers (disp item time rect) (declare (ignore disp time rect)) @@ -317,29 +193,54 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*)) +(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)) + (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)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) + +(defun select-ellipses (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) + (gfw:redraw *drawing-win*)) + (defun draw-lines (gc) - (let ((orig-points (list (gfs:make-point :x 15 :y 60) - (gfs:make-point :x 75 :y 30) - (gfs:make-point :x 40 :y 10)))) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (draw-lines-test gc #'gfg:draw-filled-polygon orig-points '((:dashdotdot :bevel-join) (:solid) (:solid))) - (draw-lines-test gc - #'gfg:draw-polygon - (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) - :y (+ (gfs:point-y pnt) 60))) - orig-points) - '((:dot :round-join :flat-endcap) (:dot) (:solid))) - (draw-lines-test gc - #'gfg:draw-polyline - (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) - :y (+ (gfs:point-y pnt) 120))) - orig-points) - '((:dot :round-join :flat-endcap) (:dot) (:solid))) - (let ((tmp (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) - :y (+ (gfs:point-y pnt) 180))) - orig-points))) - (draw-line-test gc (first tmp) (second tmp) '((:dot :round-join :flat-endcap) (:dot) (:solid)))))) + (let ((pnt-1 (gfs:make-point :x 15 :y 60)) + (pnt-2 (gfs:make-point :x 75 :y 30)) + (pnt-3 (gfs:make-point :x 40 :y 10)) + (delta-x 75) + (delta-y 60)) + (draw-points gc + (list (clone-point pnt-1) (clone-point pnt-2) (clone-point pnt-3)) + delta-x + #'gfg:draw-filled-polygon + t) + (draw-points gc + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) delta-y))) + (list pnt-1 pnt-2 pnt-3)) + delta-x + #'gfg:draw-polygon + nil) + (draw-points gc + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) (* delta-y 2)))) + (list pnt-1 pnt-2 pnt-3)) + delta-x + #'gfg:draw-polyline + nil) + (draw-start-end gc + (gfs:make-point :x (gfs:point-x pnt-1) :y (+ (gfs:point-y pnt-1) (* delta-y 3))) + (gfs:make-point :x (gfs:point-x pnt-2) :y (+ (gfs:point-y pnt-2) (* delta-y 3))) + delta-x + #'gfg:draw-line + nil))) (defun select-lines (disp item time rect) (declare (ignore disp time rect)) @@ -348,7 +249,22 @@ (gfw:redraw *drawing-win*)) (defun draw-rects (gc) - (draw-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) + (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)) + (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)) + (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)) + (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)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil))) (defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -357,58 +273,20 @@ (gfw:redraw *drawing-win*)) (defun draw-wedges (gc) - (let ((rect-pnt (gfs:make-point :x 15 :y 10)) - (rect-size (gfs:make-size :width 80 :height 65)) - (start-pnt (gfs:make-point :x 35 :y 75)) - (end-pnt (gfs:make-point :x 85 :y 35)) - (delta-x 0) - (delta-y 0)) - - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) - (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (setf delta-x (+ (gfs:size-width rect-size) 10)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 1) - (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-filled-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - - (setf (gfs:point-x rect-pnt) 15) - (setf (gfs:point-x start-pnt) 35) - (setf (gfs:point-x end-pnt) 85) - (setf delta-y (gfs:size-height rect-size)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-y pnt) delta-y)) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) - (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (setf delta-x (+ (gfs:size-width rect-size) 10)) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) '(:dot)) - (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) '(:solid)) - (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt) - (loop for pnt in (list rect-pnt start-pnt end-pnt) - do (incf (gfs:point-x pnt) delta-x)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + (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)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (gfs:size-height rect-size)) + (start-pnt (gfs:make-point :x 35 :y 75)) + (end-pnt (gfs:make-point :x 85 :y 35))) + + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-filled-pie-wedge t) + (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)) + (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) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 13:16:14 2006 @@ -107,6 +107,19 @@ (+ (gfs:point-y pnt) (gfs:size-height size)))) (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) +(defun call-rounded-rect-function (fn name hdc rect arc-size) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (if (zerop (funcall fn + hdc + (gfs:point-x pnt) + (gfs:point-y pnt) + (+ (gfs:point-x pnt) (gfs:size-width size)) + (+ (gfs:point-y pnt) (gfs:size-height size)) + (gfs:size-width arc-size) + (gfs:size-height arc-size))) + (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) + (defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt) (let ((rect-pnt (gfs:location rect)) (rect-size (gfs:size rect))) @@ -232,45 +245,6 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) -(defmethod draw-line ((self graphics-context) start-pnt end-pnt) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) - -(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (with-null-brush (self) - (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) - -(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (null points) - (let ((tmp (loop for triplet in points - append (list (second triplet) (third triplet) (first triplet))))) - (push start-pnt tmp) - (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) - -(defmethod draw-polygon ((self graphics-context) points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (< (length points) 3) - (with-null-brush (self) - (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) - -(defmethod draw-polyline ((self graphics-context) points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (< (length points) 2) - (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) - -(defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (with-null-brush (self) - (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) - ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. ;;; @@ -298,6 +272,11 @@ (cffi:null-pointer)))))) |# +(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size)) + ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; @@ -353,6 +332,51 @@ 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc))) +(defmethod draw-line ((self graphics-context) start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) + +(defmethod draw-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) + +(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (null points) + (let ((tmp (loop for triplet in points + append (list (second triplet) (third triplet) (first triplet))))) + (push start-pnt tmp) + (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) + +(defmethod draw-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (with-null-brush (self) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) + +(defmethod draw-polyline ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 2) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) + +(defmethod draw-rectangle ((self graphics-context) rect) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) + +(defmethod draw-rounded-rectangle ((self graphics-context) rect size) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))) + (defmethod draw-text ((self graphics-context) text (pnt gfs:point)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Tue Mar 28 13:16:14 2006 @@ -87,7 +87,7 @@ (defgeneric draw-filled-rectangle (self rect) (:documentation "Fills the interior of a rectangle in the current background color.")) -(defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) +(defgeneric draw-filled-rounded-rectangle (self rect size) (:documentation "Fills the interior of the rectangle with rounded corners.")) (defgeneric draw-filled-wedge (self rect start-pnt end-pnt) @@ -117,7 +117,7 @@ (defgeneric draw-rectangle (self rect) (:documentation "Draws the outline of a rectangle in the current foreground color.")) -(defgeneric draw-rounded-rectangle (self rect arc-width arc-height) +(defgeneric draw-rounded-rectangle (self rect size) (:documentation "Draws the outline of the rectangle with rounded corners.")) (defgeneric draw-text (self text pnt) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 13:16:14 2006 @@ -297,6 +297,17 @@ (y2 INT)) (defcfun + ("RoundRect" round-rect) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) + (width INT) + (height INT)) + +(defcfun ("SelectObject" select-object) HANDLE (hdc HANDLE) From junrue at common-lisp.net Tue Mar 28 19:42:29 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 28 Mar 2006 14:42:29 -0500 (EST) Subject: [graphic-forms-cvs] r80 - in trunk: docs/manual src/uitoolkit/graphics Message-ID: <20060328194229.EE3BB5E003@common-lisp.net> Author: junrue Date: Tue Mar 28 14:42:29 2006 New Revision: 80 Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/graphics/graphics-context.lisp Log: implemented draw-point drawing function Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 14:42:29 2006 @@ -900,7 +900,8 @@ @end deffn @deffn GenericFunction draw-image self image point -Draws @code{image} in the receiver at the specified @ref{point}. +Draws @code{image} in the receiver where @code{point} identifies the +position of the upper-left corner of the image. @end deffn @deffn GenericFunction draw-line self start-point end-point @@ -915,6 +916,10 @@ current pen style, pen width, and foreground color. @end deffn + at deffn GenericFunction draw-point self point +Draws a pixel at @code{point} in the current foreground color. + at end deffn + @deffn GenericFunction draw-poly-bezier self start-point points Draws a sequence of connected B@'ezier curves starting with @code{start-point}. @code{points} is a list of lists, each sublist containing three points, Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 14:42:29 2006 @@ -343,6 +343,14 @@ (with-null-brush (self) (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) +(defmethod draw-point ((self graphics-context) pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::set-pixel (gfs:handle self) + (gfs:point-x pnt) + (gfs:point-y pnt) + (color->rgb (foreground-color self)))) + (defmethod draw-poly-bezier ((self graphics-context) start-pnt points) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) From junrue at common-lisp.net Tue Mar 28 19:44:59 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 28 Mar 2006 14:44:59 -0500 (EST) Subject: [graphic-forms-cvs] r81 - trunk/src/uitoolkit/system Message-ID: <20060328194459.ACC6C5E003@common-lisp.net> Author: junrue Date: Tue Mar 28 14:44:59 2006 New Revision: 81 Modified: trunk/src/uitoolkit/system/gdi32.lisp Log: added missing binding for SetPixel Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 14:44:59 2006 @@ -356,6 +356,14 @@ (oldlimit LPTR)) (defcfun + ("SetPixel" set-pixel) + COLORREF + (hdc HANDLE) + (x INT) + (y INT) + (color COLORREF)) + +(defcfun ("SetTextColor" set-text-color) COLORREF (hdc HANDLE) From junrue at common-lisp.net Wed Mar 29 04:30:02 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Tue, 28 Mar 2006 23:30:02 -0500 (EST) Subject: [graphic-forms-cvs] r82 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060329043002.3EFE95903A@common-lisp.net> Author: junrue Date: Tue Mar 28 23:30:00 2006 New Revision: 82 Added: trunk/src/uitoolkit/graphics/font-data.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented font-data structure and data->font converter function, as a precursor to allowing fonts to be selected in graphics contexts Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 23:30:00 2006 @@ -689,6 +689,68 @@ object. @xref{font-metrics}. @end deftp + at anchor{font-data} + at deftp Structure font-data char-set face-name point-size style +This structure describes basic attributes of a font that the system font mapper +can use to match a logical @ref{font}.@*@* +The @code{face-name} slot holds the text name of the requested font. +For example, @samp{Times New Roman}.@*@* +The @code{char-set} slot identifies the character set of the requested +font. It can be one of the following values: + at itemize @bullet + at item @code{+ansi-charset+} + at item @code{+arabic-charset+} + at item @code{+baltic-charset+} + at item @code{+chinesebig5-charset+} + at item @code{+default-charset+} + at item @code{+easteurope-charset+} + at item @code{+gb2312-charset+} + at item @code{+greek-charset+} + at item @code{+hangeul-charset+} + at item @code{+hangul-charset+} + at item @code{+hebrew-charset+} + at item @code{+johab-charset+} + at item @code{+mac-charset+} + at item @code{+oem-charset+} + at item @code{+russian-charset+} + at item @code{+shiftjis-charset+} + at item @code{+symbol-charset+} + at item @code{+thai-charset+} + at item @code{+turkish-charset+} + at item @code{+vietnamese-charset+} + at end itemize + at strong{Note:} a future release will include Unicode support by +default; in the meantime, the actual character range is currently +limited to @sc{ascii}.@*@* +The @code{point-size} slot holds the font's point size. The +special value @code{0} instructs the mapper to return a font in the +default size defined for the corresponding face name and style.@*@* +The @code{style} slot holds a list of keywords that further specify attributes +of the requested font. One or more of the following may be specified: + at itemize @bullet + at item one of the following font weight keywords: + at itemize @minus + at item @code{:bold} specifies that the font should be bold + at item @code{:normal} specifies that the font should be normal weight (this is the default) + at end itemize + at item one of the following pitch keywords: + at itemize @minus + at item @code{:fixed} to request a fixed-width font + at item @code{:variable} to request a variable-width font + at end itemize + at item one of the following precision keywords: + at itemize @minus + at item @code{:truetype-only} requests that only a TrueType at registeredsymbol{} font should +be returned + at item @code{:outline} may be specified to request an outline +font or a TrueType at registeredsymbol{} font + at end itemize + at item @code{:italic} may be included to request an italic effect + at item @code{:strikeout} may be included to request a strike-through effect + at item @code{:underline} may be included to request an underline effect + at end itemize + at end deftp + @anchor{font-metrics} @deftp Structure font-metrics ascent descent leading avg-char-width max-char-width This structure describes basic attributes of a font in terms that drawing code Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Mar 28 23:30:00 2006 @@ -126,7 +126,7 @@ @titlepage @title Graphic-Forms Programming Reference - at c @subtitle Version 0.2.0 + at c @subtitle Version 0.3 @c @author Jack D. Unrue @page @@ -136,7 +136,7 @@ @ifnottex @node Top - at top Graphic-Forms Programming Reference (version 0.2) + at top Graphic-Forms Programming Reference (version 0.3) @insertcopying @end ifnottex Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Mar 28 23:30:00 2006 @@ -69,12 +69,14 @@ :components ((:file "magick-core-types") (:file "magick-core-api") + (:file "graphics-constants") (:file "graphics-classes") (:file "graphics-generics") (:file "color") (:file "palette") (:file "image-data") (:file "image") + (:file "font-data") (:file "font") (:file "graphics-context"))) (:module "widgets" Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 28 23:30:00 2006 @@ -62,6 +62,7 @@ #:detail #:dispose #:disposed-p + #:flatten #:handle #:location #:make-point @@ -77,6 +78,7 @@ #:size-width #:span-start #:span-end + #:zero-mem ;; conditions #:disposed-error @@ -96,6 +98,7 @@ ;; classes and structs #:font + #:font-data #:font-metrics #:graphics-context #:image @@ -155,6 +158,10 @@ #:draw-text #:fill-rule #:font + #:font-data-char-set + #:font-data-face-name + #:font-data-point-size + #:font-data-style #:foreground-color #:foreground-pattern #:green-mask @@ -169,6 +176,8 @@ #:line-width #:load #:make-color + #:make-font-data + #:make-image-data #:matrix #:maximum-char-width #:metrics Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 23:30:00 2006 @@ -272,6 +272,16 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) +(defun draw-strings (gc) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (gfg:draw-text gc "This is a placeholder." (gfs:make-point))) + +(defun select-text (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-strings) + (gfw:redraw *drawing-win*)) + (defun draw-wedges (gc) (let* ((rect-pnt (gfs:make-point :x 5 :y 10)) (rect-size (gfs:make-size :width 80 :height 65)) @@ -305,7 +315,8 @@ (:item "&Ellipses" :callback #'select-ellipses) (:item "&Lines and Polylines" :callback #'select-lines) (:item "&Pie Wedges" :callback #'select-wedges) - (:item "&Rectangles" :callback #'select-rects))))))) + (:item "&Rectangles" :callback #'select-rects) + (:item "&Text" :callback #'select-text))))))) (setf *drawing-dispatcher* (make-instance 'drawing-win-events)) (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher* Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Tue Mar 28 23:30:00 2006 @@ -37,12 +37,17 @@ (defclass hellowin-events (gfw:event-dispatcher) ()) -(defmethod gfw:event-close ((d hellowin-events) window time) - (declare (ignore time)) - (gfs:dispose window) +(defun exit-fn (disp item time rect) + (declare (ignorable disp item time rect)) + (gfs:dispose *hello-win*) + (setf *hello-win* nil) (gfw:shutdown 0)) -(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) +(defmethod gfw:event-close ((disp hellowin-events) window time) + (declare (ignore window)) + (exit-fn disp nil time nil)) + +(defmethod gfw:event-paint ((disp hellowin-events) window time gc rect) (declare (ignore time)) (setf rect (make-instance 'gfs:rectangle :location (gfs:make-point) :size (gfw:client-size window))) @@ -53,12 +58,6 @@ (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) -(defun exit-fn (disp item time rect) - (declare (ignorable disp item time rect)) - (gfs:dispose *hello-win*) - (setf *hello-win* nil) - (gfw:shutdown 0)) - (defun run-hello-world-internal () (let ((menubar nil)) (setf *hello-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'hellowin-events) Added: trunk/src/uitoolkit/graphics/font-data.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/font-data.lisp Tue Mar 28 23:30:00 2006 @@ -0,0 +1,79 @@ +;;;; +;;;; font-data.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.graphics) + +(defun compute-font-weight (style) + (if (null (find :bold style)) + gfs::+fw-normal+ + gfs::+fw-bold+)) + +(defun compute-font-precis (style) + (if (find :truetype-only style) + (return-from compute-font-precis gfs::+out-tt-only-precis+)) + (if (find :outline style) + (return-from compute-font-precis gfs::+out-outline-precis+)) + gfs::+out-default-precis+) + +(defun compute-font-pitch (style) + (if (find :fixed style) + (return-from compute-font-pitch gfs::+fixed-pitch+)) + (if (find :variable style) + (return-from compute-font-pitch gfs::+variable-pitch+)) + gfs::+default-pitch+) + +(defun data->font (data) + (let ((hfont (cffi:null-pointer)) + (style (font-data-style data))) + (cffi:with-foreign-object (lf-ptr 'gfs::logfont) + (gfs:zero-mem lf-ptr gfs::logfont) + (cffi:with-foreign-slots ((gfs::lfheight gfs::lfweight gfs::lfitalic gfs::lfunderline + gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec + gfs::lfpitchandfamily gfs::lffacename) + lf-ptr gfs::logfont) + (setf gfs::lfheight (- 0 (font-data-point-size data))) + (setf gfs::lfweight (compute-font-weight style)) + (setf gfs::lfitalic (if (null (find :italic style)) 0 1)) + (setf gfs::lfunderline (if (null (find :underline style)) 0 1)) + (setf gfs::lfstrikeout (if (null (find :strikeout style)) 0 1)) + (setf gfs::lfcharset (font-data-char-set data)) + (setf gfs::lfoutprec (compute-font-precis style)) + (setf gfs::lfpitchandfamily (compute-font-pitch style)) + (cffi:with-foreign-string (str (font-data-face-name data)) + (gfs::strncpy (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename) + str + (1- gfs::+lf-facesize+)))) + (setf hfont (gfs::create-font-indirect lf-ptr)) + (if (gfs:null-handle-p hfont) + (error 'gfs:win32-error :detail "create-font-indirect failed"))) + hfont)) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Tue Mar 28 23:30:00 2006 @@ -39,6 +39,12 @@ (green 0) (blue 0)) + (defstruct font-data + (char-set 1) ; gfg:+default-charset+ (ie., the default for the machine) + (face-name "") + (point-size 10) + (style nil)) + (defstruct font-metrics (ascent 0) (descent 0) Added: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Tue Mar 28 23:30:00 2006 @@ -0,0 +1,59 @@ +;;;; +;;;; graphics-constants.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.graphics) + +;;; The following are transcribed from WinGDI.h; +;;; specify one of them as the value of the char-set +;;; slot in the font-data structure. +;;; +(defconstant +ansi-charset+ 0) +(defconstant +default-charset+ 1) +(defconstant +symbol-charset+ 2) +(defconstant +shiftjis-charset+ 128) +(defconstant +hangeul-charset+ 129) +(defconstant +hangul-charset+ 129) +(defconstant +gb2312-charset+ 134) +(defconstant +chinesebig5-charset+ 136) +(defconstant +oem-charset+ 255) +(defconstant +johab-charset+ 130) +(defconstant +hebrew-charset+ 177) +(defconstant +arabic-charset+ 178) +(defconstant +greek-charset+ 161) +(defconstant +turkish-charset+ 162) +(defconstant +vietnamese-charset+ 163) +(defconstant +thai-charset+ 222) +(defconstant +easteurope-charset+ 238) +(defconstant +russian-charset+ 204) +(defconstant +mac-charset+ 77) +(defconstant +baltic-charset+ 186) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 23:30:00 2006 @@ -426,6 +426,8 @@ (when (null (gfs:handle self)) (setf (owns-dc self) t) (setf (slot-value self 'gfs:handle) (gfs::create-compatible-dc (cffi:null-pointer)))) + ;; ensure world-to-device transformation conformance + (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) (defmethod (setf pen-style) :around (style (self graphics-context)) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 23:30:00 2006 @@ -125,6 +125,11 @@ (offset DWORD)) (defcfun + ("CreateFontIndirectA" create-font-indirect) + HANDLE + (logfont LPTR)) + +(defcfun ("CreatePen" create-pen) HANDLE (style INT) @@ -349,6 +354,12 @@ (color-use UINT)) (defcfun + ("SetGraphicsMode" set-graphics-mode) + INT + (hdc HANDLE) + (mode INT)) + +(defcfun ("SetMiterLimit" set-miter-limit) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Mar 28 23:30:00 2006 @@ -192,13 +192,31 @@ (defconstant +eto-opaque+ #x0002) (defconstant +eto-clipped+ #x0004) -(defconstant +eto-glyph_index+ #x0010) +(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 +ff-dontcare+ #x0000) +(defconstant +ff-roman+ #x0010) +(defconstant +ff-swiss+ #x0020) +(defconstant +ff-modern+ #x0030) +(defconstant +ff-script+ #x0040) +(defconstant +ff-decorative+ #x0050) + +(defconstant +fw-dontcare+ 0) +(defconstant +fw-thin+ 100) +(defconstant +fw-extralight+ 200) +(defconstant +fw-light+ 300) +(defconstant +fw-normal+ 400) +(defconstant +fw-medium+ 500) +(defconstant +fw-semibold+ 600) +(defconstant +fw-bold+ 700) +(defconstant +fw-extrabold+ 800) +(defconstant +fw-heavy+ 900) + (defconstant +ga-parent+ 1) (defconstant +ga-root+ 2) (defconstant +ga-rootowner+ 3) @@ -215,6 +233,10 @@ (defconstant +gcw-atom+ -32) (defconstant +gclp-hiconsm+ -34) +(defconstant +gm-compatible+ 1) +(defconstant +gm-advanced+ 2) +(defconstant +gm-last+ 3) + (defconstant +gwlp-wndproc+ -4) (defconstant +gwlp-hinstance+ -6) (defconstant +gwl-hwndparent+ -8) @@ -235,6 +257,9 @@ (defconstant +image-cursor+ 2) (defconstant +image-enhmetafile+ 3) +(defconstant +lf-facesize+ 32) +(defconstant +lf-fullfacesize+ 64) + (defconstant +lr-defaultcolor+ #x0000) (defconstant +lr-monochrome+ #x0001) (defconstant +lr-color+ #x0002) @@ -368,6 +393,18 @@ (defconstant +ocr-hand+ 32649) (defconstant +ocr-appstarting+ 32650) +(defconstant +out-default-precis+ 0) +(defconstant +out-string-precis+ 1) +(defconstant +out-character-precis+ 2) +(defconstant +out-stroke-precis+ 3) +(defconstant +out-tt-precis+ 4) +(defconstant +out-device-precis+ 5) +(defconstant +out-raster-precis+ 6) +(defconstant +out-tt-only-precis+ 7) +(defconstant +out-outline-precis+ 8) +(defconstant +out-screen-outline-precis+ 9) +(defconstant +out-ps-only-precis+ 10) + (defconstant +qs-key+ #x0001) (defconstant +qs-mousemove+ #x0002) (defconstant +qs-mousebutton+ #x0004) @@ -751,3 +788,7 @@ (defconstant +default-gui-font+ 17) (defconstant +dc-brush+ 18) (defconstant +dc-pen+ 19) + +(defconstant +default-pitch+ 0) +(defconstant +fixed-pitch+ 1) +(defconstant +variable-pitch+ 2) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Mar 28 23:30:00 2006 @@ -119,6 +119,22 @@ (color COLORREF) (hatch LONG)) +(defcstruct logfont + (lfheight LONG) + (lfwidth LONG) + (lfescapement LONG) + (lforientation LONG) + (lfweight LONG) + (lfitalic LONG) + (lfunderline LONG) + (lfstrikeout LONG) + (lfcharset LONG) + (lfoutprec LONG) + (lfclipprec LONG) + (lfquality LONG) + (lfpitchandfamily LONG) + (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 + (defcstruct menuinfo (cbsize DWORD) (mask DWORD) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Tue Mar 28 23:30:00 2006 @@ -34,6 +34,23 @@ (in-package :graphic-forms.uitoolkit.system) ;;; +;;; convenience functions +;;; + +(defun flatten (tree) + (if (cl:atom tree) + (list tree) + (mapcan (function flatten) tree))) + +;;; lifted from lispbuilder-windows/windows/util.lisp +;;; author: Frank Buss +;;; +(defmacro zero-mem (object type) + (let ((i (gensym))) + `(loop for ,i from 0 below (foreign-type-size (quote ,type)) do + (setf (mem-aref ,object :char ,i) 0)))) + +;;; ;;; convenience macros ;;; Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Mar 28 23:30:00 2006 @@ -41,7 +41,7 @@ (declare (ignore btn)) (let ((std-flags 0) (ex-flags 0)) - (setf style (flatten style)) + (setf style (gfs:flatten style)) ;; FIXME: check whether any of the primary button ;; styles were specified, default to :push-button ;; Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Mar 28 23:30:00 2006 @@ -41,7 +41,7 @@ (declare (ignore label)) (let ((std-flags 0) (ex-flags 0)) - (setf style (flatten style)) + (setf style (gfs:flatten style)) (unless (or (find :beginning style) (find :center style) (find :end style)) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Tue Mar 28 23:30:00 2006 @@ -58,7 +58,7 @@ ;; ((eq sym :style-border) (setf std-flags (logior std-flags gfs::+ws-border+))))) - (flatten style)) + (gfs:flatten style)) (values std-flags ex-flags))) (defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Mar 28 23:30:00 2006 @@ -107,7 +107,7 @@ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) (setf ex-flags 0)))) - (flatten style)) + (gfs:flatten style)) (values std-flags ex-flags))) (defmethod gfs:dispose ((win top-level)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Mar 28 23:30:00 2006 @@ -76,13 +76,6 @@ (cffi:null-pointer) 0)))) -;;; FIXME: move this to a common, non-UI module -;;; -(defun flatten (tree) - (if (atom tree) - (list tree) - (mapcan (function flatten) tree))) - (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) From junrue at common-lisp.net Thu Mar 30 05:35:09 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 30 Mar 2006 00:35:09 -0500 (EST) Subject: [graphic-forms-cvs] r83 - in trunk: etc src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system Message-ID: <20060330053509.688DC78003@common-lisp.net> Author: junrue Date: Thu Mar 30 00:35:00 2006 New Revision: 83 Added: trunk/etc/font-test.doc (contents, props changed) Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/font-data.lisp trunk/src/uitoolkit/graphics/font.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/graphics/magick-core-api.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp Log: implemented font selection into graphics contexts; changed data->font to take gc param in anticipation of printer support Added: trunk/etc/font-test.doc ============================================================================== Binary file. No diff available. Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Thu Mar 30 00:35:00 2006 @@ -272,9 +272,34 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) +(defun draw-a-string (gc pnt face-name pt-size style) + (let* ((font (make-instance 'gfg:font :gc gc + :data (gfg:make-font-data :face-name face-name + :style style + :point-size pt-size))) + (metrics (gfg:metrics gc font))) + (unwind-protect + (progn + (setf (gfg:font gc) font) + (gfg:draw-text gc face-name pnt) + (gfs:make-point :x (gfs:point-x pnt) :y (+ (gfs:point-y pnt) (gfg:height metrics)))) + (gfs:dispose font)))) + (defun draw-strings (gc) (setf (gfg:foreground-color gc) gfg:*color-blue*) - (gfg:draw-text gc "This is a placeholder." (gfs:make-point))) + (let ((pnt (gfs:make-point :x 2 :y 0))) + (setf pnt (draw-a-string gc pnt "Times New Roman" 10 nil)) + (setf pnt (draw-a-string gc pnt "Times New Roman" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Times New Roman" 18 '(:strikeout))) + (setf pnt (draw-a-string gc pnt "Tahoma" 10 nil)) + (setf pnt (draw-a-string gc pnt "Tahoma" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Tahoma" 18 '(:strikeout))) + (setf pnt (draw-a-string gc pnt "Lucida Console" 10 nil)) + (setf pnt (draw-a-string gc pnt "Lucida Console" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Lucida Console" 18 '(:strikeout))) + (setf pnt (draw-a-string gc pnt "Courier New" 10 nil)) + (setf pnt (draw-a-string gc pnt "Courier New" 14 '(:italic :bold :underline))) + (setf pnt (draw-a-string gc pnt "Courier New" 18 '(:strikeout))))) (defun select-text (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/font-data.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font-data.lisp (original) +++ trunk/src/uitoolkit/graphics/font-data.lisp Thu Mar 30 00:35:00 2006 @@ -52,7 +52,7 @@ (return-from compute-font-pitch gfs::+variable-pitch+)) gfs::+default-pitch+) -(defun data->font (data) +(defun data->font (hdc data) (let ((hfont (cffi:null-pointer)) (style (font-data-style data))) (cffi:with-foreign-object (lf-ptr 'gfs::logfont) @@ -61,7 +61,10 @@ gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec gfs::lfpitchandfamily gfs::lffacename) lf-ptr gfs::logfont) - (setf gfs::lfheight (- 0 (font-data-point-size data))) + (setf gfs::lfheight (- (floor (+ (/ (* (font-data-point-size data) + (gfs::get-device-caps hdc gfs::+logpixelsy+)) + 72) + 0.5)))) (setf gfs::lfweight (compute-font-weight style)) (setf gfs::lfitalic (if (null (find :italic style)) 0 1)) (setf gfs::lfunderline (if (null (find :underline style)) 0 1)) @@ -70,9 +73,9 @@ (setf gfs::lfoutprec (compute-font-precis style)) (setf gfs::lfpitchandfamily (compute-font-pitch style)) (cffi:with-foreign-string (str (font-data-face-name data)) - (gfs::strncpy (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename) - str - (1- gfs::+lf-facesize+)))) + (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename))) + (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+)) + (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0)))) (setf hfont (gfs::create-font-indirect lf-ptr)) (if (gfs:null-handle-p hfont) (error 'gfs:win32-error :detail "create-font-indirect failed"))) Modified: trunk/src/uitoolkit/graphics/font.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/font.lisp (original) +++ trunk/src/uitoolkit/graphics/font.lisp Thu Mar 30 00:35:00 2006 @@ -42,3 +42,6 @@ (unless (gfs:null-handle-p hgdi) (gfs::delete-object hgdi))) (setf (slot-value fn 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys) + (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data))) Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Mar 30 00:35:00 2006 @@ -40,7 +40,7 @@ (blue 0)) (defstruct font-data - (char-set 1) ; gfg:+default-charset+ (ie., the default for the machine) + (char-set 0) (face-name "") (point-size 10) (style nil)) @@ -63,8 +63,7 @@ (defmacro height (metrics) `(+ (gfg::font-metrics-ascent ,metrics) - (gfg::font-metrics-descent ,metrics) - (gfg::font-metrics-leading ,metrics))) + (gfg::font-metrics-descent ,metrics))) (defmacro average-char-width (metrics) `(gfg::font-metrics-avg-char-width ,metrics)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Thu Mar 30 00:35:00 2006 @@ -409,6 +409,11 @@ gfs::+dt-vcenter+) (cffi:null-pointer))))) +(defmethod (setf font) ((font font) (self graphics-context)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (gfs::select-object (gfs:handle self) (gfs:handle font))) + (defmethod foreground-color ((self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) @@ -430,6 +435,26 @@ (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) (update-pen-for-gc self)) +(defmethod metrics ((self graphics-context) (font font)) + (if (or (gfs:disposed-p self) (gfs:disposed-p font)) + (error 'gfs:disposed-error)) + (let ((hdc (gfs:handle self)) + (hfont (gfs:handle font)) + (metrics nil)) + (gfs::with-hfont-selected (hdc hfont) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmascent gfs::tmdescent gfs::tmexternalleading + gfs::tmavgcharwidth gfs::tmmaxcharwidth) + tm-ptr gfs::textmetrics) + (if (zerop (gfs::get-text-metrics hdc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf metrics (make-font-metrics :ascent gfs::tmascent + :descent gfs::tmdescent + :leading gfs::tmexternalleading + :avg-char-width gfs::tmavgcharwidth + :max-char-width gfs::tmmaxcharwidth))))) + metrics)) + (defmethod (setf pen-style) :around (style (self graphics-context)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Thu Mar 30 00:35:00 2006 @@ -123,9 +123,6 @@ (defgeneric draw-text (self text pnt) (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string.")) -(defgeneric fill-rule (self) - (:documentation "Returns an integer specifying the current fill rule.")) - (defgeneric font (self) (:documentation "Returns the current font.")) @@ -159,8 +156,8 @@ (defgeneric matrix (self) (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) -(defgeneric metrics (self) - (:documentation "Returns a metrics object describing key attributes of the specified object.")) +(defgeneric metrics (self font) + (:documentation "Returns a metrics object describing key attributes of the specified font.")) (defgeneric multiply (self other) (:documentation "Returns a modified version of the object which is the result of multiplying the original with the other parameter.")) Modified: trunk/src/uitoolkit/graphics/magick-core-api.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original) +++ trunk/src/uitoolkit/graphics/magick-core-api.lisp Thu Mar 30 00:35:00 2006 @@ -190,9 +190,9 @@ (error 'gfs:toolkit-error :detail "could not allocate Magick ImageInfo object")) (unwind-protect (cffi:with-foreign-string (str ,path) - (gfs::strncpy (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename) - str - (1- +magick-max-text-extent+)) - , at body)) + (let ((filename-ptr (cffi:foreign-slot-pointer ,info 'magick-image-info 'filename))) + (gfs::strncpy filename-ptr str (1- +magick-max-text-extent+)) + (setf (cffi:mem-aref filename-ptr :char (1- +magick-max-text-extent+)) 0)) + , at body) (destroy-image-info ,info) - (destroy-exception-info ,ex)))) + (destroy-exception-info ,ex))))) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu Mar 30 00:35:00 2006 @@ -202,6 +202,12 @@ (hdc HANDLE)) (defcfun + ("GetDeviceCaps" get-device-caps) + INT + (hdc HANDLE) + (index INT)) + +(defcfun ("GetDIBits" get-di-bits) INT (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Mar 30 00:35:00 2006 @@ -792,3 +792,47 @@ (defconstant +default-pitch+ 0) (defconstant +fixed-pitch+ 1) (defconstant +variable-pitch+ 2) + +;;; +;;; device parameters for get-device-caps +;;; +(defconstant +driverversion+ 0) +(defconstant +technology+ 2) +(defconstant +horzsize+ 4) +(defconstant +vertsize+ 6) +(defconstant +horzres+ 8) +(defconstant +vertres+ 10) +(defconstant +bitspixel+ 12) +(defconstant +planes+ 14) +(defconstant +numbrushes+ 16) +(defconstant +numpens+ 18) +(defconstant +nummarkers+ 20) +(defconstant +numfonts+ 22) +(defconstant +numcolors+ 24) +(defconstant +pdevicesize+ 26) +(defconstant +curvecaps+ 28) +(defconstant +linecaps+ 30) +(defconstant +polygonalcaps+ 32) +(defconstant +textcaps+ 34) +(defconstant +clipcaps+ 36) +(defconstant +rastercaps+ 38) +(defconstant +aspectx+ 40) +(defconstant +aspecty+ 42) +(defconstant +aspectxy+ 44) +(defconstant +logpixelsx+ 88) +(defconstant +logpixelsy+ 90) +(defconstant +sizepalette+ 104) +(defconstant +numreserved+ 106) +(defconstant +colorres+ 108) +(defconstant +physicalwidth+ 110) +(defconstant +physicalheight+ 111) +(defconstant +physicaloffsetx+ 112) +(defconstant +physicaloffsety+ 113) +(defconstant +scalingfactorx+ 114) +(defconstant +scalingfactory+ 115) +(defconstant +vrefresh+ 116) +(defconstant +desktopvertres+ 117) +(defconstant +desktophorzres+ 118) +(defconstant +bltalignment+ 119) +(defconstant +shadeblendcaps+ 120) +(defconstant +colormgmtcaps+ 121) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Mar 30 00:35:00 2006 @@ -125,14 +125,14 @@ (lfescapement LONG) (lforientation LONG) (lfweight LONG) - (lfitalic LONG) - (lfunderline LONG) - (lfstrikeout LONG) - (lfcharset LONG) - (lfoutprec LONG) - (lfclipprec LONG) - (lfquality LONG) - (lfpitchandfamily LONG) + (lfitalic BYTE) + (lfunderline BYTE) + (lfstrikeout BYTE) + (lfcharset BYTE) + (lfoutprec BYTE) + (lfclipprec BYTE) + (lfquality BYTE) + (lfpitchandfamily BYTE) (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 (defcstruct menuinfo From junrue at common-lisp.net Fri Mar 31 23:21:20 2006 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Fri, 31 Mar 2006 18:21:20 -0500 (EST) Subject: [graphic-forms-cvs] r84 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20060331232120.573491F003@common-lisp.net> Author: junrue Date: Fri Mar 31 18:21:19 2006 New Revision: 84 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented :tab and :mnemonic text drawing styles; implemented text-extent method and refactored widgets package at the same time Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Mar 31 18:21:19 2006 @@ -1027,9 +1027,23 @@ using the current pen width and style. @end deffn - at deffn GenericFunction draw-text self text pnt -Draws the given string in the current font and foreground color, with -(x, y) being the top-left coordinate of a bounding box for the string. + at deffn GenericFunction draw-text self text point &optional style tab-width +Draws @code{text} in the current font and foreground color, with + at code{point} being the top-left coordinate of a bounding box for the +string. The optional @code{style} parameter is a list containing the +following text style keywords: + at table @code + at item :mnemonic +underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}) + at item :tab +expand tabs when the string is rendered; by default the tab-width +is 8 characters, but the optional @code{tab-width} parameter may +be used to specify a different width + at item :transparent + at emph{This style is not yet implemented.} the background of the +rectangular area where text is drawn will not be modified + at end table @end deffn @deffn GenericFunction font self @@ -1041,12 +1055,27 @@ Returns a color object corresponding to the current foreground color. @end deffn - at deffn GenericFunction metrics self -Returns a metrics object describing key attributes of the specified object. + at deffn GenericFunction metrics self font +Returns a @ref{font-metrics} object describing key attributes of @code{font}. @end deffn @deffn GenericFunction size self -Returns a size object describing the size of the object. +Returns a size object describing the dimensions of the object. + at end deffn + + at deffn GenericFunction text-extent self text &optional style tab-width +Returns the size of a rectangular that would enclose @code{text} if it +were drawn in the current font. The optional @code{style} parameter is +a list containing the following text style keywords: + at table @code + at item :mnemonic +underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}) + at item :tab +expand tabs when the string is rendered; by default the tab-width +is 8 characters, but the optional @code{tab-width} parameter may +be used to specify a different width + at end table @end deffn @deffn GenericFunction transparency-mask self Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 31 18:21:19 2006 @@ -272,34 +272,51 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) -(defun draw-a-string (gc pnt face-name pt-size style) +(defun draw-a-string (gc pnt text face-name pt-size font-style text-style) (let* ((font (make-instance 'gfg:font :gc gc :data (gfg:make-font-data :face-name face-name - :style style + :style font-style :point-size pt-size))) (metrics (gfg:metrics gc font))) + (if (or (null text) (zerop (length text))) + (setf text face-name)) (unwind-protect (progn (setf (gfg:font gc) font) - (gfg:draw-text gc face-name pnt) + (gfg:draw-text gc text pnt text-style) (gfs:make-point :x (gfs:point-x pnt) :y (+ (gfs:point-y pnt) (gfg:height metrics)))) (gfs:dispose font)))) (defun draw-strings (gc) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let ((pnt (gfs:make-point :x 2 :y 0))) - (setf pnt (draw-a-string gc pnt "Times New Roman" 10 nil)) - (setf pnt (draw-a-string gc pnt "Times New Roman" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Times New Roman" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Tahoma" 10 nil)) - (setf pnt (draw-a-string gc pnt "Tahoma" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Tahoma" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Lucida Console" 10 nil)) - (setf pnt (draw-a-string gc pnt "Lucida Console" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Lucida Console" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Courier New" 10 nil)) - (setf pnt (draw-a-string gc pnt "Courier New" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Courier New" 18 '(:strikeout))))) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 18 '(:strikeout) nil)) + + (setf (gfs:point-x pnt) (+ (floor (/ (gfs:size-width (gfw:client-size *drawing-win*)) 2)) 10)) + (setf (gfs:point-y pnt) 0) + (setf pnt (draw-a-string gc pnt (format nil "tab~ctab~ctab" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) + (setf pnt (draw-a-string gc pnt (format nil "even~cmore~ctabs" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) + (setf pnt (draw-a-string gc pnt " " "Verdana" 10 nil nil)) + (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))))) + +#| + (setf pnt (draw-a-string gc pnt " " "Arial" 18 nil nil)) + (draw-a-string gc pnt "transparent" "Arial" 18 '(:bold) nil) + (incf (gfs:point-x pnt) 50) + (setf (gfg:foreground-color gc) gfg:*color-red*) + (draw-a-string gc pnt "text" "Arial" 10 '(:bold) '(:transparent)) +|# (defun select-text (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Mar 31 18:21:19 2006 @@ -152,6 +152,44 @@ (error 'gfs:win32-error :detail (format nil "~a failed" name)))) (cffi:foreign-free array)))) +(defun compute-draw-text-style (style) + (let ((flags (logior gfs::+dt-noclip+ gfs::+dt-noprefix+ gfs::+dt-singleline+ gfs::+dt-vcenter+))) + (unless (null style) + (loop for sym in style + do (cond + ((eq sym :mnemonic) + (setf flags (logand flags (lognot gfs::+dt-noprefix+)))) + ((eq sym :tab) + (setf flags (logior flags gfs::+dt-expandtabs+))) + ;; FIXME: the :transparent style needs to be implemented + ;; + ((eq sym :transparent))))) + flags)) + +(defun text-bounds (hdc str dt-flags tab-width) + (let ((len (length str)) + (sz (gfs:make-size))) + (when (> len 0) + (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) + (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) + dt-ptr gfs::drawtextparams) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::drawtextparams)) + (setf gfs::tablength tab-width) + (setf gfs::leftmargin 0) + (setf gfs::rightmargin 0) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) + (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (setf (gfs:size-width sz) (- gfs::right gfs::left)) + (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))) + (when (or (zerop len) (zerop (gfs:size-height sz))) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics) + (if (zerop (gfs::get-text-metrics hdc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))) + sz)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-null-brush ((gc) &body body) (let ((hdc (gensym)) @@ -385,29 +423,35 @@ (with-null-brush (self) (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))) -(defmethod draw-text ((self graphics-context) text (pnt gfs:point)) +(defmethod draw-text ((self graphics-context) text (pnt gfs:point) &optional style tab-width) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (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::left (gfs:point-x pnt)) - (setf gfs::top (gfs:point-y pnt)) - (gfs::draw-text (gfs:handle self) - text - -1 - rect-ptr - (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) - (cffi:null-pointer)) - (gfs::draw-text (gfs:handle self) - text - (length text) - rect-ptr - (logior gfs::+dt-noclip+ - gfs::+dt-noprefix+ - gfs::+dt-singleline+ - gfs::+dt-vcenter+) - (cffi:null-pointer))))) + (let ((flags (compute-draw-text-style style)) + (tb-width (if (null tab-width) 0 tab-width))) + (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) + (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) + dt-ptr gfs::drawtextparams) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::drawtextparams)) + (setf gfs::tablength tb-width) + (setf gfs::leftmargin 0) + (setf gfs::rightmargin 0) + (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::left (gfs:point-x pnt)) + (setf gfs::top (gfs:point-y pnt)) + (gfs::draw-text-ex (gfs:handle self) + text + -1 + rect-ptr + (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) + dt-ptr) + (gfs::draw-text-ex (gfs:handle self) + text + (length text) + rect-ptr + flags + dt-ptr))))))) (defmethod (setf font) ((font font) (self graphics-context)) (if (gfs:disposed-p self) @@ -466,3 +510,11 @@ (error 'gfs:disposed-error)) (setf (slot-value self 'pen-width) width) (update-pen-for-gc self)) + +(defmethod text-extent ((self graphics-context) str &optional style tab-width) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (text-bounds (gfs:handle self) + str + (compute-draw-text-style style) + (if (or (null tab-width) (< tab-width 0)) 0 tab-width))) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Fri Mar 31 18:21:19 2006 @@ -33,27 +33,9 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defgeneric alpha (self) - (:documentation "Returns an integer representing an alpha value.")) - -(defgeneric anti-alias (self) - (:documentation "Returns an int representing the current anti-alias setting.")) - (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric background-pattern (self) - (:documentation "Returns a pattern object representing the current background pattern.")) - -(defgeneric clipped-p (self) - (:documentation "Returns T if a clipping region is set; nil otherwise.")) - -(defgeneric clipping-rectangle (self) - (:documentation "Returns a rectangle object representing the current clipping rectangle.")) - -(defgeneric copy-area (self src-rect dest-pnt) - (:documentation "Copies a rectangular area of the source onto the destination.")) - (defgeneric data-obj (self) (:documentation "Returns the data structure representing the raw form of the object.")) @@ -120,8 +102,8 @@ (defgeneric draw-rounded-rectangle (self rect size) (:documentation "Draws the outline of the rectangle with rounded corners.")) -(defgeneric draw-text (self text pnt) - (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string.")) +(defgeneric draw-text (self text pnt &optional style tab-width) + (:documentation "Draws the given string in the current font and foreground color.")) (defgeneric font (self) (:documentation "Returns the current font.")) @@ -129,65 +111,17 @@ (defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric foreground-pattern (self) - (:documentation "Returns a pattern object representing the current foreground pattern.")) - -(defgeneric invert (self) - (:documentation "Returns a modified version of the object which is the mathematical inverse of the original.")) - -(defgeneric line-cap-style (self) - (:documentation "Returns an integer representing the line cap style.")) - -(defgeneric line-dash-style (self) - (:documentation "Returns a list of integers representing the line dash style.")) - -(defgeneric line-join-style (self) - (:documentation "Returns an integer representing the line join style.")) - -(defgeneric line-style (self) - (:documentation "Returns an integer representing the line style.")) - -(defgeneric line-width (self) - (:documentation "Returns an integer representing the line width.")) - (defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) -(defgeneric matrix (self) - (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) - (defgeneric metrics (self font) - (:documentation "Returns a metrics object describing key attributes of the specified font.")) - -(defgeneric multiply (self other) - (:documentation "Returns a modified version of the object which is the result of multiplying the original with the other parameter.")) - -(defgeneric rotate (self angle) - (:documentation "Returns a modified version of the object which is the result of rotating the original by the specified angle.")) - -(defgeneric scale (self delta-x delta-y) - (:documentation "Returns a modified version of the object which is the result of scaling the original by the specified mathematical vector.")) + (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) (defgeneric size (self) (:documentation "Returns a size object describing the size of the object.")) -(defgeneric text-anti-alias (self) - (:documentation "Returns an integer representing the text anti-alias setting.")) - -(defgeneric text-extent (self str) +(defgeneric text-extent (self str &optional style tab-width) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) -(defgeneric transform (self) - (:documentation "Returns a transform object indicating how coordinates are transformed in the context of this object.")) - -(defgeneric transform-coordinates (self pnts) - (:documentation "Returns a list of point objects that are the result of applying a transformation against the specified list of points.")) - -(defgeneric translate (self delta-x delta-y) - (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) - (defgeneric transparency-mask (self) (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) - -(defgeneric xor-mode-p (self) - (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Mar 31 18:21:19 2006 @@ -147,7 +147,7 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text) + ("DrawTextExA" draw-text-ex) INT (hdc HANDLE) (text :string) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 31 18:21:19 2006 @@ -114,6 +114,13 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct drawtextparams + (cbsize UINT) + (tablength INT) + (leftmargin INT) + (rightmargin INT) + (lengthdrawn UINT)) + (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 Fri Mar 31 18:21:19 2006 @@ -77,7 +77,7 @@ (init-control btn)) (defmethod preferred-size ((btn button) width-hint height-hint) - (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) + (let ((sz (widget-text-size btn gfs::+dt-singleline+))) (if (>= width-hint 0) (setf (gfs:size-width sz) width-hint) (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Mar 31 18:21:19 2006 @@ -97,7 +97,7 @@ gfs::+dt-expandtabs+))) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags width-hint)) + (setf sz (widget-text-size label flags)) (if (>= width-hint 0) (setf (gfs:size-width sz) width-hint)) (if (>= height-hint 0) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Mar 31 18:21:19 2006 @@ -122,30 +122,10 @@ (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags width-hint) - (let* ((hwnd (gfs:handle widget)) - (str (text widget)) - (len (length str)) - (sz (gfs:make-size)) - (hfont nil)) - (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) +(defun widget-text-size (widget dt-flags) + (let ((hwnd (gfs:handle widget)) + (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (when (> len 0) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (if (> width-hint 0) - (setf gfs::right width-hint)) - (gfs::draw-text hdc str -1 rect-ptr dt-flags (cffi:null-pointer)) - (setf (gfs:size-width sz) (- gfs::right gfs::left)) - (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))) - (when (or (zerop len) (zerop (gfs:size-height sz))) - (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) - (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) - tm-ptr gfs::textmetrics) - (if (zerop (gfs::get-text-metrics hdc tm-ptr)) - (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) - sz)) + (gfg::text-bounds hdc (text widget) dt-flags 0)))))