Patch title: Release 85 bulk changes
Abstract:
File: /pliant/graphic/vector/font.pli
Key:
    Removed line
    Added line
   
abstract
  [Loading and rendering a PostScript Type 1 font]

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
abstract
  [Loading and rendering a PostScript Type 1 font]

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and
# modify it under the terms of the GNU General Public Licens
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be us
# but WITHOUT ANY WARRANTY; without even the implied warrant
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See 
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public 
# version 2 along with this program; if not, write to the Fr
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 
# Fixed by  Patrice Ossona de Mendez


# ttf2pt1 -b /tmp/foo.ttf /tmp/foo
# http://dustismo.com/

module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/multi.pli"
module "/pliant/math/point.pli"

module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/multi.pli"
module "/pliant/math/point.pli"
module "/pliant/math/vector.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/transform.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/float.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/float.pli"
module "/pliant/language/data/cache.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/language/data/cache.pli"
module "/pliant/admin/md5.pli"

constant raster_fonts true
constant raster_maximum_size 63

constant raster_fonts true
constant raster_maximum_size 63
constant raster_cache_size 1024
constant raster_anti_aliasing 4
constant auto_accent true
constant raster_anti_aliasing 4
constant auto_accent true
constant type1details false
constant verbose false


#-----------------------------------------------------------
constant verbose false


#-----------------------------------------------------------
# Goodies


function '+' p v -> r
  arg Point2 p ; arg Vector2 v ; arg Point2 r
  r x := p:x+v:x
  r y := p:y+v:y

function '+' v1 v2 -> r
  arg Vector2 v1 v2 r
  r x := v1:x+v2:x
  r y := v1:y+v2:y

function '*' f v -> r
  arg Float f ; arg Vector2 v r
  r x := f*v:x
  r y := f*v:y

method v length -> w
  arg Vector2 v ; arg Float w
  if v:y=0
    w := v x
  else
    w := (v:x*v:x+v:y*v:y)^0.5


#-------------------------------------------------------------------------
# Decoding .pfb files



method drv ctoken
  arg_rw PfbStreamDriver drv
  var Int b := drv cgetc
  if b>=32
    var Int val
# Decoding .pfb files



method drv ctoken
  arg_rw PfbStreamDriver drv
  var Int b := drv cgetc
  if b>=32
    var Int val
    if b >= 32 and b <= 246
    if b<=246
      val := b - 139
      val := b - 139
    eif b >= 247 and b <= 250
    eif b<=250
      val := (b - 247)*256 + 108 + drv:cgetc
      val := (b - 247)*256 + 108 + drv:cgetc
    eif b >= 251 and b <= 254
    eif b<=254
      val := -(b - 251)*256 - 108 - drv:cgetc
    else
      val := -(b - 251)*256 - 108 - drv:cgetc
    else
      val := 0
      for (var Int i) 0 3
        addressof:val map uInt8 3-i := drv cgetc
    drv output string:val
  else
    if b=1
      drv output "hstem"
    eif b=3
      drv output "vstem"
    eif b=4
      drv output "vmoveto"
    eif b=5
      drv output "rlineto"
    eif b=6
      drv output "hlineto"
    eif b=7
      drv output "vlineto"
    eif b=8
      drv output "rrcurveto"
    eif b=9
      drv output "closepath"
    eif b=10
      drv output "callsubr"
    eif b=11
      drv output "return"
    eif b=13
      drv output "hsbw"
    eif b=14
      drv output "endchar"
    eif b=21
      drv output "rmoveto"
    eif b=22
      drv output "hmoveto"
    eif b=30
      drv output "vhcurveto"
    eif b=31
      drv output "hvcurveto"
    eif b=12
      b := drv cgetc
      if b=0
        drv output "dotsection"
      for (var Int i) 0 3
        addressof:val map uInt8 3-i := drv cgetc
    drv output string:val
  else
    if b=1
      drv output "hstem"
    eif b=3
      drv output "vstem"
    eif b=4
      drv output "vmoveto"
    eif b=5
      drv output "rlineto"
    eif b=6
      drv output "hlineto"
    eif b=7
      drv output "vlineto"
    eif b=8
      drv output "rrcurveto"
    eif b=9
      drv output "closepath"
    eif b=10
      drv output "callsubr"
    eif b=11
      drv output "return"
    eif b=13
      drv output "hsbw"
    eif b=14
      drv output "endchar"
    eif b=21
      drv output "rmoveto"
    eif b=22
      drv output "hmoveto"
    eif b=30
      drv output "vhcurveto"
    eif b=31
      drv output "hvcurveto"
    eif b=12
      b := drv cgetc
      if b=0
        drv output "dotsection"
        if b=1
          drv output "vstem3"
        eif b=2
          drv output "hstem3"
        eif b=6
          drv output "seac"
        eif b=7
          drv output "sbw"
        eif b=12
          drv output "div"
        eif b=16
          drv output "callothersubr"
        eif b=17
          drv output "pop"
        eif b=33
          drv output "setcurrentpoint"
      eif b=1
        drv output "vstem3"
      eif b=2
        drv output "hstem3"
      eif b=6
        drv output "seac"
      eif b=7
        drv output "sbw"
      eif b=12
        drv output "div"
      eif b=16
        drv output "callothersubr"
      eif b=17
        drv output "pop"
      eif b=33
        drv output "setcurrentpoint"
  if drv:cnb=0
    drv output " ":number
    drv output "}":number
    


  if drv:cnb=0
    drv output " ":number
    drv output "}":number
    


type Vector2
  field Float x y

function '+' p v -> r
  arg Point2 p ; arg Vector2 v ; arg Point2 r
  r x := p:x+v:x
  r y := p:y+v:y

function vector x y -> v
  arg Float x y ; arg Vector2 v
  v x := x ; v y := y


type FontChar
  field Str char_name
type FontChar
  field Str char_name
  field Array:Curve outline
  field Array:Curve curves
  field Vector2 vector
  field Vector2 vector
  field Float box_x0 box_y0 box_x1 box_y1 <- 0
  field Float bbox_x0 bbox_y0 bbox_x1 bbox_y1 <- 0


  type FontRaster


  type FontRaster
    inherit CachePrototype
    field (Dictionary Int Address) chars
    field (Dictionary Int Address) chars
    field Sem sem
  
  
  CachePrototype maybe FontRaster

  function destroy fr
    arg_w FontRaster fr
    each a fr:chars
      memory_free a

type Font
  function destroy fr
    arg_w FontRaster fr
    each a fr:chars
      memory_free a

