Patch title: Release 90 bulk changes
Abstract:
File: /graphic/vector/freetype.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
module "/pliant/admin/file.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/vector.pli"
module "/pliant/admin/file.pli"
module "font.pli"

constant libfreetype "libfreetype.so.6"
constant direct true


function FT_Init_FreeType library -> error
  arg_rw Address library ; arg Int error
  external libfreetype "FT_Init_FreeType"

function FT_Done_FreeType library -> error
  arg Address library ; arg Int error
  external libfreetype "FT_Done_FreeType"

function FT_New_Face library path index face -> error
  arg Address library ; arg CStr path ; arg Int index ; arg_rw Address face ; arg Int error
  external libfreetype "FT_New_Face"

function FT_Select_Charmap face encoding -> error
  arg Address face ; arg Int encoding ; arg Int error
  external libfreetype "FT_Select_Charmap"

function FT_Get_Char_Index face code -> index
  arg Address face ; arg uInt code index
  external libfreetype "FT_Get_Char_Index"

function FT_Has_PS_Glyph_Names face -> c
  arg Address face ; arg CBool c
  external libfreetype "FT_Has_PS_Glyph_Names"

function FT_Get_Glyph_Name face index buffer buffer_max -> error
  arg Address face ; arg uInt index ; arg Address buffer ; arg uInt buffer_max ; arg Int error
  external libfreetype "FT_Get_Glyph_Name"

function FT_Load_Glyph face index flags -> error
  arg Address face ; arg uInt index ; arg Int flags ; arg Int error
  external libfreetype "FT_Load_Glyph"

constant FT_LOAD_DEFAULT 0
constant FT_LOAD_NO_SCALE 1

type FT_BBox
  field Int xMin yMin xMax yMax

type FT_Generic
  field Address data fun

type FT_FaceRec
  field Int num_faces face_index
  field Int face_flags style_flags
  field Int num_glyphs
  field Address family_name style_name
  field Int num_fixed_sizes ; field Address available_sizes
  field Int num_charmaps ; field Address charmaps
  field FT_Generic generic
  field FT_BBox bbox
  field uInt16 units_per_EM ; field Int16 ascender descender height
  field Int16 max_advance_width max_advance_height
  field Int16 underline_position underline_thickness
  field Address glyph size charmap

function FT_Get_Glyph slot glyph -> error
  arg Address slot ; arg_rw Address glyph ; arg Int error
  external libfreetype "FT_Get_Glyph"

type FT_Vector
  field Int x y

type FT_GlyphRec
  field Address library calssz
  field Int format
  field FT_Vector advance

type FT_Outline
  field Int16 n_contours n_points
  field Address points tags contours
  field Int flags

type FT_OutlineGlyphRec
  field FT_GlyphRec root
  field FT_Outline outline

constant FT_CURVE_TAG_ON 1
constant FT_CURVE_TAG_CONIC 0
constant FT_CURVE_TAG_CUBIC 2

type FT_Outline_Funcs
  field Address move_to line_to conic_to cubic_to
  field Int shift delta

function FT_Outline_Decompose outline funcs user -> error
  arg FT_Outline outline ; arg FT_Outline_Funcs funcs ; arg Address user ; arg Int error
  external libfreetype "FT_Outline_Decompose"
  
type FT_CharMapRec
  field Address face
  field uInt encoding
  field uInt16 plateform_id encoding_id


