;;; Chickadee Game Toolkit ;;; Copyright © 2020 David Thompson ;;; ;;; 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? wrap-freetype-handle unwrap-freetype-handle (lambda (handle port) (display "#" 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? wrap-freetype-face unwrap-freetype-face (lambda (face port) (display "#" 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? wrap-freetype-glyph-slot unwrap-freetype-glyph-slot (lambda (glyph-slot port) (display "#" 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? wrap-freetype-size unwrap-freetype-size (lambda (size port) (display "#" 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)))