Patch title: Release 94 bulk changes
Abstract:
File: /pliant/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/graphic/misc/float.pli"
module "/pliant/admin/file.pli"
module "font.pli"

constant libfreetype "libfreetype.so.6"
constant direct true
constant multithread false
constant debug_encoding false
constant debug_glyph false
constant debug_trouble false
constant use_conic false


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 do_load_freetype library filename options -> status
  arg_rw Font f ; arg Address library ; arg Str filename options ; arg ExtendedStatus status
  part new_face "FT_New_Face"
    var Int err := FT_New_Face library file_os_name:filename (options option "face" Int 0) (var Address face)
  if err<>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
  for (var Int index) 1 facerec:num_glyphs-1
    part record_glyph "FreeType glyph "+string:index+"/"+(string facerec:num_glyphs)
      part mapping "glyph mapping"
        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
      part load "FT_Load_Glyph"
        var Int err := FT_Load_Glyph face (cast index uInt) FT_LOAD_NO_SCALE
      if err<>0
        # console "Failed to load glyph " index eol
        if debug_trouble
          console "Failed to load glyph " index "/" facerec:num_glyphs eol
        leave record_glyph
      part get "FT_Get_Glyph"
        var Int err := FT_Get_Glyph facerec:glyph (var Address glyph)
      if err<>0
        # console "Failed to get glyph" eol
        if debug_trouble
          console "Failed to get glyph" eol
        leave record_glyph
      part mapping "glyph conversion"
        var Pointer:FT_OutlineGlyphRec r :> glyph map FT_OutlineGlyphRec
        (var Array:Curve curves) size := 0
        if direct
          constant factor (shunt use_conic 1 2/3)
          curves size := r:outline n_contours
          if use_conic
            var CBool is_conic := false
          var Pointer:FT_Outline o :> r:outline
          # console (cast o:n_contours Int) " contours " (cast o:n_points Int) " points" eol
          if debug_glyph
            console "glyph " index ": " (cast o:n_contours Int) " contours " (cast o:n_points Int) " points, vector " r:root:advance:x/unit/2^10 " " -(r:root:advance:y/unit/2^10) 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
            if debug_glyph
              console "contour " i " " j0 " " j1 ":"
              for (var Int j) j0 j1-1
                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
              console eol
            var CurvePoint last := curve_point 0 0 false
            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:CurvePoint l
                if c:size>0
                  l :> c point c:size-1
                else
                  l :> last
                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
                if (t1 .and. FT_CURVE_TAG_ON)<>0 or j+1=j1 # conic
                  l out (v0:x/unit-l:x)*factor (-(v0:y/unit)-l:y)*factor
                  if j+1<>j1
                    c angle v1:x/unit -(v1:y/unit)
                    l :> c point c:size-1
                  eif c:size>0
                    l :> c point 0
                  else
                    l :> last
                  l in (v0:x/unit-l:x)*factor (-(v0:y/unit)-l:y)*factor
                  j += 2 
                  if use_conic
                    is_conic := true
                eif (t0 .and. FT_CURVE_TAG_CUBIC)<>0 # cubic
                  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 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
                  if j+2<>j1
                    c angle v2:x/unit -(v2:y/unit)
                    var Pointer:CurvePoint l :> c point c:size-1
                  eif c:size>0
                    l :> c point 0
                  else
                    l :> last
                  l in v1:x/unit-l:x -(v1:y/unit)-l:y
                  j += 3
                else # two conic points http://www.freetype.org/freetype2/docs/glyphs/glyphs-6.html
                  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)
                  l out (v0:x/unit-l:x)*factor (-(v0:y/unit)-l:y)*factor
                  c angle (v0:x+v1:x)/2/unit -(v0:y+v1:y)/2/unit
                  var Pointer:CurvePoint l :> c point c:size-1
                  l in v1:x/unit-l:x -(v1:y/unit)-l:y
                  l in (v0:x/unit-l:x)*factor (-(v0:y/unit)-l:y)*factor
                  l out (v1:x/unit-l:x)*factor (-(v1:y/unit)-l:y)*factor
                  if j+2<>j1
                    c angle v2:x/unit -(v2:y/unit)
                    var Pointer:CurvePoint l :> c point c:size-1
                  eif c:size>0
                    l :> c point 0
                  else
                    l :> last
                  l in (v1:x/unit-l:x)*factor (-(v1:y/unit)-l:y)*factor
                  j += 3
            # console eol
            c compute outline+bezier
                  if use_conic
                    is_conic := true
            if last:is_angle and c:size>0
              var Pointer:CurvePoint l :> c point c:size-1
              if use_conic
                l out last:out_x-l:x last:out_y-l:y
              else
                l out (last:out_x/factor-l:x)*factor (last:out_y/factor-l:y)*factor
          var Int j := 0
          for (var Int i) 0 curves:size-1
            if use_conic
              curves:i compute outline+(shunt is_conic conic bezier)
            else
              curves:i compute outline+bezier
            if curves:i=success
              if j<>i
                swap curves:i curves:j
              j += 1
            eif debug_trouble
              console "buggy glyph contour" eol
          curves size := j
          if false
            for (var Int i) 0 curves:size-1
              for (var Int j) 0 curves:i:size-1
                var Pointer:CurvePoint p :> curves:i point j
                # console " ( " (string 1000*p:in_x "fixed 0") " " (string 1000*p:in_y "fixed 0") " " (string 1000*p:x "fixed 0") " " (string 1000*p:y "fixed 0") " " (string 1000*p:out_x "fixed 0") " " (string 1000*p:out_y "fixed 0") " ) "
                console "   " (string p:x*unit "fixed 0") " " (string -(p:y*unit) "fixed 0")
              console eol
        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
        fchar bbox_x0 := float_max
        fchar bbox_y0 := float_max
        fchar bbox_x1 := float_min
        fchar bbox_y1 := float_min
        for (var Int i) 0 fchar:curves:size-1
          var Pointer:Curve crv :> fchar:curves i
          crv bbox (var Float x0) (var Float y0) (var Float x1) (var Float y1)
          if x0=defined
            fchar bbox_x0 := min fchar:bbox_x0 x0
            fchar bbox_y0 := min fchar:bbox_y0 y0
            fchar bbox_x1 := max fchar:bbox_x1 x1
            fchar bbox_y1 := max fchar:bbox_y1 y1
            f bbox_x0 := min f:bbox_x0 x0
            f bbox_y0 := min f:bbox_y0 y0
            f bbox_x1 := max f:bbox_x1 x1
            f bbox_y1 := max f:bbox_y1 y1
        f:chars insert 2^30+2^29+index fchar
  if debug_encoding
    for (var Int i) 0 facerec:num_charmaps-1
      if (FT_Select_Charmap face (facerec:charmaps map Pointer:FT_CharMapRec i):encoding)=0
        console "freetype encoding " (string (facerec:charmaps map Pointer:FT_CharMapRec i):encoding "radix 16") "h:"
        for (var Int char) 1 2^16-1
          var Int index := FT_Get_Char_Index face (cast char uInt)
          if index<>0
            console " " char "->" index
        console eol
    if FT_Has_PS_Glyph_Names:face
      console "freetype glyph names" eol
  var Int encoding := shunt facerec:num_charmaps>0 (facerec:charmaps map Pointer:FT_CharMapRec 0):encoding (cast undefined Int)
  if encoding=unicode_encoding
    encoding := shunt facerec:num_charmaps>1 (facerec:charmaps map Pointer:FT_CharMapRec 1):encoding (cast undefined Int)
  if encoding<>undefined and (FT_Select_Charmap face encoding)=0
    for (var Int char) 1 2^16-1
      var Int index := FT_Get_Char_Index face (cast char uInt)
      if exists:(f:chars first 2^30+2^29+index)
        f:chars insert 2^30+char (f:chars first 2^30+2^29+index)
        if char<f:encoding:size and f:encoding:char<>undefined
          f:chars insert f:encoding:char (f:chars first 2^30+2^29+index)
  if (FT_Select_Charmap face unicode_encoding)=0
    for (var Int char) 1 2^16-1
      var Int index := FT_Get_Char_Index face (cast char uInt)
      if exists:(f:chars first 2^30+2^29+index)
        if exists:(f:chars first char)
          f:chars remove (f:chars first char)
        f:chars insert char (f:chars first 2^30+2^29+index)
  status := success

if not multithread
  gvar Sem libfreetype_sem

method f load_freetype filename options -> status
  arg_rw Font f ; arg Str filename options ; arg ExtendedStatus status
  if not multithread
    libfreetype_sem request
  part load "load freetype font "+filename+" "+options
    part init "FT_Init_FreeType"
      var Int err := FT_Init_FreeType (var Address library)
    if err<>0
      status := failure "failed to init freetype library"
      leave load
    status := f do_load_freetype library filename options
    part done "FT_Done_FreeType"
      var Int err := FT_Done_FreeType library
    if err<>0
      status := failure "failed to close freetype library"
  if not multithread
    libfreetype_sem release

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"