path: root/chickadee/freetype.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; 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)

;; FT_Error_String only exists in libfreetype 2.10.0+, and we wish to
;; support older versions so we stub out the function when it doesn't
;; exist.
(define ft-error-string
  (or (false-if-exception (freetype-func '* "FT_Error_String" (list int)))
      (lambda (error-code)
        (string->pointer
         (string-append "error code " (number->string error-code))))))

(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)))