type Font
  field Str psname
  field Str name
  field Str family
  field Str weight
  field CBool italic <- false
  field CBool fixed <- false
  field Str file
  inherit CachePrototype
  field (Dictionary Int FontChar) chars
  field Float x0 y0 x1 y1 <- 0
  field (Dictionary Int FontChar) chars
  field Float x0 y0 x1 y1 <- 0
  if raster_fonts
    field (Dictionary Int FontRaster) raster
    field Int raster_count <- 0
  field Str file
  # Pliant way to identify
  field Str family
  field Str fullname
  field Str psname
  field Str md5
  if type1details
    field Str weight
    field Float italic <- 0
    field CBool fixed <- false


CachePrototype maybe Font



type FontContext
  field Str filename
  field (Dictionary Str Str) defs
  field Array:Str subrs
  field Array:Float stack stack2
  field Point2 cp
  field Pointer:Curve cc
  field Pointer:FontChar ch


method fc newcurve -> c
  arg_rw FontContext fc ; arg_C Curve c
type FontContext
  field Str filename
  field (Dictionary Str Str) defs
  field Array:Str subrs
  field Array:Float stack stack2
  field Point2 cp
  field Pointer:Curve cc
  field Pointer:FontChar ch


method fc newcurve -> c
  arg_rw FontContext fc ; arg_C Curve c
  fc:ch:outline size += 1
  c :> fc:ch:outline fc:ch:outline:size-1
  fc:ch:curves size += 1
  c :> fc:ch:curves fc:ch:curves:size-1


method fc close_char_def
  arg_rw FontContext fc
  var Pointer:FontChar c :> fc ch


method fc close_char_def
  arg_rw FontContext fc
  var Pointer:FontChar c :> fc ch
  c box_x0 := float_max
  c box_y0 := float_max
  c box_x1 := float_min
  c box_y1 := float_min
  c bbox_x0 := float_max
  c bbox_y0 := float_max
  c bbox_x1 := float_min
  c bbox_y1 := float_min
  var Int i := 0
  var Int i := 0
  while i<c:outline:size
    var Pointer:Curve crv :> c:outline i
  while i<c:curves:size
    var Pointer:Curve crv :> c:curves i
    for (var Int j) 0 crv:size-1
      var Pointer:CurvePoint p :> crv point j
      p x /= 1000 ; p y /= 1000
      p in_x /= 1000 ; p in_y /= 1000
      p out_x /= 1000 ; p out_y /= 1000
    crv compute bezier
    if crv=success
    for (var Int j) 0 crv:size-1
      var Pointer:CurvePoint p :> crv point j
      p x /= 1000 ; p y /= 1000
      p in_x /= 1000 ; p in_y /= 1000
      p out_x /= 1000 ; p out_y /= 1000
    crv compute bezier
    if crv=success
      crv limits (var Float x0) (var Float y0) (var Float x1
      c box_x0 := min c:box_x0 x0
      c box_y0 := min c:box_y0 y0
      c box_x1 := max c:box_x1 x1
      c box_y1 := max c:box_y1 y1
      crv bbox (var Float x0) (var Float y0) (var Float x1) (var Float y1)
      c bbox_x0 := min c:bbox_x0 x0
      c bbox_y0 := min c:bbox_y0 y0
      c bbox_x1 := max c:bbox_x1 x1
      c bbox_y1 := max c:bbox_y1 y1
      i += 1
    else
      i += 1
    else
      for (var Int j) i c:outline:size-2
        swap (c:outline j) (c:outline j+1)
      c:outline size -= 1
      for (var Int j) i c:curves:size-2
        swap (c:curves j) (c:curves j+1)
      c:curves size -= 1
  c:vector x /= 1000 ; c:vector y /= 1000


method fc interprete prog
  arg_rw FontContext fc ; arg Str prog
  implicit fc
    var Str p := prog ; var Str r
    while p<>""
      if (p parse (var Float f) any:r)
        push f
      eif (p parse word:"rlineto" any:r) and count>=2
        cp x += st 1 ; cp y -= st 0
        cc angle cp:x cp:y
        pop 2
      eif (p parse word:"hlineto" any:r) and count>=1
        cp x += st 0
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"vlineto" any:r) and count>=1
        cp y -= st 0
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"rmoveto" any:r) and count>=2
        cp x += st 1 ; cp y -= st 0
        cc :> newcurve
        cc angle cp:x cp:y
        pop 2
      eif (p parse word:"hmoveto" any:r) and count>=1
        cp x += st 0
        cc :> newcurve
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"vmoveto" any:r) and count>=1
        cp y -= st 0
        cc :> newcurve
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"rrcurveto" any:r) and count>=6
        var Point2 p1 := cp+(vector st:5 -(st:4))
        var Point2 p2 := p1+(vector st:3 -(st:2))
        var Point2 p3 := p2+(vector st:1 -(st:0))
        cp := p3
        cc angle cp:x cp:y
        var Pointer:CurvePoint cp0 :> lastpoint 0
        var Pointer:CurvePoint cp1 :> lastpoint 1
        cp1 out p1:x-cp1:x p1:y-cp1:y
        cp0 in p2:x-cp0:x p2:y-cp0:y
        pop 6
      eif (p parse word:"hvcurveto" any:r) and count>=4
        var Point2 p1 := cp+(vector st:3 0)
        var Point2 p2 := p1+(vector st:2 -(st:1))
        var Point2 p3 := p2+(vector 0 -(st:0))
        cp := p3
        cc angle cp:x cp:y
        var Pointer:CurvePoint cp0 :> lastpoint 0
        var Pointer:CurvePoint cp1 :> lastpoint 1
        cp1 out p1:x-cp1:x p1:y-cp1:y
        cp0 in p2:x-cp0:x p2:y-cp0:y
        pop 4
      eif (p parse word:"vhcurveto" any:r) and count>=4
        var Point2 p1 := cp+(vector 0 -(st:3))
        var Point2 p2 := p1+(vector st:2 -(st:1))
        var Point2 p3 := p2+(vector st:0 0)
        cp := p3
        cc angle cp:x cp:y
        var Pointer:CurvePoint cp0 :> lastpoint 0
        var Pointer:CurvePoint cp1 :> lastpoint 1
        cp1 out p1:x-cp1:x p1:y-cp1:y
        cp0 in p2:x-cp0:x p2:y-cp0:y
        pop 4
      eif (p parse word:"hsbw" any:r) and count>=2
        cp := point st:1 0
        ch vector := vector st:0 0
        pop 2
      eif (p parse word:"sbw" any:r) and count>=4
        cp := point st:3 -(st:2)
        ch vector := vector st:1 -(st:0)
        pop 4
      eif (p parse word:"seac" any:r) and count>=5
        var Vector2 v := ch vector
        var Int a := cast st:0 Int
        var Int b := cast st:1 Int
  c:vector x /= 1000 ; c:vector y /= 1000


