Add OTF/TTF font support via freetype.

1 files changed, 356 insertions, 0 deletions

diff --git a/chickadee/freetype.scm b/chickadee/freetype.scm
new file mode 100644
index 0000000..58a1d08
--- /dev/null
+++ b/chickadee/freetype.scm
@@ -0,0 +1,356 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2020 David Thompson <davet@gnu.org>
+;;;
+;;; Chickadee is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee 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
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; FreeType 2 bindings.
+;;
+;;; Code:
+
+(define-module (chickadee freetype)
+  #:use-module (chickadee config)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (system foreign)
+  #:export (init-freetype
+            freetype-handle?
+            load-face
+            freetype-face?
+            face-num-glyphs
+            face-family-name
+            face-style-name
+            face-height
+            face-glyph-slot
+            face-size
+            get-char-index
+            get-kerning
+            set-char-size!
+            load-char
+            glyph-metrics
+            glyph-bitmap
+            glyph-bitmap-left
+            glyph-bitmap-top
+            size-metrics))
+
+
+;;;
+;;; Low-level bindings
+;;;
+
+(define %lib (dynamic-link %libfreetype))
+
+(define (freetype-func return-type function-name arg-types)
+  (pointer->procedure return-type
+                      (dynamic-func function-name %lib)
+                      arg-types))
+
+(define-syntax-rule (define-foreign name return-type func-name arg-types)
+  (define name
+    (freetype-func return-type func-name arg-types)))
+
+(define FT_LOAD_NO_SCALE                    1)
+(define FT_LOAD_NO_HINTING                  2)
+(define FT_LOAD_RENDER                      4)
+(define FT_LOAD_NO_BITMAP                   8)
+(define FT_LOAD_VERTICAL_LAYOUT             16)
+(define FT_LOAD_FORCE_AUTOHINT              32)
+(define FT_LOAD_CROP_BITMAP                 64)
+(define FT_LOAD_PEDANTIC                    128)
+(define FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH 256)
+(define FT_LOAD_NO_RECURSE                  512)
+(define FT_LOAD_IGNORE_TRANSFORM            1024)
+(define FT_LOAD_MONOCHROME                  2048)
+(define FT_LOAD_LINEAR_DESIGN               4096)
+(define FT_LOAD_NO_AUTOHINT                 8192)
+(define FT_LOAD_COLOR                       16384)
+(define FT_LOAD_COMPUTE_METRICS             32768)
+(define FT_LOAD_BITMAP_METRICS_ONLY         65536)
+
+(define-foreign ft-error-string
+  '* "FT_Error_String" (list int))
+
+(define-foreign ft-init-freetype
+  int "FT_Init_FreeType" '(*))
+
+(define ft-done-freetype (dynamic-func "FT_Done_FreeType" %lib))
+
+(define-foreign ft-new-face
+  int "FT_New_Face" (list '* '* long '*))
+
+(define ft-done-face (dynamic-func "FT_Done_Face" %lib))
+
+(define-foreign ft-set-char-size
+  int "FT_Set_Char_Size" (list '* long long unsigned-int unsigned-int))
+
+(define-foreign ft-get-char-index
+  unsigned-long "FT_Get_Char_Index" (list '* unsigned-long))
+
+(define-foreign ft-load-glyph
+  int "FT_Load_Glyph" (list '* unsigned-int int32))
+
+(define-foreign ft-render-glyph
+  int "FT_Render_Glyph" (list '* int))
+
+(define-foreign ft-load-char
+  int "FT_Load_Char" (list '* unsigned-long int32))
+
+(define-foreign ft-get-kerning
+  int "FT_Get_Kerning" (list '* unsigned-int unsigned-int unsigned-int '*))
+
+;; This is all super hacky since Guile doesn't provide a good way to index
+;; into struct pointers.
+(define ft-generic '(* *))
+(define ft-bbox (list long long long long))
+(define ft-vector (list long long))
+
+;;  https://www.freetype.org/freetype2/docs/reference/ft2-base_interface.html#ft_glyph_metrics
+(define ft-glyph-metrics
+  (list long long long long long long long long))
+
+;; https://www.freetype.org/freetype2/docs/reference/ft2-basic_types.html#ft_bitmap
+(define ft-bitmap
+  (list unsigned-int unsigned-int int '* short uint8 uint8 '*))
+
+;; https://www.freetype.org/freetype2/docs/reference/ft2-base_interface.html#ft_facerec
+(define face-num-glyphs-offset
+  (sizeof (list long long long long)))
+(define face-family-name-offset
+  (sizeof (list long long long long long)))
+(define face-style-name-offset
+  (sizeof (list long long long long long '*)))
+(define face-height-offset
+  (sizeof (list long long long long long '*
+                '* int '* int '* ft-generic
+                ft-bbox unsigned-short short short)))
+(define face-glyph-slot-offset
+  (sizeof (list long long long long long '*
+                '* int '* int '* ft-generic
+                ft-bbox unsigned-short
+                short short short short short short short)))
+(define face-size-offset
+  (sizeof (list long long long long long '*
+                '* int '* int '* ft-generic
+                ft-bbox unsigned-short
+                short short short short short short short
+                '*)))
+
+;; https://www.freetype.org/freetype2/docs/reference/ft2-base_interface.html#ft_glyphslotrec
+(define glyph-slot-metrics-offset
+  (sizeof (list '* '* '* unsigned-int '* '*)))
+(define glyph-slot-bitmap-offset
+  (+ glyph-slot-metrics-offset
+     (sizeof (list ft-glyph-metrics long long ft-vector int))))
+(define glyph-slot-bitmap-left-offset
+  (+ glyph-slot-bitmap-offset (sizeof ft-bitmap)))
+(define glyph-slot-bitmap-top-offset
+  (+ glyph-slot-bitmap-left-offset (sizeof int)))
+
+;; https://www.freetype.org/freetype2/docs/reference/ft2-base_interface.html#ft_sizerec
+(define size-metrics-offset
+  (sizeof (list '* ft-generic)))
+(define ft-size-metrics
+  (list unsigned-short unsigned-short long long long long long long))
+
+
+;;;
+;;; High-level wrappers
+;;;
+
+(define (make-pointer-pointer)
+  (make-bytevector (sizeof uintptr_t)))
+
+(define (bytevector-pointer-ref bv finalizer)
+  (make-pointer (bytevector-uint-ref bv 0 (native-endianness) (sizeof uintptr_t))
+                finalizer))
+
+(define (extract-pointer pointer offset)
+  (dereference-pointer (make-pointer (+ (pointer-address pointer) offset))))
+
+(define (extract-string pointer offset)
+  (pointer->string (extract-pointer pointer offset)))
+
+(define (check-error error message)
+  (unless (zero? error)
+    (error message (pointer->string (ft-error-string error)))))
+
+(define-wrapped-pointer-type <freetype-handle>
+  freetype-handle?
+  wrap-freetype-handle unwrap-freetype-handle
+  (lambda (handle port)
+    (display "#<freetype-handle>" port)))
+
+(define (init-freetype)
+  (let ((bv (make-pointer-pointer)))
+    (check-error (ft-init-freetype (bytevector->pointer bv))
+                 "failed to initialize freetype library")
+    (wrap-freetype-handle (bytevector-pointer-ref bv ft-done-freetype))))
+
+(define-wrapped-pointer-type <freetype-face>
+  freetype-face?
+  wrap-freetype-face unwrap-freetype-face
+  (lambda (face port)
+    (display "#<freetype-face>" port)))
+
+(define* (load-face handle file-name #:optional (face-index 0))
+  (let ((bv (make-pointer-pointer)))
+    (check-error (ft-new-face (unwrap-freetype-handle handle)
+                              (string->pointer file-name)
+                              face-index
+                              (bytevector->pointer bv))
+                 "failed to load face")
+    (wrap-freetype-face (bytevector-pointer-ref bv ft-done-face))))
+
+(define (set-char-size! face width height horizontal-dpi vertical-dpi)
+  (check-error (ft-set-char-size (unwrap-freetype-face face)
+                                 width
+                                 height
+                                 horizontal-dpi
+                                 vertical-dpi)
+               "failed to set face char size"))
+
+(define (get-char-index face char)
+  (ft-get-char-index (unwrap-freetype-face face)
+                     (char->integer char)))
+
+(define (get-kerning face left-index right-index )
+  (let ((bv (make-s64vector 2)))
+    (check-error (ft-get-kerning (unwrap-freetype-face face)
+                                 left-index
+                                 right-index
+                                 0
+                                 (bytevector->pointer bv))
+                 "failed to get kerning")
+    bv))
+
+(define (load-flags->bitmask flags)
+  (fold (lambda (flag prev)
+          (logior prev
+                  (match flag
+                    ('no-scale FT_LOAD_NO_SCALE)
+                    ('no-hinting FT_LOAD_NO_HINTING)
+                    ('render FT_LOAD_RENDER)
+                    ('no-bitmap FT_LOAD_NO_BITMAP)
+                    ('vertical-layout FT_LOAD_VERTICAL_LAYOUT)
+                    ('force-auto-hint FT_LOAD_FORCE_AUTOHINT)
+                    ('crop-bitmap FT_LOAD_CROP_BITMAP)
+                    ('pedantic FT_LOAD_PEDANTIC)
+                    ('ignore-global-advance-width FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH)
+                    ('no-recurse FT_LOAD_NO_RECURSE)
+                    ('ignore-transform FT_LOAD_IGNORE_TRANSFORM)
+                    ('load-monochrome FT_LOAD_MONOCHROME)
+                    ('linear-design FT_LOAD_LINEAR_DESIGN)
+                    ('no-auto-hint FT_LOAD_NO_AUTOHINT)
+                    ('load-color FT_LOAD_COLOR)
+                    ('compute-metrics FT_LOAD_COMPUTE_METRICS)
+                    ('bitmap-metrics-only FT_LOAD_BITMAP_METRICS_ONLY))))
+        0
+        flags))
+
+(define* (load-glyph face index #:optional (flags '()))
+  (check-error (ft-load-glyph (unwrap-freetype-face face)
+                              index
+                              (load-flags->bitmask flags))
+               "failed to load glyph"))
+
+(define* (load-char face char #:optional (flags '()))
+  (check-error (ft-load-char (unwrap-freetype-face face)
+                             (char->integer char)
+                             (load-flags->bitmask flags))
+               "failed to load char"))
+
+(define (face-num-glyphs face)
+  (s64vector-ref (pointer->bytevector (unwrap-freetype-face face)
+                                      1 face-num-glyphs-offset 's64)
+                 0))
+
+(define (face-family-name face)
+  (extract-string (unwrap-freetype-face face) face-family-name-offset))
+
+(define (face-style-name face)
+  (extract-string (unwrap-freetype-face face) face-style-name-offset))
+
+(define (face-height face)
+  (s64vector-ref (pointer->bytevector (unwrap-freetype-face face)
+                                      1
+                                      face-height-offset
+                                      's64)
+                 0))
+
+(define-wrapped-pointer-type <freetype-glyph-slot>
+  freetype-glyph-slot?
+  wrap-freetype-glyph-slot unwrap-freetype-glyph-slot
+  (lambda (glyph-slot port)
+    (display "#<freetype-glyph-slot>" port)))
+
+(define (face-glyph-slot face)
+  (wrap-freetype-glyph-slot
+   (extract-pointer (unwrap-freetype-face face) face-glyph-slot-offset)))
+
+(define-wrapped-pointer-type <freetype-size>
+  freetype-size?
+  wrap-freetype-size unwrap-freetype-size
+  (lambda (size port)
+    (display "#<freetype-size>" port)))
+
+(define (face-size face)
+  (wrap-freetype-size
+   (extract-pointer (unwrap-freetype-face face) face-size-offset)))
+
+(define (size-metrics size)
+  (parse-c-struct (make-pointer (+ (pointer-address
+                                    (unwrap-freetype-size size))
+                                   size-metrics-offset))
+                  ft-size-metrics))
+
+(define (glyph-metrics glyph-slot)
+  (match (parse-c-struct (make-pointer (+ (pointer-address
+                                           (unwrap-freetype-glyph-slot glyph-slot))
+                                          glyph-slot-metrics-offset))
+                         ft-glyph-metrics)
+    ;; Ignoring vertical layout for now.
+    ((_ _ bearing-x bearing-y advance _ _ _)
+     (list (/ bearing-x 64) (/ bearing-y 64) (/ advance 64)))))
+
+(define (glyph-bitmap glyph-slot)
+  (match (parse-c-struct (make-pointer (+ (pointer-address
+                                           (unwrap-freetype-glyph-slot glyph-slot))
+                                          glyph-slot-bitmap-offset))
+                         ft-bitmap)
+    ((height width pitch buffer num-grays pixel-mode _ _)
+     (list width height pitch
+           (and (not (zero? (pointer-address buffer)))
+                (pointer->bytevector buffer (* height pitch)))))))
+
+(define (glyph-bitmap-left glyph-slot)
+  (bytevector-sint-ref (pointer->bytevector (unwrap-freetype-glyph-slot glyph-slot)
+                                            (sizeof int)
+                                            glyph-slot-bitmap-left-offset)
+                       0
+                       (native-endianness)
+                       (sizeof int)))
+
+
+(define (glyph-bitmap-top glyph-slot)
+  (bytevector-sint-ref (pointer->bytevector (unwrap-freetype-glyph-slot glyph-slot)
+                                            (sizeof int)
+                                            glyph-slot-bitmap-top-offset)
+                       0
+                       (native-endianness)
+                       (sizeof int)))