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/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
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



method f do_load_freetype library filename options -> status
  arg_rw Font f ; arg Address library ; arg Str filename opt
  part new_face "FT_New_Face"
    var Int err := FT_New_Face library file_os_name:filename
  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



method f do_load_freetype library filename options -> status
  arg_rw Font f ; arg Address library ; arg Str filename opt
  part new_face "FT_New_Face"
    var Int err := FT_New_Face library file_os_name:filename
  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+"/"+(st
    part record_glyph "FreeType glyph "+string:index+"/"+(st
      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
            glyph_name := glyph_name 0 (glyph_name search "[
            unicode :> postscript_glyphs first glyph_name
        if not exists:unicode
          if facerec:num_charmaps>=1
            var uInt encoding := (facerec:charmaps map Point
            if encoding=unicode_encoding and facerec:num_cha
              encoding := (facerec:charmaps map Pointer:FT_C
            if (FT_Select_Charmap face encoding)=0
              for (var Int char) 0 255
                if (FT_Get_Char_Index face (cast char uInt))
                  unicode :> f:encoding char
      if not exists:unicode
        # console "Failed to discover Unicode value for glyp
        leave record_glyph
      part load "FT_Load_Glyph"
        var Int err := FT_Load_Glyph face (cast index uInt) 
      if err<>0
      part load "FT_Load_Glyph"
        var Int err := FT_Load_Glyph face (cast index uInt) 
      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 Addre
      if err<>0
        leave record_glyph
      part get "FT_Get_Glyph"
        var Int err := FT_Get_Glyph facerec:glyph (var Addre
      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_Out
        (var Array:Curve curves) size := 0
        if direct
        leave record_glyph
      part mapping "glyph conversion"
        var Pointer:FT_OutlineGlyphRec r :> glyph map FT_Out
        (var Array:Curve curves) size := 0
        if direct
          constant factor (shunt use_conic 1 2/3)
          curves size := r:outline n_contours
          curves size := r:outline n_contours
          if use_conic
            var CBool is_conic := false
          var Pointer:FT_Outline o :> r:outline
          var Pointer:FT_Outline o :> r:outline
          # console (cast o:n_contours Int) " contours " (ca
          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
          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_Ve
              var Int t0 := o:tags map uInt8 j
              # console "   " (character 65+(t0 .and. 3)) " 
            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_Ve
              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 Int j := j0
            while j<j1
              var Pointer:FT_Vector v0 :> o:points map FT_Ve
              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_
                var Int t1 := o:tags map uInt8 (j+1-j0)%(j1-
                var Pointer:FT_Vector v1 :> o:points map FT_
                var Int t1 := o:tags map uInt8 (j+1-j0)%(j1-
                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
                  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
                  l in v0:x/unit-v1:x/unit -(v0:y/unit)-(-(v
                  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 F
                  var Int t2 := o:tags map uInt8 (j+2-j0)%(j
                  var Pointer:FT_Vector v2 :> o:points map F
                  var Int t2 := o:tags map uInt8 (j+2-j0)%(j
                  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
                  var Pointer:CurvePoint l :> c point c:size
                  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
                  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 A
          funcs line_to := (the_function line_to FT_Vector A
          funcs conic_to := (the_function conic_to FT_Vector
          funcs cubic_to := (the_function cubic_to FT_Vector
          funcs shift := 0
          funcs delta := 0
          if r:outline:n_contours>0
            if (FT_Outline_Decompose r:outline funcs address
              # 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 -(
        else
          var FT_Outline_Funcs funcs
          funcs move_to := (the_function move_to FT_Vector A
          funcs line_to := (the_function line_to FT_Vector A
          funcs conic_to := (the_function conic_to FT_Vector
          funcs cubic_to := (the_function cubic_to FT_Vector
          funcs shift := 0
          funcs delta := 0
          if r:outline:n_contours>0
            if (FT_Outline_Decompose r:outline funcs address
              # 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 -(
        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


  # test "embedded:/usr/share/fonts/type1/gsfonts/n019003l.p
  test "file:/tmp/font.cff"
  status := success


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