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


method fs open name options flags stream support -> status
  oarg_rw PfbFileSystem fs ; arg Str name options ; arg Int 
abstract
  [Loading and rendering a PostScript Type 1 font]


method fs open name options flags stream support -> status
  oarg_rw PfbFileSystem fs ; arg Str name options ; arg Int 
  var Link:Stream s :> new Stream
  s open name options (flags .and. in+out+append+safe)
  if s=failure
    return failure
  var Link:Stream s
  if exists:support
    s :> support
  else
    s :> new Stream
    s open name options (flags .and. in+out+append+safe)
    if s=failure
      return failure
  var Link:PfbStreamDriver drv :> new PfbStreamDriver
  drv src :> s ; drv eof := false
  drv er := 55665
  drv lenIV := 4
  drv enb := 0 ; drv cnb := 0
  drv first := true
  drv buffer := memory_allocate 2^16 addressof:drv ; drv buf
  stream stream_driver :> drv
  status := success



  type Font
    inherit CachePrototype
    field (Dictionary Int FontChar) chars
  var Link:PfbStreamDriver drv :> new PfbStreamDriver
  drv src :> s ; drv eof := false
  drv er := 55665
  drv lenIV := 4
  drv enb := 0 ; drv cnb := 0
  drv first := true
  drv buffer := memory_allocate 2^16 addressof:drv ; drv buf
  stream stream_driver :> drv
  status := success



  type Font
    inherit CachePrototype
    field (Dictionary Int FontChar) chars
    field Float x0 y0 x1 y1 <- 0
    field Vector2 vector <- (vector 1 0)
    field Float bbox_x0 bbox_y0 bbox_x1 bbox_y1 <- 0
    field Str file
    # Pliant way to identify
    field Str family
    field Str fullname
    field Str psname
    field Str file
    # Pliant way to identify
    field Str family
    field Str fullname
    field Str psname
    field Str md5
    field Str id
    # extra informations
    field Array:Int encoding
    field Array:Int encoding
    field Str options
    field CBool fixed <- false
    if type1details
      field Str weight
      field Float italic <- 0
    if type1details
      field Str weight
      field Float italic <- 0
      field CBool fixed <- false





function init_bbox x0 y0 x1 y1
  arg_w Float x0 y0 x1 y1
  x0 := float_max
  y0 := float_max
  x1 := float_min
  y1 := float_min
  
function update_bbox x0 y0 x1 y1 xx0 yy0 xx1 yy1
  arg_rw Float x0 y0 x1 y1 ; arg Float xx0 yy0 xx1 yy1
  x0 := min x0 xx0
  y0 := min y0 yy0
  x1 := max x1 xx1
  y1 := max y1 yy1

function terminate_bbox x0 y0 x1 y1
  arg_rw Float x0 y0 x1 y1
  if x0=float_max
    x0 := 0
    y0 := 0
    x1 := 0
    y1 := 0
  

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 bbox_x0 := float_max
  c bbox_y0 := float_max
  c bbox_x1 := float_min
  c bbox_y1 := float_min
  c:vector x /= 1000 ; c:vector y /= 1000
  init_bbox c:bbox_x0 c:bbox_y0 c:bbox_x1 c:bbox_y1
  var Int i := 0
  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
      crv bbox (var Float x0) (var Float y0) (var Float x1) 
  var Int i := 0
  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
      crv bbox (var Float x0) (var Float y0) (var Float x1) 
      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
      update_bbox c:bbox_x0 c:bbox_y0 c:bbox_x1 c:bbox_y1 x0 y0 x1 y1
      i += 1
    else
      for (var Int j) i c:curves:size-2
        swap (c:curves j) (c:curves j+1)
      c:curves size -= 1
      i += 1
    else
      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
  terminate_bbox c:bbox_x0 c:bbox_y0 c:bbox_x1 c:bbox_y1



method f load_postscript filename options -> status
  arg_rw Font f ; arg Str filename options ; arg Status stat