method fc interprete prog
  arg_rw FontContext fc ; arg Str prog
  implicit fc
    var Str p := prog ; var Str r
    while p<>""
      if (p parse (var Float f) any:r)
        push f
      eif (p parse word:"rlineto" any:r) and count>=2
        cp x += st 1 ; cp y -= st 0
        cc angle cp:x cp:y
        pop 2
      eif (p parse word:"hlineto" any:r) and count>=1
        cp x += st 0
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"vlineto" any:r) and count>=1
        cp y -= st 0
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"rmoveto" any:r) and count>=2
        cp x += st 1 ; cp y -= st 0
        cc :> newcurve
        cc angle cp:x cp:y
        pop 2
      eif (p parse word:"hmoveto" any:r) and count>=1
        cp x += st 0
        cc :> newcurve
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"vmoveto" any:r) and count>=1
        cp y -= st 0
        cc :> newcurve
        cc angle cp:x cp:y
        pop 1
      eif (p parse word:"rrcurveto" any:r) and count>=6
        var Point2 p1 := cp+(vector st:5 -(st:4))
        var Point2 p2 := p1+(vector st:3 -(st:2))
        var Point2 p3 := p2+(vector st:1 -(st:0))
        cp := p3
        cc angle cp:x cp:y
        var Pointer:CurvePoint cp0 :> lastpoint 0
        var Pointer:CurvePoint cp1 :> lastpoint 1
        cp1 out p1:x-cp1:x p1:y-cp1:y
        cp0 in p2:x-cp0:x p2:y-cp0:y
        pop 6
      eif (p parse word:"hvcurveto" any:r) and count>=4
        var Point2 p1 := cp+(vector st:3 0)
        var Point2 p2 := p1+(vector st:2 -(st:1))
        var Point2 p3 := p2+(vector 0 -(st:0))
        cp := p3
        cc angle cp:x cp:y
        var Pointer:CurvePoint cp0 :> lastpoint 0
        var Pointer:CurvePoint cp1 :> lastpoint 1
        cp1 out p1:x-cp1:x p1:y-cp1:y
        cp0 in p2:x-cp0:x p2:y-cp0:y
        pop 4
      eif (p parse word:"vhcurveto" any:r) and count>=4
        var Point2 p1 := cp+(vector 0 -(st:3))
        var Point2 p2 := p1+(vector st:2 -(st:1))
        var Point2 p3 := p2+(vector st:0 0)
        cp := p3
        cc angle cp:x cp:y
        var Pointer:CurvePoint cp0 :> lastpoint 0
        var Pointer:CurvePoint cp1 :> lastpoint 1
        cp1 out p1:x-cp1:x p1:y-cp1:y
        cp0 in p2:x-cp0:x p2:y-cp0:y
        pop 4
      eif (p parse word:"hsbw" any:r) and count>=2
        cp := point st:1 0
        ch vector := vector st:0 0
        pop 2
      eif (p parse word:"sbw" any:r) and count>=4
        cp := point st:3 -(st:2)
        ch vector := vector st:1 -(st:0)
        pop 4
      eif (p parse word:"seac" any:r) and count>=5
        var Vector2 v := ch vector
        var Int a := cast st:0 Int
        var Int b := cast st:1 Int
        console "seac " a " " b eol
        var Vector2 t := vector st:3-st:4 -(st:2)
        pop 5
        if exists:(defs first string:a) # shoud be std_ev:a
          interprete (defs string:a)
        var Vector2 t := vector st:3-st:4 -(st:2)
        pop 5
        if exists:(defs first string:a) # shoud be std_ev:a
          interprete (defs string:a)
        for (var Int n) 0 ch:outline:size-1
          var Pointer:Curve c :> ch:outline n
        for (var Int n) 0 ch:curves:size-1
          var Pointer:Curve c :> ch:curves n
          for (var Int i) 0 c:size
            var Pointer:CurvePoint pp :> c point i
            pp x += t x ; pp y += t y
        if exists:(defs first string:b) # shoud be std_ev:b
          interprete (defs string:b)
        ch vector := v
      eif (p parse word:"hstem" any:r) and count>=2
        pop 2
      eif (p parse word:"hstem3" any:r) and count>=5
        pop 6
      eif (p parse word:"vstem" any:r) and count>=2
        pop 2
      eif (p parse word:"vstem3" any:r) and count>=5
        pop 6
      eif (p parse word:"div" any:r) and count>=2
        st 1 /= st 0
        pop 1
      eif (p parse word:"callsubr" any:r) and count>=1
        var Int i := cast st:0 Int
        pop 1
        if i>=0 and i<subrs:size
          interprete subrs:i
      eif (p parse word:"callothersubr" any:r) and count>=2 
        pop 2
        for (var Int u) 0 n-1
          stack2 += st 0
          pop 1
      eif (p parse word:"pop" any:r) and stack2:size>=0
        push (stack2 stack2:size-1)
        fc:stack2 size -= 1
      eif (p parse word:"return" any:r)
        void
      eif (p parse word:"dotsection" any:r)
        void
      eif (p parse word:"closepath" any:r)
        void
      eif (p parse word:"endchar" any:r)
        void
      else
        console "Failed to parse definition " p " in " filen
        return
      p := r

          for (var Int i) 0 c:size
            var Pointer:CurvePoint pp :> c point i
            pp x += t x ; pp y += t y
        if exists:(defs first string:b) # shoud be std_ev:b
          interprete (defs string:b)
        ch vector := v
      eif (p parse word:"hstem" any:r) and count>=2
        pop 2
      eif (p parse word:"hstem3" any:r) and count>=5
        pop 6
      eif (p parse word:"vstem" any:r) and count>=2
        pop 2
      eif (p parse word:"vstem3" any:r) and count>=5
        pop 6
      eif (p parse word:"div" any:r) and count>=2
        st 1 /= st 0
        pop 1
      eif (p parse word:"callsubr" any:r) and count>=1
        var Int i := cast st:0 Int
        pop 1
        if i>=0 and i<subrs:size
          interprete subrs:i
      eif (p parse word:"callothersubr" any:r) and count>=2 
        pop 2
        for (var Int u) 0 n-1
          stack2 += st 0
          pop 1
      eif (p parse word:"pop" any:r) and stack2:size>=0
        push (stack2 stack2:size-1)
        fc:stack2 size -= 1
      eif (p parse word:"return" any:r)
        void
      eif (p parse word:"dotsection" any:r)
        void
      eif (p parse word:"closepath" any:r)
        void
      eif (p parse word:"endchar" any:r)
        void
      else
        console "Failed to parse definition " p " in " filen
        return
      p := r

