typesetting/pitfall/fontkit/freetype-ffi.rkt

#lang racket/base
(require ffi/unsafe
         ffi/unsafe/define
         racket/draw/private/libs)

(define-syntax-rule (define+provide id val)
  (begin
    (define id val)
    (provide id)))

(define-runtime-lib freetype-lib
  [(unix) (ffi-lib "libfontconfig" '("1" ""))]
  [(macosx) (ffi-lib "libfreetype.6.dylib")]
  [(windows) (ffi-lib "libfreetype-6.dll")])

(define-ffi-definer define-freetype freetype-lib #:provide provide)

;; types
(define _void-pointer (_cpointer 'void-pointer))
(define _char _byte)
(define _char-pointer (_cpointer 'char-pointer))
(define _uchar _ubyte)
(define _FT_Byte _ubyte)
(define _FT_Bytes _bytes)
(define _FT_Char _char)
(define _FT_Int _int)
(define _FT_UInt _uint)
(define _FT_Int16 _short)
(define _FT_UInt16 _ushort)
(define _FT_Int32 _int32)
(define _FT_UInt32 _uint32)
(define _FT_Short _short)
(define _FT_UShort _ushort)
(define _FT_Long _long)
(define _FT_ULong _ulong)
(define _FT_Bool _byte)
(define _FT_Offset _size) ;; equivalent to _size_t?
(define _FT_PtrDist _ptrdiff) ;; equivalent to _longlong?
(define _FT_String _char) 
(define _FT_String-pointer (_cpointer 'FT_String-pointer)) ;; char*
(define _FT_Tag _FT_UInt32)
(define _FT_Error _int)
(define _FT_Fixed _long) 
(define _FT_Pointer _void-pointer)
(define _FT_Pos _long)
(define _FT_FWord _short)
(define _FT_UFWord _ushort)
(define _FT_F26Dot16 _short)
(define _FT_F26Dot6 _long)
(define _FT_Glyph_Format _int)
(define _FT_Encoding _int)
(define _FT_Generic_Finalizer (_cpointer '_FT_Generic_Finalizer (_fun _void-pointer -> _void)))

(define _FT_LibraryRec (_cpointer 'FT_LibraryRec))
(define _FT_Library (_cpointer 'FT_Library))

(define-cstruct _FT_Bitmap_Size
  ([height _FT_Short]
   [width _FT_Short]
   [size _FT_Pos]
   [x_ppem _FT_Pos]
   [y_ppem _FT_Pos]))

(define-cstruct _FT_CharMapRec
  ([face _void-pointer] ; should be FT_Face
   [encoding _FT_Encoding]
   [platform_id _FT_UShort]
   [encoding_id _FT_UShort]))

(define _FT_Charmap _FT_CharMapRec-pointer)
(define _FT_CharMap-pointer (_cpointer 'FT_CharMap-pointer))

(define-cstruct _FT_Generic
  ([data _void-pointer]
   [finalizer _FT_Generic_Finalizer]))

(define-cstruct _FT_BBox
  ([xMin _FT_Pos]
   [yMin _FT_Pos]
   [xMax _FT_Pos]
   [yMax _FT_Pos]))
(provide (struct-out FT_BBox)
         _FT_BBox _FT_BBox-pointer)

(define-cstruct _FT_Glyph_Metrics
  ([width _FT_Pos]
   [height _FT_Pos]
   [horiBearingX _FT_Pos]
   [horiBearingY _FT_Pos]
   [horiAdvance _FT_Pos]
   [vertBearingX _FT_Pos]
   [vertBearingY _FT_Pos]
   [vertAdvance _FT_Pos]))
(provide (struct-out FT_Glyph_Metrics)
         _FT_Glyph_Metrics _FT_Glyph_Metrics-pointer)

(define-cstruct _FT_Vector
  ([x _FT_Pos]
   [y _FT_Pos]))

(provide (struct-out FT_Vector)
         _FT_Vector _FT_Vector-pointer)

(define-cstruct _FT_Bitmap
  ([rows _int]
   [width _int]
   [pitch _int]
   [buffer (_cpointer 'buffer)]
   [num_grays _short]
   [pixel_mode _ubyte]
   [palette_mode _char]
   [palette _void-pointer]))

(define-cstruct _FT_Outline
  ([n_contours _short]
   [n_points _short]
   [points _FT_Vector-pointer]
   [tags (_cpointer 'tags)]
   [contours (_cpointer 'contours)]
   [flags _int]))

(define-cstruct _FT_GlyphSlotRec
  ([library           _FT_Library]
   [face              _void-pointer]
   [next              _void-pointer]
   [reserved          _uint]
   [generic           _FT_Generic]
   [metrics           _FT_Glyph_Metrics]
   [linearHoriAdvance _FT_Fixed]
   [linearVertAdvance _FT_Fixed]
   [advance           _FT_Vector]
   [format            _FT_Glyph_Format]
   [bitmap            _FT_Bitmap]
   [bitmap_left       _FT_Int]
   [bitmap_top        _FT_Int]
   [outline           _FT_Outline]
   [num_subglyphs     _FT_UInt]
   [subglyphs         _void-pointer]
   [control_data      _void-pointer]
   [control_len       _long]
   [lsb_delta         _FT_Pos]
   [rsb_delta         _FT_Pos]
   [other             _void-pointer]
   [internal          _void-pointer]))

(define _FT_GlyphSlot _FT_GlyphSlotRec-pointer)

(provide (struct-out FT_GlyphSlotRec)
         _FT_GlyphSlotRec _FT_GlyphSlotRec-pointer)

(define-cstruct _FT_Size_Metrics
  ([x_ppem _FT_UShort]
   [y_ppem _FT_UShort]
   [x_scale _FT_Fixed]
   [y_scale _FT_Fixed]
   [ascender _FT_Pos]
   [descender _FT_Pos]
   [height _FT_Pos]
   [max_advance _FT_Pos]))

(define-cstruct _FT_SizeRec
  ([face _void-pointer]
   [generic _FT_Generic]
   [metrics _FT_Size_Metrics]
   [internal _void-pointer]))

(define _FT_Size _FT_SizeRec-pointer)

(define-cstruct _FT_FaceRec
  ([num_faces _FT_Long]
   [face_index _FT_Long]
   [face_flag _FT_Long]
   [style_flags _FT_Long]
   [num_glyphs _FT_Long]
   [family_name _string] ; probably _string is a better choice
   [style_name _string]
   [num_fixed_sizes _FT_Int]
   [available_sizes _FT_Bitmap_Size-pointer]
   [num_charmaps _FT_Int]
   [charmaps _FT_CharMap-pointer]
   [generic _FT_Generic]
   [bbox _FT_BBox]
   [units_per_EM _FT_UShort]
   [ascender _FT_Short]
   [descender _FT_Short]
   [height _FT_Short]
   [max_advance_width _FT_Short]
   [max_advance_height _FT_Short]
   [underline_position _FT_Short]
   [underline_thickness _FT_Short]
   [glyph _FT_GlyphSlot]
   [size _FT_Size]
   [charmap _FT_Charmap]
   [driver _void-pointer]
   [memory _void-pointer]
   [stream _void-pointer]
   [sizes_list_head _void-pointer]
   [sizes_list_tail _void-pointer]
   [autohint _FT_Generic]
   [extensions _void-pointer]
   [internal _void-pointer]))

(define _FT_Face _FT_FaceRec-pointer)
(provide (struct-out FT_FaceRec)
         _FT_FaceRec _FT_FaceRec-pointer)

(define _FT_Sfnt_Tag _FT_ULong)

(define-cstruct _FT_HoriHeader
  ([version _FT_Long]
   [ascent _FT_Short]
   [descent _FT_Short]
   [lineGap _FT_Short]))
(provide (struct-out FT_HoriHeader)
         _FT_HoriHeader _FT_HoriHeader-pointer)

(define-cstruct _FT_TT_Postscript
  ([FormatType _FT_Fixed]
   [italicAngle _FT_Fixed]
   [underlinePosition _FT_Short]
   [underlineThickness _FT_Short]
   [isFixedPitch _FT_ULong]
   [minMemType42 _FT_ULong]
   [maxMemType42 _FT_ULong]
   [minMemType1 _FT_ULong]
   [maxMemType1 _FT_ULong]))
(provide (struct-out FT_TT_Postscript)
         _FT_TT_Postscript _FT_TT_Postscript-pointer)

(define-cstruct _FT_panose
  ([a _FT_Byte]
   [b _FT_Byte]
   [c _FT_Byte]
   [d _FT_Byte]
   [e _FT_Byte]
   [f _FT_Byte]
   [g _FT_Byte]
   [h _FT_Byte]
   [i _FT_Byte]
   [j _FT_Byte]))

(define-cstruct _FT_VendID
               ([a _FT_Char]
                [b _FT_Char]
                [c _FT_Char]
                [d _FT_Char]))

(define-cstruct _FT_TT_OS2
  ([version _FT_UShort]
   [xAvgCharWidth _FT_Short]
   [usWeightClass _FT_UShort]
   [usWidthClass _FT_UShort]
   [fsType _FT_Short] 
   [ySubscriptXSize _FT_Short]
   [ySubscriptYSize _FT_Short]
   [ySubscriptXOffset _FT_Short]
   [ySubscriptYOffset _FT_Short]
   [ySuperscriptXSize _FT_Short]
   [ySuperscriptYSize _FT_Short]
   [ySuperscriptXOffset _FT_Short]
   [ySuperscriptYOffset _FT_Short]
   [yStrikeoutSize _FT_Short]
   [yStrikeoutPosition _FT_Short]
   [sFamilyClass _FT_Short]
   [panose _FT_panose]
   [ulUnicodeRange1 _FT_ULong]
   [ulUnicodeRange2 _FT_ULong]
   [ulUnicodeRange3 _FT_ULong]
   [ulUnicodeRange4 _FT_ULong]
   [achVendID _FT_VendID]
   [fsSelection _FT_UShort]
   [usFirstCharIndex _FT_UShort]
   [usLastCharIndex _FT_UShort]
   [sTypoAscender _FT_Short]
   [sTypoDescender _FT_Short]
   [sTypoLineGap _FT_Short]
   [usWinAscent _FT_UShort]
   [usWinDescent _FT_UShort]
   [ulCodePageRange1 _FT_ULong]
   [ulCodePageRange2 _FT_ULong]
   [sxHeight _FT_Short]
   [sCapHeight _FT_Short]
   [usDefaultChar _FT_UShort]
   [usBreakChar _FT_UShort]
   [usMaxContext _FT_UShort]
   [usLowerOpticalPointSize _FT_UShort]
   [usUpperOpticalPointSize _FT_UShort]))
(provide (struct-out FT_TT_OS2)
         _FT_TT_OS2 _FT_TT_OS2-pointer)

(define _full-path
  (make-ctype _path
              path->complete-path
              values))

(define-freetype FT_Init_FreeType (_fun (ftl : (_ptr o _FT_Library))
                                        -> (err : _FT_Error) 
                                        -> (if (zero? err) ftl (error 'FT_Init_FreeType))))

(define-freetype FT_New_Face (_fun _FT_Library _full-path _FT_Long 
                                   (ftf : (_ptr o (_or-null _FT_Face)))
                                   -> (err : _FT_Error)
                                   -> (if (zero? err) ftf (error 'FT_New_Face (format "error ~a" err)))))

(define-freetype FT_Done_Face (_fun _FT_Face
                                    -> (err : _FT_Error)
                                    -> (unless (zero? err) (error 'FT_Done_Face (format "error ~a" err)))))

(define-freetype FT_Done_FreeType (_fun _FT_Library -> (err : _FT_Error) -> (if (zero? err) (void) (error 'FT_Done_FreeType))))

(define-freetype FT_Get_Kerning (_fun _FT_Face _FT_UInt _FT_UInt _FT_UInt
                                      (ftv : (_ptr o _FT_Vector))
                                      -> (err : _FT_Error)
                                      -> (if (zero? err) ftv (error 'FT_Get_Kerning (format "error ~a" err)))))

(define-freetype FT_Get_Char_Index (_fun _FT_Face _FT_ULong
                                         -> _FT_UInt))

(define-freetype FT_Load_Glyph (_fun _FT_Face _FT_UInt _FT_Int32
                                     -> (err : _FT_Error)
                                     -> (unless (zero? err)
                                          (error 'FT_Load_Glyph "failed, try using FT_LOAD_NO_RECURSE flag instead"))))

(define-freetype FT_Load_Char (_fun _FT_Face _FT_ULong _FT_Int32
                                    -> (err : _FT_Error)))

(define+provide FT_KERNING_UNSCALED 2)
(define+provide FT_LOAD_DEFAULT 0)
(define+provide FT_LOAD_RENDER (expt 2 2))
(define+provide FT_LOAD_LINEAR_DESIGN (expt 2 13))
(define+provide FT_LOAD_NO_RECURSE (expt 2 10))



(define-freetype FT_Get_Postscript_Name (_fun _FT_Face -> _string))

(define-freetype FT_Load_Sfnt_Table (_fun _FT_Face _FT_Sfnt_Tag _FT_Long
                                          (buffer : (_ptr io _FT_Byte))
                                          (len : (_ptr io _FT_ULong))
                                          -> (err : _FT_Error)
                                          -> (and (zero? err) #t)))


(define+provide _FT_Gettable_Sfnt_Tag (_enum '(ft_sfnt_head = 0
                                                            ft_sfnt_maxp
                                                            ft_sfnt_os2
                                                            ft_sfnt_hhea
                                                            ft_sfnt_vhea
                                                            ft_sfnt_post
                                                            ft_sfnt_pclt)))

(define-freetype FT_Get_Sfnt_Table (_fun _FT_Face _FT_Gettable_Sfnt_Tag
                                         -> (p : (_cpointer/null 'table-ptr))
                                         -> (or p (error 'sfnt-table-not-loaded))))

(define-freetype FT_Select_Charmap (_fun _FT_Face _FT_Encoding
                                          -> (err : _FT_Error)
                                          -> (and (zero? err) #t)))

(provide tag->int)
(define (tag->int tag)
  (define signed? #f)
  (define big-endian? #t)
  (integer-bytes->integer tag signed? big-endian?))

(module+ test
  (require rackunit)
  (define ft-library (FT_Init_FreeType))
  (define face (FT_New_Face ft-library "../pitfall/test/assets/charter.ttf" 0))
  (check-equal? (FT_Get_Postscript_Name face) "Charter")
  (check-equal? (FT_FaceRec-units_per_EM face) 1000)
  (check-true (FT_Load_Sfnt_Table face (tag->int #"cmap") 0 0 0))
  (check-false (FT_Load_Sfnt_Table face (tag->int #"zzap") 0 0 0))
  (check-true (cpointer? (FT_Get_Sfnt_Table face 'ft_sfnt_hhea)))
  (define charter-hhea-table (cast (FT_Get_Sfnt_Table face 'ft_sfnt_hhea) _pointer _FT_HoriHeader-pointer))
  (check-equal? (FT_HoriHeader-ascent charter-hhea-table) 980)
  (check-equal? (FT_HoriHeader-descent charter-hhea-table) -238)
  (check-equal? (FT_HoriHeader-lineGap charter-hhea-table) 0)
  (check-equal?
   (let ([bbox (FT_FaceRec-bbox face)])
     (list (FT_BBox-xMin bbox)
           (FT_BBox-yMin bbox)
           (FT_BBox-xMax bbox)
           (FT_BBox-yMax bbox))) '(-161 -236 1193 963))

  (define H-gid 41)
  (FT_Load_Glyph face H-gid FT_LOAD_NO_RECURSE)
  ; want bearingX (lsb) and advanceX (advance width)
  (define g (FT_FaceRec-glyph face))
  (define metrics (FT_GlyphSlotRec-metrics g))
  (define bearingX (FT_Glyph_Metrics-horiBearingX metrics))
  (check-equal? bearingX 33)
  (define advanceX (FT_Glyph_Metrics-horiAdvance metrics))
  (check-equal? advanceX 738)

  (define charter-post-table (cast (FT_Get_Sfnt_Table face 'ft_sfnt_post) _pointer _FT_TT_Postscript-pointer))
  (check-equal? (FT_TT_Postscript-italicAngle charter-post-table) 0)
  (check-equal? (FT_TT_Postscript-underlinePosition charter-post-table) -178) ; -207 + 1/2 of thickness = -207 + 29
  (check-equal? (FT_TT_Postscript-underlineThickness charter-post-table) 58)

  (define os2-table (cast (FT_Get_Sfnt_Table face 'ft_sfnt_os2) _pointer _FT_TT_OS2-pointer))
  (check-equal? (FT_TT_OS2-fsType os2-table) #b1000)
  (check-equal? (FT_TT_OS2-yStrikeoutSize os2-table) 61)
  (check-equal? (FT_TT_OS2-yStrikeoutPosition os2-table) 240)

  (check-equal? (FT_panose->list (FT_TT_OS2-panose os2-table)) '(2 0 5 3 6 0 0 2 0 4))

  (check-equal? (FT_TT_OS2-sTypoAscender os2-table) 762)
  (check-equal? (FT_TT_OS2-sTypoDescender os2-table) -238)
  (check-equal? (FT_TT_OS2-sCapHeight os2-table) 671)
  (check-equal? (FT_TT_OS2-sxHeight os2-table) 481)

  (FT_Done_Face face)
  )