[graphic-forms-cvs] r82 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Mar 29 04:30:02 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list