function font_postscript filename -> f
  arg Str filename ; arg Link:Font f
method f load_postscript filename -> status
  arg_rw Font f ; arg Str filename ; arg Status status
  if false
    (var Stream s) open "pfb:"+filename in+safe
    (var Stream clear) open "file:/tmp/font.txt" out+safe
    while not s:atend
      clear writeline s:readline
    clear close
  (var Stream s) open "pfb:"+filename in+safe
  if s=failure or not (s:readline parse "%!" any)
  if false
    (var Stream s) open "pfb:"+filename in+safe
    (var Stream clear) open "file:/tmp/font.txt" out+safe
    while not s:atend
      clear writeline s:readline
    clear close
  (var Stream s) open "pfb:"+filename in+safe
  if s=failure or not (s:readline parse "%!" any)
    f :> null map Font
    return
  f :> new Font
  
    return failure
  f file := filename
  var FontContext ctx ; ctx filename := filename
  while not s:atend
    var Str l := s readline
    if (l parse word:"/FontName" "/" any:(var Str n) word:"d
      f psname := n
    eif (l parse word:"/FullName" "(" any:(var Str n) ")" wo
  f file := filename
  var FontContext ctx ; ctx filename := filename
  while not s:atend
    var Str l := s readline
    if (l parse word:"/FontName" "/" any:(var Str n) word:"d
      f psname := n
    eif (l parse word:"/FullName" "(" any:(var Str n) ")" wo
      f name := n
      f fullname := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" 
      f family := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" 
      f family := n
    eif (l parse word:"/Weight" "(" any:(var Str n) ")" word
    eif type1details and (l parse word:"/Weight" "(" any:(var Str n) ")" word:"readonly" word:"def")
      f weight := n
      f weight := n
    eif (l parse word:"/ItalicAngle" (var Float ff) word:"de
      f italic := ff<>0
    eif (l parse word:"/isFixedPitch" any:(var Str n) word:"
    eif type1details and (l parse word:"/ItalicAngle" (var Float ff) word:"def")
      f italic := ff
    eif type1details and (l parse word:"/isFixedPitch" any:(var Str n) word:"def")
      f fixed := n="true"
    eif (l parse word:"/FontBBox" "{" (var Int ix0) (var Int
      f x0 := ix0/1000
      f y0 := -iy1/1000
      f x1 := ix1/1000
      f y1 := -iy0/1000
    eif (l parse word:"dup" (var Int i) "{" any:(var Str d) 
      if i>=0 and i<2^16
        if i>=ctx:subrs:size
          ctx:subrs size := i+1
        ctx:subrs i := d
    eif (l parse "/" any:(var Str n) "{" any:(var Str d) "}"
      ctx:defs insert n d
  each def ctx:defs
    var Str n := ctx:defs key def
    var Pointer:Int num :> postscript_glyphs first n
    if exists:num
      var FontChar new_ch := var FontChar empty_char
      ctx open_char_def new_ch n
      ctx interprete def
      ctx close_char_def
      f fixed := n="true"
    eif (l parse word:"/FontBBox" "{" (var Int ix0) (var Int
      f x0 := ix0/1000
      f y0 := -iy1/1000
      f x1 := ix1/1000
      f y1 := -iy0/1000
    eif (l parse word:"dup" (var Int i) "{" any:(var Str d) 
      if i>=0 and i<2^16
        if i>=ctx:subrs:size
          ctx:subrs size := i+1
        ctx:subrs i := d
    eif (l parse "/" any:(var Str n) "{" any:(var Str d) "}"
      ctx:defs insert n d
  each def ctx:defs
    var Str n := ctx:defs key def
    var Pointer:Int num :> postscript_glyphs first n
    if exists:num
      var FontChar new_ch := var FontChar empty_char
      ctx open_char_def new_ch n
      ctx interprete def
      ctx close_char_def
      if not auto_accent or not exists:(accents first num) o
      if not auto_accent or not exists:(accents first num) or new_ch:curves:size>0
        f:chars insert num new_ch
  if f:x0=0 and f:y0=0 and f:x1=0 and f:y1=0
    each ch f:chars
        f:chars insert num new_ch
  if f:x0=0 and f:y0=0 and f:x1=0 and f:y1=0
    each ch f:chars
      for (var Int j) 0 ch:outline:size-1
        ch:outline:j limits (var Float x0) (var Float y0) (v
      for (var Int j) 0 ch:curves:size-1
        ch:curves:j bbox (var Float x0) (var Float y0) (var Float x1) (var Float y1)
        if y0=defined and y1=defined
          f x0 := min f:x0 x0
          f y0 := min f:y0 y0
          f x1 := max f:x1 x1
          f y1 := max f:y1 y1
        if y0=defined and y1=defined
          f x0 := min f:x0 x0
          f y0 := min f:y0 y0
          f x1 := max f:x1 x1
          f y1 := max f:y1 y1
  f md5 := file_md5_hexa_signature filename
  if verbose
  if verbose
    console "  loaded font " f:name " / " f:family " (" f:ps
    console "  loaded font " f:fullname eol
  status := success


function font_postscript filename -> f
  arg Str filename ; arg Link:Font f
  f :> new Font
  if (f load_postscript filename)=failure
    f :> null map Font


export postscript_glyphs font_postscript


#-----------------------------------------------------------
#-----------------------------------------------------------
# Basic queries


method f curves char_num -> curves
  arg Font f ; arg Int char_num ; arg Array:Curve curves
  curves size := 0
  var Pointer:FontChar ch :> f:chars first char_num
  if exists:ch
    curves := ch curves
  eif auto_accent and { var Pointer:FontAccent a :> accents first char_num ; exists a }
    var Pointer:FontChar base :> f:chars first a:base
    var Pointer:FontChar accent :> f:chars first a:accent
    if exists:base and exists:accent
      curves size := base:curves:size+accent:curves:size
      for (var Int i) 0 base:curves:size
        curves i := base:curves:i
      for (var Int i) 0 accent:curves:size
        curves base:curves:size+i := accent:curves:i
    else
      curves size := 0
  else
    curves size := 0


method f vector char_num -> v
  arg Font f ; arg Int char_num ; arg Vector2 v
  var Pointer:FontChar ch :> f:chars first char_num
  if auto_accent and not exists:ch and { var Pointer:FontAccent a :> accents first char_num ; exists a }
    ch :> f:chars first a:base
  if exists:ch
    v := ch vector
  else
    v := vector 0 0

method f bbox char_num x0 y0 x1 y1
  arg Font f ; arg Int char_num ; arg_w Float x0 y0 x1 y1
  var Pointer:FontChar ch :> f:chars first char_num
  if auto_accent and not exists:ch and { var Pointer:FontAccent a :> accents first char_num ; exists a }
    ch :> f:chars first a:base
  if exists:ch
    x0 := ch bbox_x0 ; y0 := ch bbox_y0 ; x1 := ch bbox_x1 ; y1 := ch bbox_y1
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0


export Font '. family' '. fullname' '. psname' '. md5'
if type1details
  export '. weight' '. italic' '. fixed'
export '. curves' '. vector' '. bbox'


#-------------------------------------------------------------------------
# Advanced queries


method f vector buffer count csize kerning -> v
  arg Font f ; arg Address buffer ; arg Int count csize ; arg Address kerning ; arg Vector2 v
  v := vector 0 0
  for (var Int i) 0 count-1
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    var Pointer:FontChar ch :> f:chars first num
    if auto_accent and not exists:ch and { var Pointer:FontAccent a :> accents first num ; exists a }
      ch :> f:chars first a:base
    if exists:ch
      if kerning<>null
        v += (kerning map Float i)*ch:vector
      else
        v += ch:vector

method f length text kerning -> w
  arg Font f ; arg Str text ; arg Address kerning ; arg Float w
  w := (f vector text:characters text:len 1 kerning) length

method f length text kerning -> w
  arg Font f ; arg Str32 text ; arg Address kerning ; arg Float w
  w := (f vector text:characters text:len 4 kerning) length

method f bbox text kerning x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Address kerning ; arg_w Float x0 y0 x1 y1
  if text:len<>0
    var Vector2 v := f vector text:characters text:len-1 1 kerning
    x0 := min f:x0 v:x+f:x0 ; y0 := min f:y0 v:y+f:y0 ; x1 := max f:x1 v:x+f:x1 ; y1 := max f:y1 v:y+f:y1
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0

method f bbox text kerning x0 y0 x1 y1
  arg Font f ; arg Str32 text ; arg Address kerning ; arg_w Float x0 y0 x1 y1
  if text:len<>0
    var Vector2 v := f vector text:characters text:len-1 4 kerning
    x0 := min f:x0 v:x+f:x0 ; y0 := min f:y0 v:y+f:y0 ; x1 := max f:x1 v:x+f:x1 ; y1 := max f:y1 v:y+f:y1
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0

export '. length' '. bbox'



#-------------------------------------------------------------------------
# Drawing text

# Drawing text


module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/antialiasing.pli"
module "/pliant/graphic/color/gamut.pli"
module "outline.pli"


module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/antialiasing.pli"
module "/pliant/graphic/color/gamut.pli"
module "outline.pli"


method f draw ch img x y scale color
  arg Font f ; arg FontChar ch ; oarg_rw ImagePrototype img 
  var Float x0 := x
  var Float y0 := y+f:y0*scale
  var Float x1 := x+ch:vector:x*scale
  var Float y1 := y+f:y1*scale
  if x0>img:x1 or y0>img:y1 or x1<img:x0 or y1<img:y0
    return
  var Outline outline := var Outline empty_outline
  for (var Int j) 0 ch:outline:size-1
    var Curve c := ch:outline j
    for (var Int k) 0 c:size-1
      var Pointer:CurvePoint p :> c point k
      p in_x *= scale
      p in_y *= scale
      p x := x+p:x*scale
      p y := y+p:y*scale
      p out_x *= scale
      p out_y *= scale
    var Array:Point2 pts := c polyline (min (img:x1-img:x0)/
    outline build_chains pts
    pts size := 0
  outline chains # FIXME: Pliant will wrongly optimize if re
  outline draw img color
method img character f char_num t color
  oarg_rw ImagePrototype img ; arg Font f ; arg Int char_num ; arg Transform2 t ; arg Address color
  var Pointer:FontChar ch :> f:chars first char_num
  if exists:ch
    img fill ch:curves outline_evenodd t color
  eif auto_accent and { var Pointer:FontAccent a :> accents first char_num ; exists a }
    var Pointer:FontChar base :> f:chars first a:base
    var Pointer:FontChar accent :> f:chars first a:accent
    if exists:base and exists:accent
      img fill base:curves outline_evenodd t color
      img fill accent:curves outline_evenodd t color






  method f rasterize ch rsize -> buf
    arg Font f ; arg FontChar ch ; arg Int rsize ; arg Addre
  method f rasterize char_num rsize -> buf
    arg Font f ; arg Int char_num ; arg Int rsize ; arg Address buf
    var Float res := rsize/(f:y1-f:y0)
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype f:x0 f:y0 f:x1 f:y1 (cast 
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    final bind pixmap raster_anti_aliasing raster_anti_alias
    var Address linebuf := memory_allocate final:line_size n
    var uInt8 color := 0
    for (var Int y) 0 pixmap:size_y-1
      pixmap fill 0 y pixmap:size_x addressof:color
    var uInt8 color := 255
    var Float res := rsize/(f:y1-f:y0)
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype f:x0 f:y0 f:x1 f:y1 (cast 
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    final bind pixmap raster_anti_aliasing raster_anti_alias
    var Address linebuf := memory_allocate final:line_size n
    var uInt8 color := 0
    for (var Int y) 0 pixmap:size_y-1
      pixmap fill 0 y pixmap:size_x addressof:color
    var uInt8 color := 255
    f draw ch pixmap 0 0 1 addressof:color
    pixmap character f char_num transform addressof:color
    var Int reserved := 2*rsize*3+uInt:size ; var Int used :
    buf := memory_allocate reserved null
    var Int cx := (cast -(f:x0)*res Int) ; var Int cy := (ca
    for (var Int y) 0 final:size_y-1
      final read 0 y final:size_x linebuf
      var Int x0 := 0
      part segment
        while x0<final:size_x and (linebuf map uInt8 x0)=0
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)<>0
          x1 += 1
        while used+3+(x1-x0)+uInt:size>reserved
          reserved *= 2
          buf := memory_resize buf reserved addressof:f
        var Int limit := 127
        var Int dx := x0-cx
        var Int dy := y-cy
        if dx<>(bound dx -limit limit)
          dx := bound dx -limit limit ; x1 := x0
        if dy<>(bound dy -limit limit)
          dy := bound dy -limit limit ; x1 := x0
        (buf translate Byte used) map Int8 := dx ; used += 1
        (buf translate Byte used) map Int8 := dy ; used += 1
        (buf translate Byte used) map uInt8 := x1-x0 ; used 
        for (var Int x) x0 x1-1
          (buf translate Byte used) map uInt8 := linebuf map
        cx += dx ; cy += dy
        x0 := x1
        restart segment
    memory_free linebuf
    (buf translate Byte used) map uInt := 0 ; used += uInt s
    buf := memory_resize buf used addressof:f
    
    var Int reserved := 2*rsize*3+uInt:size ; var Int used :
    buf := memory_allocate reserved null
    var Int cx := (cast -(f:x0)*res Int) ; var Int cy := (ca
    for (var Int y) 0 final:size_y-1
      final read 0 y final:size_x linebuf
      var Int x0 := 0
      part segment
        while x0<final:size_x and (linebuf map uInt8 x0)=0
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)<>0
          x1 += 1
        while used+3+(x1-x0)+uInt:size>reserved
          reserved *= 2
          buf := memory_resize buf reserved addressof:f
        var Int limit := 127
        var Int dx := x0-cx
        var Int dy := y-cy
        if dx<>(bound dx -limit limit)
          dx := bound dx -limit limit ; x1 := x0
        if dy<>(bound dy -limit limit)
          dy := bound dy -limit limit ; x1 := x0
        (buf translate Byte used) map Int8 := dx ; used += 1
        (buf translate Byte used) map Int8 := dy ; used += 1
        (buf translate Byte used) map uInt8 := x1-x0 ; used 
        for (var Int x) x0 x1-1
          (buf translate Byte used) map uInt8 := linebuf map
        cx += dx ; cy += dy
        x0 := x1
        restart segment
    memory_free linebuf
    (buf translate Byte used) map uInt := 0 ; used += uInt s
    buf := memory_resize buf used addressof:f
    
  function rdraw buf img ix iy color
    arg Address buf ; oarg_rw ImagePrototype img ; arg Int i
  method img rcharacter buf ix iy color
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int ix iy ; arg Address color
    var Address c := buf ; var Int x := ix ; var Int y := iy
    var Int psize := img pixel_size
    while (c map uInt)<>0
      x += c map Int8 ; c := c translate Int8 1
      y += c map Int8 ; c := c translate Int8 1
      var Int n := c map uInt8 ; c := c translate uInt8 1
      if y>=0 and y<img:size_y
        var Int x0 := max x 0
        var Int x1 := min x+n img:size_x
        if x1>x0
          # img fill x0 y x1-x0 color
          var Address adr := img write_map x0 y x1-x0 x1-x0 
          if adr<>null
            var Address pixel := adr ; var Address stop := p
            var Address opacity := c translate uInt8 x0-x
            while pixel<>stop
              pixel_mixte pixel color psize (opacity map uIn
              pixel := pixel translate Byte psize
              opacity := opacity translate uInt8 1
            img write_unmap x0 y count adr
      c := c translate uInt8 n


    var Address c := buf ; var Int x := ix ; var Int y := iy
    var Int psize := img pixel_size
    while (c map uInt)<>0
      x += c map Int8 ; c := c translate Int8 1
      y += c map Int8 ; c := c translate Int8 1
      var Int n := c map uInt8 ; c := c translate uInt8 1
      if y>=0 and y<img:size_y
        var Int x0 := max x 0
        var Int x1 := min x+n img:size_x
        if x1>x0
          # img fill x0 y x1-x0 color
          var Address adr := img write_map x0 y x1-x0 x1-x0 
          if adr<>null
            var Address pixel := adr ; var Address stop := p
            var Address opacity := c translate uInt8 x0-x
            while pixel<>stop
              pixel_mixte pixel color psize (opacity map uIn
              pixel := pixel translate Byte psize
              opacity := opacity translate uInt8 1
            img write_unmap x0 y count adr
      c := c translate uInt8 n


  method f rasterize ch rsize -> buf
    arg Font f ; arg FontChar ch ; arg Int rsize ; arg Addre
  method f rasterize char_num rsize -> buf
    arg Font f ; arg Int char_num ; arg Int rsize ; arg Address buf
    var Float res := rsize/(f:y1-f:y0)
    var Int aa := 4
    var Int threshold := aa*aa\2
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype f:x0 f:y0 f:x1 f:y1 (cast 
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    final bind pixmap aa
    var Address linebuf := memory_allocate final:line_size n
    var uInt8 color := 0
    for (var Int y) 0 pixmap:size_y-1
      pixmap fill 0 y pixmap:size_x addressof:color
    var uInt8 color := aa*aa
    var Float res := rsize/(f:y1-f:y0)
    var Int aa := 4
    var Int threshold := aa*aa\2
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype f:x0 f:y0 f:x1 f:y1 (cast 
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    final bind pixmap aa
    var Address linebuf := memory_allocate final:line_size n
    var uInt8 color := 0
    for (var Int y) 0 pixmap:size_y-1
      pixmap fill 0 y pixmap:size_x addressof:color
    var uInt8 color := aa*aa
    f draw ch pixmap 0 0 1 addressof:color
    pixmap character f char_num transform addressof:color
    var Int reserved := 2*rsize*3+uInt:size ; var Int used :
    buf := memory_allocate reserved null
    var Int cx := (cast -(f:x0)*res Int) ; var Int cy := (ca
    for (var Int y) 0 final:size_y-1
      final read 0 y final:size_x linebuf
      var Int x0 := 0
      part segment
        while x0<final:size_x and (linebuf map uInt8 x0)<thr
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)>=th
          x1 += 1
        if used+3+uInt:size>reserved
          reserved *= 2
          buf := memory_resize buf reserved addressof:f
        var Int limit := 127
        var Int dx := x0-cx
        var Int dy := y-cy
        if dx<>(bound dx -limit limit)
          dx := bound dx -limit limit ; x1 := x0
        if dy<>(bound dy -limit limit)
          dy := bound dy -limit limit ; x1 := x0
        (buf translate Byte used) map Int8 := dx ; used += 1
        (buf translate Byte used) map Int8 := dy ; used += 1
        (buf translate Byte used) map uInt8 := x1-x0 ; used 
        cx += dx ; cy += dy
        x0 := x1
        restart segment
    memory_free linebuf
    (buf translate Byte used) map uInt := 0 ; used += uInt s
    buf := memory_resize buf used addressof:f
    
    var Int reserved := 2*rsize*3+uInt:size ; var Int used :
    buf := memory_allocate reserved null
    var Int cx := (cast -(f:x0)*res Int) ; var Int cy := (ca
    for (var Int y) 0 final:size_y-1
      final read 0 y final:size_x linebuf
      var Int x0 := 0
      part segment
        while x0<final:size_x and (linebuf map uInt8 x0)<thr
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)>=th
          x1 += 1
        if used+3+uInt:size>reserved
          reserved *= 2
          buf := memory_resize buf reserved addressof:f
        var Int limit := 127
        var Int dx := x0-cx
        var Int dy := y-cy
        if dx<>(bound dx -limit limit)
          dx := bound dx -limit limit ; x1 := x0
        if dy<>(bound dy -limit limit)
          dy := bound dy -limit limit ; x1 := x0
        (buf translate Byte used) map Int8 := dx ; used += 1
        (buf translate Byte used) map Int8 := dy ; used += 1
        (buf translate Byte used) map uInt8 := x1-x0 ; used 
        cx += dx ; cy += dy
        x0 := x1
        restart segment
    memory_free linebuf
    (buf translate Byte used) map uInt := 0 ; used += uInt s
    buf := memory_resize buf used addressof:f
    
  function rdraw buf img ix iy color
    arg Address buf ; oarg_rw ImagePrototype img ; arg Int i
  method img rcharacter buf ix iy color
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int ix iy ; arg Address color
    var Address c := buf ; var Int x := ix ; var Int y := iy
    while (c map uInt)<>0
      x += c map Int8 ; c := c translate Int8 1
      y += c map Int8 ; c := c translate Int8 1
      var Int n := c map uInt8 ; c := c translate uInt8 1
      if y>=0 and y<img:size_y
        var Int x0 := max x 0
        var Int x1 := min x+n img:size_x
        if x1>x0
          img fill x0 y x1-x0 color

    var Address c := buf ; var Int x := ix ; var Int y := iy
    while (c map uInt)<>0
      x += c map Int8 ; c := c translate Int8 1
      y += c map Int8 ; c := c translate Int8 1
      var Int n := c map uInt8 ; c := c translate uInt8 1
      if y>=0 and y<img:size_y
        var Int x0 := max x 0
        var Int x1 := min x+n img:size_x
        if x1>x0
          img fill x0 y x1-x0 color

method f draw buffer length csize img x y scale extra_spacin
  arg_rw Font f ; arg Address buffer ; arg Int length csize 
method p index_x x -> i
  arg ImagePrototype p ; arg Float x ; arg Int i
  i := cast (x-p:x0)/(p:x1-p:x0)*p:size_x-0.499 Int

method p index_y y -> i
  arg ImagePrototype p ; arg Float y ; arg Int i
  i := cast (y-p:y0)/(p:y1-p:y0)*p:size_y-0.499 Int

method img text buffer count csize f kerning length t color speedup
  oarg_rw ImagePrototype img ; arg Address buffer ; arg Int count csize ; arg_rw Font f ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color ; arg CBool speedup
  var Float spacing := 1
  if length=defined
    spacing := length/(f vector buffer count csize kerning):length
    if spacing=undefined
      spacing := 0
  if raster_fonts
  if raster_fonts
    var Int rsize := cast (f:y1-f:y0)*scale/(img:y1-img:y0)*
    if rsize<=raster_maximum_size
      var Pointer:FontRaster rf :> f:raster first rsize
      if not exists:rf
        f:raster insert rsize (var FontRaster empty_font_ras
        rf :> f:raster first rsize
      var Float cur_x := x
      var Float cur_y := y
      for (var Int i) 0 length-1
        var Int num
        if csize=1
          num := buffer map uInt8 i
        eif csize=4
          num := buffer map Int32 i
        var Pointer:FontChar ch :> f:chars first num
        if exists:ch # and cur_x+f:x0<img:x1 and cur_x+f:x1>
          var Pointer:Address rch :> rf:chars first num
          if not exists:rch
            rf:chars insert num (f rasterize ch rsize)
            rch :> rf:chars first num
            f raster_count += 1
          rdraw rch img (img index_x cur_x) (img index_y cur
          cur_x += ch:vector:x*scale+extra_spacing_x
          cur_y += ch:vector:y*scale+extra_spacing_y
      if f:raster_count>=raster_cache_size
        f raster := var (Dictionary Int FontRaster) empty_fo
      return  
  var Float cur_x := x
  var Float cur_y := y
  for (var Int i) 0 length-1
    var CBool raster := false
    if speedup and t:level<=transform_scale and t:xx=t:yy
      var Int rsize := cast t:yy*(f:y1-f:y0)/(img:y1-img:y0)*img:size_y Int
      if rsize<=raster_maximum_size
        var Link:FontRaster rf
        if (cache_open "/pliant/fontr/"+string:rsize+"/"+f:file FontRaster ((addressof Link:FontRaster rf) map Link:CachePrototype))
          cache_ready ((addressof Link:FontRaster rf) map Link:CachePrototype)
        rf:sem request
        raster := true
  var Transform2 cur := t
  for (var Int i) 0 count-1
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    var Pointer:FontChar ch :> f:chars first num
    if exists:ch
      f draw ch img cur_x cur_y scale color
      cur_x += ch:vector:x*scale+extra_spacing_x
      cur_y += ch:vector:y*scale+extra_spacing_y
    eif auto_accent and { var Pointer:FontAccent a :> accent
      var Pointer:FontChar base :> f:chars first a:base
      var Pointer:FontChar accent :> f:chars first a:accent
      if exists:base and exists:accent
        f draw base img cur_x cur_y scale color
        f draw accent img cur_x+(base:vector:x-accent:vector
        cur_x += base:vector:x*scale+extra_spacing_x
        cur_y += base:vector:y*scale+extra_spacing_y
    if raster_fonts and raster
      var Pointer:FontChar ch :> f:chars first num
      if exists:ch # and cur_x+f:x0<img:x1 and cur_x+f:x1>img:x0 and cur_y+f:y0<img:y1 and cur_y+f:y1>img:y0
        var Pointer:Address rch :> rf:chars first num
        if not exists:rch
          rf:chars insert num (f rasterize num rsize)
          rch :> rf:chars first num
        img rcharacter rch (img index_x cur:xt) (img index_y cur:yt) color
      eif auto_accent and { var Pointer:FontAccent a :> accents first num ; exists a }
        var Pointer:FontChar base :> f:chars first a:base
        var Pointer:FontChar accent :> f:chars first a:accent
        if exists:base and exists:accent
          var Pointer:Address rch :> rf:chars first a:base
          if not exists:rch
            rf:chars insert a:base (f rasterize a:base rsize)
            rch :> rf:chars first a:base
          img rcharacter rch (img index_x cur:xt) (img index_y cur:yt) color
          var Pointer:Address rch :> rf:chars first a:accent
          if not exists:rch
            rf:chars insert a:accent (f rasterize a:accent rsize)
            rch :> rf:chars first a:accent
          img rcharacter rch (img index_x cur:xt) (img index_y cur:yt) color
    else
      img character f num cur color
    var Vector2 v := f vector num
    if kerning<>null
      v := (kerning map Float i)*v
    if spacing<>1
      v := spacing*v
    v := cur v ; cur xt += v x ; cur yt += v y
  if raster_fonts and raster
    rf:sem release


method f draw text img x y scale extra_spacing_x extra_spaci
  arg_rw Font f ; arg Str text ; oarg_rw ImagePrototype img 
  f draw text:characters text:len 1 img x y scale extra_spac
method img text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str txt ; arg Font f ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
  img text txt:characters txt:len 1 (addressof:f map Font)  kerning length t color false


method f draw text img x y scale color
  arg_rw Font f ; arg Str text ; oarg_rw ImagePrototype img 
  f draw text:characters text:len 1 img x y scale 0 0 color 
method img text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str32 txt ; arg Font f ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
  img text txt:characters txt:len 4 (addressof:f map Font)  kerning length t color false


method f draw text img x y scale extra_spacing_x extra_spaci
  arg_rw Font f ; arg Str32 text ; oarg_rw ImagePrototype im
  f draw text:characters text:len 4 img x y scale extra_spac
method img fast_text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str txt ; arg Font f ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
  img text txt:characters txt:len 1 (addressof:f map Font)  kerning length t color true


method f draw text img x y scale color
  arg_rw Font f ; arg Str32 text ; oarg_rw ImagePrototype im
  f draw text:characters text:len 4 img x y scale 0 0 color 
method img fast_text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str32 txt ; arg Font f ; arg Address kerning ; arg Float length ; arg Transform2 t ; arg Address color
  img text txt:characters txt:len 4 (addressof:f map Font) kerning length t color true


export '. text' '. fast_text'


method f width buffer length csize scale -> w
  arg Font f ; arg Address buffer ; arg Int length csize ; a
  w := 0
  for (var Int i) 0 length-1
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    var Pointer:FontChar ch :> f:chars first num
    if auto_accent and not exists:ch and { var Pointer:FontA
      ch :> f:chars first a:base
    if exists:ch
      w += ch:vector:x*scale


method f width text scale -> w
  arg Font f ; arg Str text ; arg Float scale w
  w := f width text:characters text:len 1 scale
#-------------------------------------------------------------------------
# Font caching


method f width text scale -> w
  arg Font f ; arg Str32 text ; arg Float scale w
  w := f width text:characters text:len 4 scale


module "/pliant/appli/database.pli"
module "/pliant/admin/file.pli"


method f box buffer length csize x y scale x0 y0 x1 y1
  arg Font f ; arg Address buffer ; arg Int length csize ; a
  x0 := x
  y0 := y+f:y0*scale
  x1 := x
  y1 := y+f:y1*scale
  for (var Int i) 0 length-1
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    var Pointer:FontChar ch :> f:chars first num
    if auto_accent and not exists:ch and { var Pointer:FontA
      ch :> f:chars first a:base
    if exists:ch
      x1 += ch:vector:x*scale


method f box text x y scale x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Float x y scale x y ; arg_
  f box text:characters text:len 1 x y scale x0 y0 x1 y1
public


method f box text x y scale x0 y0 x1 y1
  arg Font f ; arg Str32 text ; arg Float x y scale x y ; ar
  f box text:characters text:len 4 x y scale x0 y0 x1 y1
  type FontFile
    field Str family
    field Str fullname
    field Str psname
    field Str file


  type FontDatabase
    field Set:FontFile font # key is md5
    field (Set Set:Void) family
    field Set:Str fullname
    field Set:Str psname
    field Set:Str alias
  
  (gvar Database:FontDatabase font_database) load "security:/font.pdb" mount "/pliant/font"


export Font font_postscript '. family' '. name' '. psname'
export '. weight' '. italic' '. fixed'
export '. draw' '. width' '. box'
export postscript_glyphs


function font_scan path
  arg Str path
  var Array:FileInfo files := file_list path extended+recursive
  for (var Int i) 0 files:size-1
    if files:i:extension=".pfb" and not files:i:is_link
      var Link:Font f :> font_postscript files:i:name
      if exists:f
        font_database:data:font create f:md5
        var Data:FontFile ffile :> font_database:data:font f:md5
        ffile family := f family
        ffile fullname := f fullname
        ffile psname := f psname
        ffile file := f file
        console f:fullname eol
        font_database:data:family create f:family
        (font_database:data:family f:family) create f:md5
        font_database:data:fullname create f:fullname
        font_database:data:fullname f:fullname := f md5
        font_database:data:psname create f:psname
        font_database:data:psname f:psname := f md5




function font name -> font
  arg Str name ; arg Link:Font font
  var Data:FontFile f :> font_database:data:font name # md5
  if not exists:f
    f :> font_database:data:font font_database:data:psname:name
  if not exists:f
    f :> font_database:data:font font_database:data:fullname:name
  if not exists:f
    f :> font_database:data:font font_database:data:alias:name
  if exists:f
    if (cache_open "/pliant/font/"+keyof:f Font ((addressof Link:Font font) map Link:CachePrototype))
      if (font load_postscript f:file)=success
        cache_ready ((addressof Link:Font font) map Link:CachePrototype)
      else
        cache_cancel ((addressof Link:Font font) map Link:CachePrototype)
        font :> null map Font
  else
    font :> null map Font




export font_scan font