if not direct

  constant unit 1000

  function move_to v a
    arg  FT_Vector v ; arg_rw Array:Curve a
    external_calling_convention
    # console "moveto " v:x " " v:y eol
    if a:size>0
      (a a:size-1) compute outline+bezier
    a size += 1
    (a a:size-1) angle v:x/unit -(v:y/unit)
  
  function line_to v a
    arg  FT_Vector v ; arg_rw Array:Curve a
    external_calling_convention
    # console "lineto " v:x " " v:y eol
    (a a:size-1) angle v:x/unit -(v:y/unit)
  
  function conic_to c v a
    arg  FT_Vector c v ; arg_rw Array:Curve a
    external_calling_convention
    # console "conicto " v:x " " v:y eol
    var Pointer:Curve cu :> a a:size-1
    var Pointer:CurvePoint l :> cu point cu:size-1
    l out c:x/unit-l:x -(c:y/unit)-l:y
    cu angle v:x/unit -(v:y/unit)
    var Pointer:CurvePoint l :> cu point cu:size-1
    l in c:x/unit-l:x -(c:y/unit)-l:y
  
  function cubic_to c1 c2 v a
    arg  FT_Vector c1 c2 v ; arg_rw Array:Curve a
    external_calling_convention
    # console "cubicto " v:x " " v:y eol
    var Pointer:Curve cu :> a a:size-1
    var Pointer:CurvePoint l :> cu point cu:size-1
    l out c1:x/unit-l:x -(c1:y/unit)-l:y
    cu angle v:x/unit -(v:y/unit)
    var Pointer:CurvePoint l :> cu point cu:size-1
    l in c2:x/unit-l:x -(c2:y/unit)-l:y

constant unicode_encoding 756E6963h
constant adobe_custom_encoding 41444243h
constant apple_roman_encoding 61726D6Eh
constant FT_FACE_FLAG_GLYPH_NAMES 2^9

method f load_freetype filename options -> status
  arg_rw Font f ; arg Str filename options ; arg ExtendedStatus status
  var Address library
  if (FT_Init_FreeType (var Address library))<>0
    return failure:"failed to init freetype library"
  if (FT_New_Face library file_os_name:filename (options option "face" Int 0) (var Address face))<>0
    return failure:"failed to load font"
  var Pointer:FT_FaceRec facerec :> face map FT_FaceRec
  var Int unit := facerec units_per_EM
  var CBool gn := FT_Has_PS_Glyph_Names face
  for (var Int index) 0 facerec:num_glyphs-1
    part record_glyph
      var Pointer:Int unicode :> null map Int
      if gn
        var Str glyph_name := repeat 256 " "
        if (FT_Get_Glyph_Name face (cast index uInt) glyph_name:characters (cast glyph_name:len uInt))=0
          glyph_name := glyph_name 0 (glyph_name search "[0]" glyph_name:len)
          unicode :> postscript_glyphs first glyph_name
      if not exists:unicode
        if facerec:num_charmaps>=1
          var uInt encoding := (facerec:charmaps map Pointer:FT_CharMapRec) encoding
          if encoding=unicode_encoding and facerec:num_charmaps>=2
            encoding := (facerec:charmaps map Pointer:FT_CharMapRec 1) encoding
          if (FT_Select_Charmap face encoding)=0
            for (var Int char) 0 255
              if (FT_Get_Char_Index face (cast char uInt))=index
                unicode :> f:encoding char
      if not exists:unicode
        # console "Failed to discover Unicode value for glyph " index eol
        leave record_glyph
      if (FT_Load_Glyph face (cast index uInt) FT_LOAD_NO_SCALE)<>0
        # console "Failed to load glyph " index eol
        leave record_glyph
      if (FT_Get_Glyph facerec:glyph (var Address glyph))<>0
        # console "Failed to get glyph" eol
        leave record_glyph
      var Pointer:FT_OutlineGlyphRec r :> glyph map FT_OutlineGlyphRec
      (var Array:Curve curves) size := 0
      if direct
        curves size := r:outline n_contours
        var Pointer:FT_Outline o :> r:outline
        # console (cast o:n_contours Int) " contours " (cast o:n_points Int) " points" eol
        for (var Int i) 0 curves:size-1
          var Pointer:Curve c :> curves i
          var Int j0
          if i=0
            j0 := 0
          else
            j0 := (o:contours map Int16 i-1)+1
          var Int j1:= (o:contours map Int16 i)+1
          # console "contout " i " " j0 " " j1 ":"
          for (var Int j) j0 j1
            var Pointer:FT_Vector v0 :> o:points map FT_Vector j
            var Int t0 := o:tags map uInt8 j
            # console "   " (character 65+(t0 .and. 3)) " " v0:x " " v0:y
          var Int j := j0
          while j<j1
            var Pointer:FT_Vector v0 :> o:points map FT_Vector j
            var Int t0 := o:tags map uInt8 j
            if (t0 .and. FT_CURVE_TAG_ON)<>0
              c angle v0:x/unit -(v0:y/unit)
              j += 1
            else
              var Pointer:CurvePoint l :> c point c:size-1
              var Pointer:FT_Vector v1 :> o:points map FT_Vector (j+1-j0)%(j1-j0)+j0
              var Int t1 := o:tags map uInt8 (j+1-j0)%(j1-j0)+j0
              if (t1 .and. FT_CURVE_TAG_ON)<>0
                l out v0:x/unit-l:x -(v0:y/unit)-l:y
                c angle v1:x/unit -(v1:y/unit)
                var Pointer:CurvePoint l :> c point c:size-1
                l in v0:x/unit-v1:x/unit -(v0:y/unit)-(-(v1:y/unit))
                j += 2
              else
                var Pointer:FT_Vector v2 :> o:points map FT_Vector (j+2-j0)%(j1-j0)+j0
                var Int t2 := o:tags map uInt8 (j+2-j0)%(j1-j0)+j0
                l out v0:x/unit-l:x (-v0:y/unit)-l:y
                c angle v2:x/unit -(v2:y/unit)
                var Pointer:CurvePoint l :> c point c:size-1
                l in v1:x/unit-l:x -(v1:y/unit)-l:y
                j += 3
          # console eol
          c compute outline+bezier
      else
        var FT_Outline_Funcs funcs
        funcs move_to := (the_function move_to FT_Vector Array:Curve) executable
        funcs line_to := (the_function line_to FT_Vector Array:Curve) executable
        funcs conic_to := (the_function conic_to FT_Vector FT_Vector Array:Curve) executable
        funcs cubic_to := (the_function cubic_to FT_Vector FT_Vector FT_Vector Array:Curve) executable
        funcs shift := 0
        funcs delta := 0
        if r:outline:n_contours>0
          if (FT_Outline_Decompose r:outline funcs addressof:curves)<>0
            # console "failed to decompose" eol
            leave record_glyph
        if curves:size>0
          (curves curves:size-1) compute outline+bezier
      var FontChar fchar ; fchar curves := curves
      fchar vector := vector r:root:advance:x/unit/2^10 -(r:root:advance:y/unit/2^10)
      f:chars insert unicode fchar
      # console "."
  if (FT_Done_FreeType library)<>0
    return failure:"failed to close freetype library"
  status := success

