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+)) - ,@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)) + ,@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