[graphic-forms-cvs] r83 - in trunk: etc src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Thu Mar 30 05:35:09 UTC 2006
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
More information about the Graphic-forms-cvs
mailing list