method f load_postscript filename options -> status
  arg_rw Font f ; arg Str filename options ; arg Status stat
  var Link:Stream s :> new Stream
  if false
  if false
    (var Stream s) open "pfb:"+filename in+safe
    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 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
  s open "pfb:"+filename in+safe
  if s=failure or not (s:readline parse "%!" any)
  if s=failure or not (s:readline parse "%!" any)
    (var Stream s) open filename in+safe
    s open filename in+safe
    if s=failure or not (s:readline parse "%!" any)
      return failure
  f file := filename
  var FontContext ctx ; ctx filename := filename
    if s=failure or not (s:readline parse "%!" any)
      return failure
  f file := filename
  var FontContext ctx ; ctx filename := filename
  # console filename eol
  while not s:atend
    var Str l := s readline
  while not s:atend
    var Str l := s readline
    # console "  " l eol
    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 fullname := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" 
      f family := n
    eif type1details and (l parse word:"/Weight" "(" any:(va
      f weight := n
    eif type1details and (l parse word:"/ItalicAngle" (var F
      f italic := ff
    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 fullname := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" 
      f family := n
    eif type1details and (l parse word:"/Weight" "(" any:(va
      f weight := n
    eif type1details and (l parse word:"/ItalicAngle" (var F
      f italic := ff
    eif type1details and (l parse word:"/isFixedPitch" any:(
    eif (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 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
      f bbox_x0 := ix0/1000
      f bbox_y0 := -iy1/1000
      f bbox_x1 := ix1/1000
      f bbox_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
    eif (l parse word:"dup" (var Int i) "/" any:(var Str n) 
      var Pointer:Int num :> postscript_glyphs first n
      if i>=0 and i<256 and exists:num
    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
    eif (l parse word:"dup" (var Int i) "/" any:(var Str n) 
      var Pointer:Int num :> postscript_glyphs first n
      if i>=0 and i<256 and exists:num
        if f:encoding:size=0
          f:encoding size := 256
          for (var Int j) 0 255
            f:encoding j := undefined
        while f:encoding:size<=i
          f:encoding += undefined
        f:encoding i := num
    else
      void
      # console "font line " l eol
  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
        f:chars insert num new_ch
    else
      void
      # console "unsupported glyph " def eol
        f:encoding i := num
    else
      void
      # console "font line " l eol
  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
        f:chars insert num new_ch
    else
      void
      # console "unsupported glyph " def eol
  if f:x0=0 and f:y0=0 and f:x1=0 and f:y1=0
  if f:bbox_x0=0 and f:bbox_y0=0 and f:bbox_x1=0 and f:bbox_y1=0
    each ch f:chars
      for (var Int j) 0 ch:curves:size-1
        ch:curves:j bbox (var Float x0) (var Float y0) (var 
    each ch f:chars
      for (var Int j) 0 ch:curves:size-1
        ch:curves:j bbox (var Float x0) (var Float y0) (var 
        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 x0=defined
          update_bbox f:bbox_x0 f:bbox_y0 f:bbox_x1 f:bbox_y1 x0 y0 x1 y1
  if (options option "fixed")
    f fixed := true
    var Pointer:FontChar ch :> f:chars first " ":number
    if exists:ch
      f vector := ch vector
  f id := file_md5_hexa_signature filename
  if verbose
  if verbose
    console "  loaded font " f:fullname eol
    console "  loaded font " f:fullname " from file " f:file eol
  status := success


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:FontAcc
    ch :> f:chars first a:base
  if exists:ch
    v := ch vector
  else
  status := success


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:FontAcc
    ch :> f:chars first a:base
  if exists:ch
    v := ch vector
  else
    v := vector 0 0
    v := f vector

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:FontAcc
    ch :> f:chars first a:base
  if exists:ch
    x0 := ch bbox_x0 ; y0 := ch bbox_y0 ; x1 := ch bbox_x1 ;
  else

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:FontAcc
    ch :> f:chars first a:base
  if exists:ch
    x0 := ch bbox_x0 ; y0 := ch bbox_y0 ; x1 := ch bbox_x1 ;
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0
    x0 := f bbox_x0 ; y0 := f bbox_y0 ; x1 := f bbox_x1 ; y1 := f bbox_y1




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



export '. curves' '. vector' '. bbox'



function character_number buffer i csize -> num
  arg Address buffer ; arg Int i csize num
  if csize=1
    num := buffer map uInt8 i
  eif csize=4
    num := buffer map Int32 i

method f vector buffer count csize kerning -> v
  arg Font f ; arg Address buffer ; arg Int count csize ; ar
method f vector buffer count csize kerning -> v
  arg Font f ; arg Address buffer ; arg Int count csize ; ar
  if f:fixed and kerning=null
    return count*f:vector
  v := vector 0 0
  for (var Int i) 0 count-1
  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:FontA
      ch :> f:chars first a:base
    if exists:ch
      if kerning<>null
        v += (kerning map Float i)*ch:vector
      else
        v += ch:vector
    if kerning<>null
      v += (kerning map Float i)*f:vector
    v += f vector (character_number buffer i csize)


method f vector text kerning -> v
  arg Font f ; arg Str text ; arg Address kerning ; arg Vector2 v
  v := f vector text:characters text:len 1 kerning

method f vector text kerning -> v
  arg Font f ; arg Str32 text ; arg Address kerning ; arg Vector2 v
  v := f vector text:characters text:len 4 kerning


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


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


method f bbox text kerning length x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Address kerning ; arg Floa
  if text:len<>0
    var Vector2 v := f vector text:characters text:len 1 ker
    x0 := 0 ; y0 := f y0 ; x1 := v x ; y1 := f y1 # FIXME
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0
  if length<>undefined
    x1 := length


method f bbox text kerning length x0 y0 x1 y1
  arg Font f ; arg Str32 text ; arg Address kerning ; arg Fl
  if text:len<>0
    var Vector2 v := f vector text:characters text:len 4 ker
    x0 := 0 ; y0 := f y0 ; x1 := v x ; y1 := f y1 # FIXME
public
  constant bbox_l 1 # lengthwise optimised
  constant bbox_h 2 # orthogonal optimised

method f bbox buffer count csize kerning flags x0 y0 x1 y1
  arg Font f ; arg Address buffer ; arg Int count csize ; arg Address kerning ; arg Int flags ; arg_w Float x0 y0 x1 y1
  init_bbox x0 y0 x1 y1
  if (flags .and. bbox_l)=0 or count=0
    var Vector2 v := f vector buffer count csize kerning
    update_bbox x0 y0 x1 y1 0 0 v:x v:y
  eif (flags .and. bbox_h)=0
    f bbox (character_number buffer 0 csize) (var Float cx0) (var Float cy0) (var Float cx1) (var Float cy1)
    update_bbox x0 y0 x1 y1 cx0 cy0 cx1 cy1
    var Vector2 v := f vector buffer count-1 csize kerning
    if kerning<>null
      v += (kerning map Float count-1)*f:vector
    f bbox (character_number buffer count-1 csize) (var Float cx0) (var Float cy0) (var Float cx1) (var Float cy1)
    update_bbox x0 y0 x1 y1 v:x+cx0 v:y+cy0 v:x+cx1 v:y+cy1
  if (flags .and. bbox_h)=0
    if f:vector:y<>0
      x0 := f bbox_x0
      x1 := f bbox_x1
    if f:vector:x<>0
      y0 := f bbox_y0
      y1 := f bbox_y1
  else
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0
  if length<>undefined
    x1 := length
    var Vector2 v := vector 0 0
    for (var Int i) 0 count-1
      if kerning<>null
        v += (kerning map Float count-1)*f:vector
      var Int num := character_number buffer i csize
      f bbox num (var Float cx0) (var Float cy0) (var Float cx1) (var Float cy1)
      update_bbox x0 y0 x1 y1 v:x+cx0 v:y+cy0 v:x+cx1 v:y+cy1
      v += f vector num
  terminate_bbox x0 y0 x1 y1


export '. length' '. bbox'
method f bbox text kerning flags x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Address kerning ; arg Int flags ; arg_w Float x0 y0 x1 y1
  f bbox text:characters text:len 1 kerning flags x0 y0 x1 y1
  if false
    x0 := 0
    y0 := f bbox_y0
    x1 := (f vector text:characters text:len 1 kerning):x
    y1 := f bbox_y1


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
  f bbox text:characters text:len 1 kerning 0 x0 y0 x1 y1


method f bbox text kerning flags x0 y0 x1 y1
  arg Font f ; arg Str32 text ; arg Address kerning ; arg Int flags ; arg_w Float x0 y0 x1 y1
  f bbox text:characters text:len 4 kerning flags x0 y0 x1 y1
  if false
    x0 := 0
    y0 := f bbox_y0
    x1 := (f vector text:characters text:len 4 kerning):x
    y1 := f bbox_y1

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
  f bbox text:characters text:len 4 kerning 0 x0 y0 x1 y1

export '. length' '. vector' '. bbox'


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



method img character f char_num t color
  oarg_rw ImagePrototype img ; arg Font f ; arg Int char_num
  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 
    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
#-----------------------------------------------------------
# Drawing text



method img character f char_num t color
  oarg_rw ImagePrototype img ; arg Font f ; arg Int char_num
  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 
    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
  
  
if raster_fonts



if raster_anti_aliasing>1

  function pixel_mixte pixel color pixel_size opacity
    arg Address pixel color ; arg Int pixel_size opacity
    for (var Int i) 0 pixel_size-1
      pixel map uInt8 i := ((pixel map uInt8 i)*(255-opacity

  method f rasterize char_num rsize -> buf
  method f rasterize1 char_num rsize -> buf
    arg Font f ; arg Int char_num ; arg Int rsize ; arg Addr
    arg Font f ; arg Int char_num ; arg Int rsize ; arg Addr
    var Float res := rsize/(f:y1-f:y0)
    var Float res := rsize/(f:bbox_y1-f:bbox_y0)
    var Int aa := 4
    var Int threshold := aa*aa\2
    var Link:ImagePixmap pixmap :> new ImagePixmap
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype f:x0 f:y0 f:x1 f:y1 (cast 
    pixmap setup (image_prototype f:bbox_x0 f:bbox_y0 f:bbox_x1 f:bbox_y1 (cast (f:bbox_x1-f:bbox_x0)*res Int)*aa (cast (f:bbox_y1-f:bbox_y0)*res Int)*aa color_gamut:"grey") ""
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    final bind pixmap raster_anti_aliasing raster_anti_alias
    final bind pixmap aa 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 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 uInt8 color := aa*aa
    pixmap character f char_num transform addressof:color
    var Int reserved := 2*rsize*3+uInt:size ; var Int used :
    buf := memory_allocate reserved null
    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
    var Int cx := (cast -(f:bbox_x0)*res Int) ; var Int cy := (cast -(f:bbox_y0)*res Int)
    for (var Int y) 0 final:size_y-1
      final read 0 y final:size_x linebuf
      var Int x0 := 0
      part segment
    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
        while x0<final:size_x and (linebuf map uInt8 x0)<threshold
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)<>0
        while x1<final:size_x and (linebuf map uInt8 x1)>=threshold
          x1 += 1
          x1 += 1
        while used+3+(x1-x0)+uInt:size>reserved
        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 
          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
    
        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
    
  method img rcharacter buf ix iy color
  method img rcharacter1 buf ix iy color
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int i
    var Address c := buf ; var Int x := ix ; var Int y := iy
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int i
    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
    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

else

  method f rasterize char_num rsize -> buf
          img fill x0 y x1-x0 color
  
  
  function pixel_mixte pixel color pixel_size opacity
    arg Address pixel color ; arg Int pixel_size opacity
    for (var Int i) 0 pixel_size-1
      pixel map uInt8 i := ((pixel map uInt8 i)*(255-opacity)+(color map uInt8 i)*opacity)\255
  
  method f rasterize2 char_num rsize -> buf
    arg Font f ; arg Int char_num ; arg Int rsize ; arg Addr
    arg Font f ; arg Int char_num ; arg Int rsize ; arg Addr
    var Float res := rsize/(f:y1-f:y0)
    var Int aa := 4
    var Int threshold := aa*aa\2
    var Float res := rsize/(f:bbox_y1-f:bbox_y0)
    var Link:ImagePixmap pixmap :> new ImagePixmap
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype f:x0 f:y0 f:x1 f:y1 (cast 
    pixmap setup (image_prototype f:bbox_x0 f:bbox_y0 f:bbox_x1 f:bbox_y1 (cast (f:bbox_x1-f:bbox_x0)*res Int)*raster_anti_aliasing (cast (f:bbox_y1-f:bbox_y0)*res Int)*raster_anti_aliasing color_gamut:"grey") ""
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    var Link:ImageAntiAliasing final :> new ImageAntiAliasin
    final bind pixmap aa
    final bind pixmap raster_anti_aliasing raster_anti_aliasing
    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 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 uInt8 color := 255
    pixmap character f char_num transform addressof:color
    var Int reserved := 2*rsize*3+uInt:size ; var Int used :
    buf := memory_allocate reserved null
    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
    var Int cx := (cast -(f:bbox_x0)*res Int) ; var Int cy := (cast -(f:bbox_y0)*res Int)
    for (var Int y) 0 final:size_y-1
      final read 0 y final:size_x linebuf
      var Int x0 := 0
      part segment
    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
        while x0<final:size_x and (linebuf map uInt8 x0)=0
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)>=th
        while x1<final:size_x and (linebuf map uInt8 x1)<>0
          x1 += 1
          x1 += 1
        if used+3+uInt:size>reserved
        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 
          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 uInt8 x ; used += 1
        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
    
        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
    
  method img rcharacter buf ix iy color
  method img rcharacter2 buf ix iy color
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int i
    var Address c := buf ; var Int x := ix ; var Int y := iy
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int i
    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
    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 (var Int count)
          if adr<>null
            var Address pixel := adr ; var Address stop := pixel translate Byte (x1-x0)*psize
            var Address opacity := c translate uInt8 x0-x
            while pixel<>stop
              pixel_mixte pixel color psize (opacity map uInt8)
              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 char_num rsize level -> buf
    arg Font f ; arg Int char_num ; arg Int rsize level ; arg Address buf
    if level=1
      buf := f rasterize1 char_num rsize
    else
      buf := f rasterize2 char_num rsize

  method img rcharacter buf ix iy color level
    oarg_rw ImagePrototype img ; arg Address buf ; arg Int ix iy ; arg Address color ; arg Int level
    if level=1
      img rcharacter1 buf ix iy color
    else
      img rcharacter2 buf ix iy color


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_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 img text buffer count csize f kerning length t color 
  oarg_rw ImagePrototype img ; arg Address buffer ; arg Int 
  var Float spacing := 1
  if length=defined
    spacing := length/(f vector buffer count csize kerning):
    if spacing=undefined
      spacing := 1
method img text buffer count csize f kerning t color speedup
  oarg_rw ImagePrototype img ; arg Address buffer ; arg Int count csize ; arg_rw Font f ; arg Address kerning ; arg Transform2 t ; arg Address color ; arg Int speedup
  if raster_fonts
    var CBool raster := false
  if raster_fonts
    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)
    if speedup>0 and t:level<=transform_scale and t:xx=t:yy
      var Int rsize := cast t:yy*(f:bbox_y1-f:bbox_y0)/(img:y1-img:y0)*img:size_y Int
      if rsize<=raster_maximum_size
        var Link:FontRaster rf
      if rsize<=raster_maximum_size
        var Link:FontRaster rf
        if (cache_open "/pliant/fontr/"+string:rsize+"/"+f:f
        if (cache_open "/pliant/fontr"+string:speedup+"/"+string:rsize+"/"+f:id FontRaster ((addressof Link:FontRaster rf) map Link:CachePrototype))
          cache_ready ((addressof Link:FontRaster rf) map Li
        rf:sem request
        raster := true
  var Transform2 cur := t
  for (var Int i) 0 count-1
          cache_ready ((addressof Link:FontRaster rf) map Li
        rf:sem request
        raster := true
  var Transform2 cur := t
  for (var Int i) 0 count-1
    if kerning<>null
      var Vector2 v := cur (kerning map Float i)*f:vector ; cur xt += v x ; cur yt += v y
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    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>im
        var Pointer:Address rch :> rf:chars first num
        if not exists:rch
    var Int num
    if csize=1
      num := buffer map uInt8 i
    eif csize=4
      num := buffer map Int32 i
    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>im
        var Pointer:Address rch :> rf:chars first num
        if not exists:rch
          rf:chars insert num (f rasterize num rsize)
          rf:chars insert num (f rasterize num rsize speedup)
          rch :> rf:chars first num
          rch :> rf:chars first num
        img rcharacter rch (img index_x cur:xt) (img index_y
        img rcharacter rch (img index_x cur:xt) (img index_y cur:yt) color speedup
      eif auto_accent and { var Pointer:FontAccent a :> acce
        var Pointer:FontChar base :> f:chars first a:base
        var Pointer:FontChar accent :> f:chars first a:accen
        if exists:base and exists:accent
          var Pointer:Address rch :> rf:chars first a:base
          if not exists:rch
      eif auto_accent and { var Pointer:FontAccent a :> acce
        var Pointer:FontChar base :> f:chars first a:base
        var Pointer:FontChar accent :> f:chars first a:accen
        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
            rf:chars insert a:base (f rasterize a:base rsize speedup)
            rch :> rf:chars first a:base
            rch :> rf:chars first a:base
          img rcharacter rch (img index_x cur:xt) (img index
          img rcharacter rch (img index_x cur:xt) (img index_y cur:yt) color speedup
          var Pointer:Address rch :> rf:chars first a:accent
          if not exists:rch
          var Pointer:Address rch :> rf:chars first a:accent
          if not exists:rch
            rf:chars insert a:accent (f rasterize a:accent r
            rf:chars insert a:accent (f rasterize a:accent rsize speedup)
            rch :> rf:chars first a:accent
            rch :> rf:chars first a:accent
          img rcharacter rch (img index_x cur:xt) (img index
          img rcharacter rch (img index_x cur:xt) (img index_y cur:yt) color speedup
    else
      img character f num cur 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
    var Vector2 v := cur (f vector num) ; cur xt += v x ; cur yt += v y
  if raster_fonts and raster
    rf:sem release

  if raster_fonts and raster
    rf:sem release

method img text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str txt ; arg Font f ; ar
  img text txt:characters txt:len 1 (addressof:f map Font)  
method img text txt f kerning t color
  oarg_rw ImagePrototype img ; arg Str txt ; arg Font f ; arg Address kerning ; arg Transform2 t ; arg Address color
  img text txt:characters txt:len 1 (addressof:f map Font) kerning t color 0


method img text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str32 txt ; arg Font f ; 
  img text txt:characters txt:len 4 (addressof:f map Font)  
method img text txt f kerning t color
  oarg_rw ImagePrototype img ; arg Str32 txt ; arg Font f ; arg Address kerning ; arg Transform2 t ; arg Address color
  img text txt:characters txt:len 4 (addressof:f map Font) kerning t color 0


method img fast_text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str txt ; arg Font f ; ar
  img text txt:characters txt:len 1 (addressof:f map Font)  
method img text txt f kerning t color speedup
  oarg_rw ImagePrototype img ; arg Str txt ; arg Font f ; arg Address kerning ; arg Transform2 t ; arg Address color ; arg Int speedup
  img text txt:characters txt:len 1 (addressof:f map Font) kerning t color speedup


method img fast_text txt f kerning length t color
  oarg_rw ImagePrototype img ; arg Str32 txt ; arg Font f ; 
  img text txt:characters txt:len 4 (addressof:f map Font) k
method img text txt f kerning t color speedup
  oarg_rw ImagePrototype img ; arg Str32 txt ; arg Font f ; arg Address kerning ; arg Transform2 t ; arg Address color ; arg Int speedup
  img text txt:characters txt:len 4 (addressof:f map Font) kerning t color speedup


export '. text' '. fast_text'
export '. text'






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



  type FontFile
    field Str family
    field Str fullname
    field Str psname
    field Str file
module "/pliant/admin/file.pli"



  type FontFile
    field Str family
    field Str fullname
    field Str psname
    field Str file
    field Str options


function font_scan path
  arg Str path
  var Array:FileInfo files := file_list path extended+recurs
  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


function font_scan path
  arg Str path
  var Array:FileInfo files := file_list path extended+recurs
  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
        font_database:data:font create f:id
        var Data:FontFile ffile :> font_database:data:font f:id
        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
        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:family f:family) create f:id
        font_database:data:fullname create f:fullname
        font_database:data:fullname create f:fullname
        font_database:data:fullname f:fullname := f md5
        font_database:data:fullname f:fullname := f id
        font_database:data:psname create f:psname
        font_database:data:psname create f:psname
        font_database:data:psname f:psname := f md5
        font_database:data:psname f:psname := f id


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:n
  if not exists:f
    f :> font_database:data:font font_database:data:fullname
  if not exists:f
    f :> font_database:data:font font_database:data:alias:na
  if exists:f
    if (cache_open "/pliant/font/"+keyof:f Font ((addressof 


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:n
  if not exists:f
    f :> font_database:data:font font_database:data:fullname
  if not exists:f
    f :> font_database:data:font font_database:data:alias:na
  if exists:f
    if (cache_open "/pliant/font/"+keyof:f Font ((addressof 
      if (font load_postscript f:file "")=success
      if (font load_postscript f:file f:options)=success
        cache_ready ((addressof Link:Font font) map Link:Cac
      else
        cache_cancel ((addressof Link:Font font) map Link:Ca
        font :> null map Font
  else
    font :> null map Font



        cache_ready ((addressof Link:Font font) map Link:Cac
      else
        cache_cancel ((addressof Link:Font font) map Link:Ca
        font :> null map Font
  else
    font :> null map Font