function font_freetype filename options -> f
  arg Str filename options ; arg Link:Font f
  f :> new Font
  if (f load_freetype filename options)=failure
    f :> null map Font

export '. load_freetype' font_freetype


if false

  module "/pliant/graphic/color/gamut.pli"
  module "/pliant/graphic/image/prototype.pli"
  module "/pliant/graphic/image/packed.pli"
  module "/pliant/graphic/draw/prototype.pli"
  module "/pliant/graphic/draw/image.pli"
  module "/pliant/graphic/filter/io.pli"

  function test filename
    arg Str filename
    var Link:ImagePacked packed :> new ImagePacked
    packed setup (image_prototype 0 -1 4 1 4*128 2*128 color_gamut:"rgb") ""
    var Link:DrawImage draw :> new DrawImage
    draw image :> packed
    var Link:Font f :> font "Helvetica"
    var Int grey := 808080h
    draw text "H鬨ne" f null undefined (transform 0.000001 0 1 1 0 0) addressof:grey
    var Link:Font f :> font_freetype filename ""
    var Int red := 255
    draw text "H鬨ne" f null undefined (transform 0.000001 0 1 1 0 0) addressof:red
    packed save "file:/tmp/font.png" ""

  # test "embedded:/usr/share/fonts/type1/gsfonts/n019003l.pfb"
  test "file:/tmp/font.cff"