truetype: better support for font dpi

4 files changed, 30 insertions, 9 deletions

diff --git a/Backends/CLX/graft.lisp b/Backends/CLX/graft.lisp
index eb42a546..ebde5602 100644
--- a/Backends/CLX/graft.lisp
+++ b/Backends/CLX/graft.lisp
@@ -10,6 +10,10 @@
 (in-package #:clim-clx)
 
 ;;; CLX-GRAFT class
+;;;
+;;; Note that GRAFT-WIDTH and GRAFT-HEIGHT are _not_ reliable for physical size
+;;; on X11. It defaults to 96 DPI unless explicitly configured to say otherwise,
+;;; disregarding of the real display size. -- jd 2023-12-27
 
 (defclass clx-graft (graft) ())
 
diff --git a/Extensions/fonts/mcclim-native-ttf.lisp b/Extensions/fonts/mcclim-native-ttf.lisp
index 114d0d64..4adbf1ff 100644
--- a/Extensions/fonts/mcclim-native-ttf.lisp
+++ b/Extensions/fonts/mcclim-native-ttf.lisp
@@ -35,7 +35,7 @@
 
 
 (defvar *zpb-font-lock* (clim-sys:make-lock "zpb-font"))
-(defparameter *dpi* 72)
+
 
 (defclass truetype-font-family (font-family)
   ((all-faces :initform nil
@@ -80,17 +80,19 @@
    (units->pixels                    :reader zpb-ttf-font-units->pixels))
   ;; Parameters TRACKING and LEADING are specified in [em]. Internally we keep
   ;; them in [units].
-  (:default-initargs :fixed nil :kerning t :tracking 0.0 :leading 1.2))
+  (:default-initargs :fixed nil :dpi 72 :kerning t :tracking 0.0 :leading 1.2))
 
 (defgeneric font-port (font)
   (:method ((font truetype-font))
     (font-family-port (font-face-family (font-face font)))))
 
-(defmethod initialize-instance :after ((font truetype-font) &key tracking leading &allow-other-keys)
+(defmethod initialize-instance :after
+    ((font truetype-font) &key dpi tracking leading &allow-other-keys)
   (with-slots (face size ascent descent font-loader) font
     (let* ((loader (zpb-ttf-font-loader face))
            (em->units (zpb-ttf:units/em loader))
-           (units->pixels (/ (* size (/ *dpi* 72)) em->units)))
+           (dpi-factor (/ dpi 72))
+           (units->pixels (/ (* size dpi-factor) em->units)))
       (setf ascent  (+ (* units->pixels (zpb-ttf:ascender loader)))
             descent (- (* units->pixels (zpb-ttf:descender loader)))
             (slot-value font 'tracking) (* units->pixels (* em->units tracking))
@@ -265,7 +267,7 @@
 (defun font-glyph-info (font code)
   (with-slots (char->glyph-info) font
     (ensure-gethash code char->glyph-info
-                    (font-generate-glyph (font-port font) font code))))
+      (font-generate-glyph (font-port font) font code))))
 
 (defgeneric font-generate-glyph (port font code &key &allow-other-keys)
   (:documentation "Truetype TTF renderer internal interface.")
diff --git a/Extensions/fonts/truetype-package.lisp b/Extensions/fonts/truetype-package.lisp
index b453afed..7b54dab7 100644
--- a/Extensions/fonts/truetype-package.lisp
+++ b/Extensions/fonts/truetype-package.lisp
@@ -9,6 +9,7 @@
                 #:assoc-value
                 #:read-file-into-byte-vector
                 #:maphash-values)
+  ;; Fontconfig
   (:export #:*truetype-font-path*
            #:*families/faces*
            #:*zpb-font-lock*
@@ -18,10 +19,12 @@
            #:make-fontconfig-font-name
            #:find-fontconfig-font
            #:invoke-with-truetype-path-restart)
+  ;; Implementation classes
   (:export #:truetype-font
            #:truetype-font-family
            #:truetype-face
            #:cached-truetype-font)
+  ;; Atlas implementgation
   (:export #:font-glyph-id
            #:font-glyph-dx
            #:font-glyph-info
@@ -30,6 +33,7 @@
            #:font-generate-glyph
            #:glyph-pixarray
            #:font-string-glyph-codes)
+  ;; Glyph metrics
   (:export #:glyph-info
            #:glyph-info-id
            #:glyph-info-pixarray
@@ -41,5 +45,6 @@
            #:glyph-info-advance-height*
            #:glyph-info-advance-width
            #:glyph-info-advance-height)
+  ;; Consumer exports
   (:export #:ttf-port-mixin
            #:ttf-medium-mixin))
diff --git a/Extensions/fonts/ttf-port-mixin.lisp b/Extensions/fonts/ttf-port-mixin.lisp
index 70f3b776..8bd912ab 100644
--- a/Extensions/fonts/ttf-port-mixin.lisp
+++ b/Extensions/fonts/ttf-port-mixin.lisp
@@ -12,6 +12,9 @@
 
 (in-package #:mcclim-truetype)
 
+(defparameter *dpi* nil
+  "The value of DPI used to overwrite the default font scaling.")
+
 (defclass ttf-port-mixin ()
   ((back-memory-cache :initform (make-hash-table :test #'equal) :allocation :class)
    ;; source -> loader (the source may be a filename or a memory block)
@@ -24,7 +27,13 @@
    ;; All registered families. Populated by ensure-truetype-font.
    (font-families :initform '() :accessor font-families)
    ;; DPI (for font scaling)
-   (font-dpi :initform *dpi* :initarg :dpi :reader font-dpi)))
+   (font-dpi :initarg :dpi :accessor font-dpi)))
+
+(defmethod initialize-instance :after ((port ttf-port-mixin) &key dpi)
+  (unless dpi
+    (setf (slot-value port 'font-dpi)
+          (or *dpi*
+              (clim:graft-pixels-per-inch (clim:find-graft :port port))))))
 
 (defun invalidate-port-font-cache (port)
   (with-slots (font-loader-cache font-family-cache font-direct-cache text-style-cache) port
@@ -57,15 +66,16 @@
       (let* ((loader (or loader (zpb-ttf:open-font-loader source)))
              (f1-name (zpb-ttf:family-name loader))
              (f2-name (zpb-ttf:subfamily-name loader))
-             (text-style (make-text-style f1-name f2-name size)))
+             (text-style (make-text-style f1-name f2-name size))
+             (font-dpi (font-dpi port)))
         (flet ((make-family ()
                  (make-instance 'truetype-font-family :name f1-name :port port))
                (make-face (family)
                  (make-instance 'truetype-face :family family :name f2-name
                                                :loader loader :preloaded preload))
                (make-font (face size)
-                 (let ((*dpi* (font-dpi port)))
-                   (make-instance 'cached-truetype-font :face face :size size))))
+                 (make-instance 'cached-truetype-font
+                                :face face :size size :dpi font-dpi)))
           (when loader-foundp
             (return-from ensure-truetype-font
               (destructuring-bind (face fonts) (gethash loader font-direct-cache)