<commit_before>;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-TRUETYPE; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: Glyph rendering via zpb-ttf and cl-vectors
;;;   Created: 2008-01-26 16:32
;;;    Author: <NAME> <<EMAIL>>
;;;   License: LGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2008 by <NAME>

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :mcclim-truetype)

;;; TODO:
;;;  * Kerning (we didn't do this with Freetype, either. Oops.)
;;;  * Implement fixed-font-width-p for zpb-ttf.
;;;  * Boxes for missing glyphs.
;;;  * Make certain left/right bearings and text-bounding-rectangle*
;;;    are correct. (I doubt they are..)

;;; Wish-list:

;;;  * Subpixel antialiasing. It would be straightforward to generate the
;;;    glyphs by tripling the width as passed to cl-vectors and compressing
;;;    triplets of pixels together ourselves. I'm not certain how to draw
;;;    the result through xrender. I've seen hints on Google that there is
;;;    subpixel AA support in xrender, which isn't obvious from CLX or the 
;;;    spec. Failing that, we could use a 24bpp mask with component-alpha. 
;;;    That might even be how you're supposed to do it. I'm skeptical as to 
;;;    whether this would be accelerated for most people.

;;;  * Subpixel positioning. Not hard in principle - render multiple versions
;;;    of each glyph, offset by fractions of a pixel. Horizontal positioning
;;;    is more important than vertical, so 1/4 pixel horizontal resolution
;;;    and 1 pixel vertical resolution should suffice. Given how ugly most
;;;    CLIM apps are, and the lack of WYSIWYG document editors crying out 
;;;    for perfect text spacing in small fonts, we don't really need this.


(defvar *zpb-font-lock* (climi::make-lock "zpb-font"))

(defclass zpb-ttf-face (truetype-face)
  ((font-loader :reader zpb-ttf-font-loader :initarg :loader)
   (units->pixels :reader zpb-ttf-font-units->pixels :initarg :units->pixels)))

(let ((font-loader-cache (make-hash-table :test #'equal))
      (font-cache        (make-hash-table :test #'equal)))
  (defun make-truetype-face (display filename size)
    (climi::with-lock-held (*zpb-font-lock*)
      (unless display (break "no display!"))
      (let* ((loader (ensure-gethash filename font-loader-cache
                                     (zpb-ttf:open-font-loader filename)))
	     (units/em (zpb-ttf:units/em loader))
	     (pixel-size (* size (/ *dpi* 72)))
	     (units->pixels (* pixel-size (/ units/em)))           
	     (font (ensure-gethash
                    (list display loader size) font-cache
                    (make-instance 'zpb-ttf-face
                                   :display display
                                   :filename filename
                                   :size size
                                   :units->pixels units->pixels
                                   :loader loader
                                   :ascent  (* (zpb-ttf:ascender loader) units->pixels)
                                   :descent (- (* (zpb-ttf:descender loader) units->pixels))))))
	font))))

(defmethod print-object ((object zpb-ttf-face) stream)
  (print-unreadable-object (object stream :type t :identity nil)
    (with-slots (font-loader filename size ascent descent) object      
      (format stream "~W size=~A ascent=~A descent=~A" 
              (or (zpb-ttf:name-entry-value :full-name font-loader) filename)
              size ascent descent))))

(defun glyph-pixarray (font char)
  "Render a character of 'face', returning a 2D (unsigned-byte 8) array
   suitable as an alpha mask, and dimensions. This function returns five
   values: alpha mask byte array, x-origin, y-origin (subtracted from
   position before rendering), horizontal and vertical advances."
  (declare (optimize (debug 3)))
  (climi::with-lock-held (*zpb-font-lock*)
    (with-slots (font-loader units->pixels size ascent descent) font
      (let* ((glyph (zpb-ttf:find-glyph char font-loader))
             (left-side-bearing  (* units->pixels (zpb-ttf:left-side-bearing  glyph)))
             (right-side-bearing (* units->pixels (zpb-ttf:right-side-bearing glyph)))
             (advance-width (* units->pixels (zpb-ttf:advance-width glyph)))
             (bounding-box (map 'vector (lambda (x) (float (* x units->pixels)))
                                (zpb-ttf:bounding-box glyph)))
             (min-x (elt bounding-box 0))
             (min-y (elt bounding-box 1))
             (max-x (elt bounding-box 2))
             (max-y (elt bounding-box 3))<commit_msg>zpb-ttf-font: make class inherit from truetype-font<commit_after>;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-TRUETYPE; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: Glyph rendering via zpb-ttf and cl-vectors
;;;   Created: 2008-01-26 16:32
;;;    Author: <NAME> <a<EMAIL>>
;;;   License: LGPL (See file COPYING for details).
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2008 by <NAME>

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the 
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
;;; Boston, MA  02111-1307  USA.

(in-package :mcclim-truetype)

;;; TODO:
;;;  * Kerning (we didn't do this with Freetype, either. Oops.)
;;;  * Implement fixed-font-width-p for zpb-ttf.
;;;  * Boxes for missing glyphs.
;;;  * Make certain left/right bearings and text-bounding-rectangle*
;;;    are correct. (I doubt they are..)

;;; Wish-list:

;;;  * Subpixel antialiasing. It would be straightforward to generate the
;;;    glyphs by tripling the width as passed to cl-vectors and compressing
;;;    triplets of pixels together ourselves. I'm not certain how to draw
;;;    the result through xrender. I've seen hints on Google that there is
;;;    subpixel AA support in xrender, which isn't obvious from CLX or the 
;;;    spec. Failing that, we could use a 24bpp mask with component-alpha. 
;;;    That might even be how you're supposed to do it. I'm skeptical as to 
;;;    whether this would be accelerated for most people.

;;;  * Subpixel positioning. Not hard in principle - render multiple versions
;;;    of each glyph, offset by fractions of a pixel. Horizontal positioning
;;;    is more important than vertical, so 1/4 pixel horizontal resolution
;;;    and 1 pixel vertical resolution should suffice. Given how ugly most
;;;    CLIM apps are, and the lack of WYSIWYG document editors crying out 
;;;    for perfect text spacing in small fonts, we don't really need this.


(defvar *zpb-font-lock* (climi::make-lock "zpb-font"))

(defclass zpb-ttf-font (truetype-font)
  ((font-loader :reader zpb-ttf-font-loader :initarg :loader)
   (units->pixels :reader zpb-ttf-font-units->pixels :initarg :units->pixels)))

(let ((font-loader-cache (make-hash-table :test #'equal))
      (font-cache        (make-hash-table :test #'equal)))
  (defun make-truetype-face (display filename size)
    (climi::with-lock-held (*zpb-font-lock*)
      (unless display (break "no display!"))
      (let* ((loader (ensure-gethash filename font-loader-cache
                                     (zpb-ttf:open-font-loader filename)))
	     (units/em (zpb-ttf:units/em loader))
	     (pixel-size (* size (/ *dpi* 72)))
	     (units->pixels (* pixel-size (/ units/em)))           
	     (font (ensure-gethash
                    (list display loader size) font-cache
                    (make-instance 'zpb-ttf-font
                                   :display display
                                   :filename filename
                                   :size size
                                   :units->pixels units->pixels
                                   :loader loader
                                   :ascent  (* (zpb-ttf:ascender loader) units->pixels)
                                   :descent (- (* (zpb-ttf:descender loader) units->pixels))))))
	font))))

(defmethod print-object ((object zpb-ttf-font) stream)
  (print-unreadable-object (object stream :type t :identity nil)
    (with-slots (font-loader filename size ascent descent) object      
      (format stream "~W size=~A ascent=~A descent=~A" 
              (or (zpb-ttf:name-entry-value :full-name font-loader) filename)
              size ascent descent))))

(defun glyph-pixarray (font char)
  "Render a character of 'face', returning a 2D (unsigned-byte 8) array
   suitable as an alpha mask, and dimensions. This function returns five
   values: alpha mask byte array, x-origin, y-origin (subtracted from
   position before rendering), horizontal and vertical advances."
  (declare (optimize (debug 3)))
  (climi::with-lock-held (*zpb-font-lock*)
    (with-slots (font-loader units->pixels size ascent descent) font
      (let* ((glyph (zpb-ttf:find-glyph char font-loader))
             (left-side-bearing  (* units->pixels (zpb-ttf:left-side-bearing  glyph)))
             (right-side-bearing (* units->pixels (zpb-ttf:right-side-bearing glyph)))
             (advance-width (* units->pixels (zpb-ttf:advance-width glyph)))
             (bounding-box (map 'vector (lambda (x) (float (* x units->pixels)))
                                (zpb-ttf:bounding-box glyph)))
             (min-x (elt bounding-box 0))
             (min-y (elt bounding-box 1))
             (max-x (elt bounding-box 2))
             (max-y (elt bounding-box 3))
{'fraction_non_alphanumeric': 0.1448180561953017, 'fraction_numerical': 0.008291110087517274, 'mean_word_length': 2.3641152773473815, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 37, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 16, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3615730', 'n_tokens_mistral': 3284, 'n_tokens_neox': 3074, 'n_words': 1100}