Patch title: Release 93 bulk changes
Abstract:
File: /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
# 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/math/vector.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/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_anti_aliasing 4
constant auto_accent true
constant type1details 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


type PfbStreamDriver
  field Link:Stream src ; field CBool eof
  field uInt16 er cr
  field Int lenIV enb cnb
  field CBool first
  field Address buffer ; field Int buflen
StreamDriver maybe PfbStreamDriver


type PfbFileSystem
  void
FileSystem maybe PfbFileSystem


method fs open name options flags stream support -> status
  oarg_rw PfbFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  var Link:Stream 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 buflen := 0
  stream stream_driver :> drv
  status := success


method drv edecrypt cipher -> plain
  arg_rw PfbStreamDriver drv ; arg Int cipher plain
  implicit drv
    plain := cipher .xor. (er \ 2^8)
    er := ( ((cast cipher uInt) + er) * 52845 + 22719 ) .and. 2^16-1

method drv cdecrypt cipher -> plain
  arg_rw PfbStreamDriver drv ; arg Int cipher plain
  implicit drv
    plain := cipher .xor. (cr \ 2^8)
    cr := ( ((cast cipher uInt) + cr) * 52845 + 22719 ) .and. 2^16-1


method drv egetc -> c
  arg_rw PfbStreamDriver drv ; arg Int c
  drv:src raw_read addressof:(var uInt8 cipher) 1
  drv enb -= 1
  c := drv edecrypt cipher

method drv cgetc -> c
  arg_rw PfbStreamDriver drv ; arg Int c
  drv:src raw_read addressof:(var uInt8 cipher) 1
  drv enb -= 1 ; drv cnb -= 1
  c := drv cdecrypt (drv edecrypt cipher)


method drv output c
  arg_rw PfbStreamDriver drv ; arg Int c
  drv:buffer map uInt8 drv:buflen := c
  drv buflen += 1

method drv atoken
  arg_rw PfbStreamDriver drv
  drv:src raw_read addressof:(var uInt8 c) 1
  if c=80h
    drv:src raw_read addressof:(var uInt8 mode) 1
    if mode=01h
      drv:src raw_read addressof:(var uInt32 u) uInt32:size
    eif mode=02h
      drv:src raw_read addressof:(var uInt32 u) uInt32:size
      drv enb := u
      if drv:first
        for (var Int i) 0 3
          drv egetc
        drv first := false
    eif mode=03h
      drv eof := true
  else
    drv output c

method drv etoken
  arg_rw PfbStreamDriver drv
  drv output drv:egetc

method drv output string
  arg_rw PfbStreamDriver drv ; arg Str string
  drv output " ":number
  for (var Int i) 0 string:len-1
    drv output string:i:number

method drv ctoken
  arg_rw PfbStreamDriver drv
  var Int b := drv cgetc
  if b>=32
    var Int val
    if b<=246
      val := b - 139
    eif b<=250
      val := (b - 247)*256 + 108 + drv:cgetc
    eif b<=254
      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"
      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
    

method drv read adr mini maxi -> red
  oarg_rw PfbStreamDriver drv ; arg Address adr ; arg Int mini maxi red
  implicit drv
    while not src:atend and not eof and (buflen=0 or buflen<mini or { var Int c := buffer map uInt8 buflen-1 ; c<>0Dh and c<>0Ah })
      if cnb<>0 and enb<>0
        ctoken
      eif enb<>0
        etoken
      else
        atoken
      if buflen>=4
        (var Str s) set (buffer translate Byte buflen-4) 4 false
        if s=" -| " or s=" RD "
          var Int i := buflen-5
          while i>0 and { var Int c := buffer map uInt8 i ; c>="0":number and c<="9":number }
            i -= 1
          s set (buffer translate Byte i) buflen-i-4 false
          s parse cnb
          buflen := i ; output "{"
          cr := 4330
          for (var Int i) 0 lenIV-1
            cgetc
    if buflen>0 and { var Int c := buffer map uInt8 buflen-1 ; c=0Ah or c=0Dh }
      buffer map uInt8 buflen-1 := 0Dh
      buffer map uInt8 buflen := 0Ah
      buflen += 1
    s set buffer buflen false
    if (s parse "/lenIV" (var Int n) any)
      lenIV := n
    red := min buflen maxi
    memory_copy buffer adr red
    buflen -= red
    memory_move (buffer translate Byte red) buffer buflen
   
            
method drv close -> status
  oarg_rw PfbStreamDriver drv ; arg ExtendedStatus status
  memory_free drv:buffer
  status := success

gvar PfbFileSystem pfb_file_system
pliant_multi_file_system mount "pfb:" "" pfb_file_system


#-------------------------------------------------------------------------
# Loading a PostScript Type 1 font


gvar (Dictionary Str Int) postscript_glyphs

function glyph name uv
  arg Str name ; arg Int uv
  postscript_glyphs insert name uv

glyph "A" 65
glyph "AE" 198
glyph "AEacute" 508
glyph "AEsmall" 63462
glyph "Aacute" 193
glyph "Aacutesmall" 63457
glyph "Abreve" 258
glyph "Acircumflex" 194
glyph "Acircumflexsmall" 63458
glyph "Acute" 63177
glyph "Acutesmall" 63412
glyph "Adieresis" 196
glyph "Adieresissmall" 63460
glyph "Agrave" 192
glyph "Agravesmall" 63456
glyph "Alpha" 913
glyph "Alphatonos" 902
glyph "Amacron" 256
glyph "Aogonek" 260
glyph "Aring" 197
glyph "Aringacute" 506
glyph "Aringsmall" 63461
glyph "Asmall" 63329
glyph "Atilde" 195
glyph "Atildesmall" 63459
glyph "B" 66
glyph "Beta" 914
glyph "Brevesmall" 63220
glyph "Bsmall" 63330
glyph "C" 67
glyph "Cacute" 262
glyph "Caron" 63178
glyph "Caronsmall" 63221
glyph "Ccaron" 268
glyph "Ccedilla" 199
glyph "Ccedillasmall" 63463
glyph "Ccircumflex" 264
glyph "Cdotaccent" 266
glyph "Cedillasmall" 63416
glyph "Chi" 935
glyph "Circumflexsmall" 63222
glyph "Csmall" 63331
glyph "D" 68
glyph "Dcaron" 270
glyph "Dcroat" 272
glyph "Delta" 8710
glyph "Delta" 916
glyph "Dieresis" 63179
glyph "DieresisAcute" 63180
glyph "DieresisGrave" 63181
glyph "Dieresissmall" 63400
glyph "Dotaccentsmall" 63223
glyph "Dsmall" 63332
glyph "E" 69
glyph "Eacute" 201
glyph "Eacutesmall" 63465
glyph "Ebreve" 276
glyph "Ecaron" 282
glyph "Ecircumflex" 202
glyph "Ecircumflexsmall" 63466
glyph "Edieresis" 203
glyph "Edieresissmall" 63467
glyph "Edotaccent" 278
glyph "Egrave" 200
glyph "Egravesmall" 63464
glyph "Emacron" 274
glyph "Eng" 330
glyph "Eogonek" 280
glyph "Epsilon" 917
glyph "Epsilontonos" 904
glyph "Esmall" 63333
glyph "Eta" 919
glyph "Etatonos" 905
glyph "Eth" 208
glyph "Ethsmall" 63472
glyph "Euro" 8364
glyph "F" 70
glyph "Fsmall" 63334
glyph "G" 71
glyph "Gamma" 915
glyph "Gbreve" 286
glyph "Gcaron" 486
glyph "Gcircumflex" 284
glyph "Gcommaaccent" 290
glyph "Gdotaccent" 288
glyph "Grave" 63182
glyph "Gravesmall" 63328
glyph "Gsmall" 63335
glyph "H" 72
glyph "H18533" 9679
glyph "H18543" 9642
glyph "H18551" 9643
glyph "H22073" 9633
glyph "Hbar" 294
glyph "Hcircumflex" 292
glyph "Hsmall" 63336
glyph "Hungarumlaut" 63183
glyph "Hungarumlautsmall" 63224
glyph "I" 73
glyph "IJ" 306
glyph "Iacute" 205
glyph "Iacutesmall" 63469
glyph "Ibreve" 300
glyph "Icircumflex" 206
glyph "Icircumflexsmall" 63470
glyph "Idieresis" 207
glyph "Idieresissmall" 63471
glyph "Idotaccent" 304
glyph "Ifraktur" 8465
glyph "Igrave" 204
glyph "Igravesmall" 63468
glyph "Imacron" 298
glyph "Iogonek" 302
glyph "Iota" 921
glyph "Iotadieresis" 938
glyph "Iotatonos" 906
glyph "Ismall" 63337
glyph "Itilde" 296
glyph "J" 74
glyph "Jcircumflex" 308
glyph "Jsmall" 63338
glyph "K" 75
glyph "Kappa" 922
glyph "Kcommaaccent" 310
glyph "Ksmall" 63339
glyph "L" 76
glyph "LL" 63167
glyph "Lacute" 313
glyph "Lambda" 923
glyph "Lcaron" 317
glyph "Lcommaaccent" 315
glyph "Ldot" 319
glyph "Lslash" 321
glyph "Lslashsmall" 63225
glyph "Lsmall" 63340
glyph "M" 77
glyph "Macron" 63184
glyph "Macronsmall" 63407
glyph "Msmall" 63341
glyph "Mu" 924
glyph "N" 78
glyph "Nacute" 323
glyph "Ncaron" 327
glyph "Ncommaaccent" 325
glyph "Nsmall" 63342
glyph "Ntilde" 209
glyph "Ntildesmall" 63473
glyph "Nu" 925
glyph "O" 79
glyph "OE" 338
glyph "OEsmall" 63226
glyph "Oacute" 211
glyph "Oacutesmall" 63475
glyph "Obreve" 334
glyph "Ocircumflex" 212
glyph "Ocircumflexsmall" 63476
glyph "Odieresis" 214
glyph "Odieresissmall" 63478
glyph "Ogoneksmall" 63227
glyph "Ograve" 210
glyph "Ogravesmall" 63474
glyph "Ohorn" 416
glyph "Ohungarumlaut" 336
glyph "Omacron" 332
glyph "Omega" 8486
glyph "Omega" 937
glyph "Omegatonos" 911
glyph "Omicron" 927
glyph "Omicrontonos" 908
glyph "Oslash" 216
glyph "Oslashacute" 510
glyph "Oslashsmall" 63480
glyph "Osmall" 63343
glyph "Otilde" 213
glyph "Otildesmall" 63477
glyph "P" 80
glyph "Phi" 934
glyph "Pi" 928
glyph "Psi" 936
glyph "Psmall" 63344
glyph "Q" 81
glyph "Qsmall" 63345
glyph "R" 82
glyph "Racute" 340
glyph "Rcaron" 344
glyph "Rcommaaccent" 342
glyph "Rfraktur" 8476
glyph "Rho" 929
glyph "Ringsmall" 63228
glyph "Rsmall" 63346
glyph "S" 83
glyph "SF010000" 9484
glyph "SF020000" 9492
glyph "SF030000" 9488
glyph "SF040000" 9496
glyph "SF050000" 9532
glyph "SF060000" 9516
glyph "SF070000" 9524
glyph "SF080000" 9500
glyph "SF090000" 9508
glyph "SF100000" 9472
glyph "SF110000" 9474
glyph "SF190000" 9569
glyph "SF200000" 9570
glyph "SF210000" 9558
glyph "SF220000" 9557
glyph "SF230000" 9571
glyph "SF240000" 9553
glyph "SF250000" 9559
glyph "SF260000" 9565
glyph "SF270000" 9564
glyph "SF280000" 9563
glyph "SF360000" 9566
glyph "SF370000" 9567
glyph "SF380000" 9562
glyph "SF390000" 9556
glyph "SF400000" 9577
glyph "SF410000" 9574
glyph "SF420000" 9568
glyph "SF430000" 9552
glyph "SF440000" 9580
glyph "SF450000" 9575
glyph "SF460000" 9576
glyph "SF470000" 9572
glyph "SF480000" 9573
glyph "SF490000" 9561
glyph "SF500000" 9560
glyph "SF510000" 9554
glyph "SF520000" 9555
glyph "SF530000" 9579
glyph "SF540000" 9578
glyph "Sacute" 346
glyph "Scaron" 352
glyph "Scaronsmall" 63229
glyph "Scedilla" 350
glyph "Scedilla" 63169
glyph "Scircumflex" 348
glyph "Scommaaccent" 536
glyph "Sigma" 931
glyph "Ssmall" 63347
glyph "T" 84
glyph "Tau" 932
glyph "Tbar" 358
glyph "Tcaron" 356
glyph "Tcommaaccent" 354
glyph "Tcommaaccent" 538
glyph "Theta" 920
glyph "Thorn" 222
glyph "Thornsmall" 63486
glyph "Tildesmall" 63230
glyph "Tsmall" 63348
glyph "U" 85
glyph "Uacute" 218
glyph "Uacutesmall" 63482
glyph "Ubreve" 364
glyph "Ucircumflex" 219
glyph "Ucircumflexsmall" 63483
glyph "Udieresis" 220
glyph "Udieresissmall" 63484
glyph "Ugrave" 217
glyph "Ugravesmall" 63481
glyph "Uhorn" 431
glyph "Uhungarumlaut" 368
glyph "Umacron" 362
glyph "Uogonek" 370
glyph "Upsilon" 933
glyph "Upsilon1" 978
glyph "Upsilondieresis" 939
glyph "Upsilontonos" 910
glyph "Uring" 366
glyph "Usmall" 63349
glyph "Utilde" 360
glyph "V" 86
glyph "Vsmall" 63350
glyph "W" 87
glyph "Wacute" 7810
glyph "Wcircumflex" 372
glyph "Wdieresis" 7812
glyph "Wgrave" 7808
glyph "Wsmall" 63351
glyph "X" 88
glyph "Xi" 926
glyph "Xsmall" 63352
glyph "Y" 89
glyph "Yacute" 221
glyph "Yacutesmall" 63485
glyph "Ycircumflex" 374
glyph "Ydieresis" 376
glyph "Ydieresissmall" 63487
glyph "Ygrave" 7922
glyph "Ysmall" 63353
glyph "Z" 90
glyph "Zacute" 377
glyph "Zcaron" 381
glyph "Zcaronsmall" 63231
glyph "Zdotaccent" 379
glyph "Zeta" 918
glyph "Zsmall" 63354
glyph "a" 97
glyph "aacute" 225
glyph "abreve" 259
glyph "acircumflex" 226
glyph "acute" 180
glyph "acutecomb" 769
glyph "adieresis" 228
glyph "ae" 230
glyph "aeacute" 509
glyph "afii00208" 8213
glyph "afii10017" 1040
glyph "afii10018" 1041
glyph "afii10019" 1042
glyph "afii10020" 1043
glyph "afii10021" 1044
glyph "afii10022" 1045
glyph "afii10023" 1025
glyph "afii10024" 1046
glyph "afii10025" 1047
glyph "afii10026" 1048
glyph "afii10027" 1049
glyph "afii10028" 1050
glyph "afii10029" 1051
glyph "afii10030" 1052
glyph "afii10031" 1053
glyph "afii10032" 1054
glyph "afii10033" 1055
glyph "afii10034" 1056
glyph "afii10035" 1057
glyph "afii10036" 1058
glyph "afii10037" 1059
glyph "afii10038" 1060
glyph "afii10039" 1061
glyph "afii10040" 1062
glyph "afii10041" 1063
glyph "afii10042" 1064
glyph "afii10043" 1065
glyph "afii10044" 1066
glyph "afii10045" 1067
glyph "afii10046" 1068
glyph "afii10047" 1069
glyph "afii10048" 1070
glyph "afii10049" 1071
glyph "afii10050" 1168
glyph "afii10051" 1026
glyph "afii10052" 1027
glyph "afii10053" 1028
glyph "afii10054" 1029
glyph "afii10055" 1030
glyph "afii10056" 1031
glyph "afii10057" 1032
glyph "afii10058" 1033
glyph "afii10059" 1034
glyph "afii10060" 1035
glyph "afii10061" 1036
glyph "afii10062" 1038
glyph "afii10063" 63172
glyph "afii10064" 63173
glyph "afii10065" 1072
glyph "afii10066" 1073
glyph "afii10067" 1074
glyph "afii10068" 1075
glyph "afii10069" 1076
glyph "afii10070" 1077
glyph "afii10071" 1105
glyph "afii10072" 1078
glyph "afii10073" 1079
glyph "afii10074" 1080
glyph "afii10075" 1081
glyph "afii10076" 1082
glyph "afii10077" 1083
glyph "afii10078" 1084
glyph "afii10079" 1085
glyph "afii10080" 1086
glyph "afii10081" 1087
glyph "afii10082" 1088
glyph "afii10083" 1089
glyph "afii10084" 1090
glyph "afii10085" 1091
glyph "afii10086" 1092
glyph "afii10087" 1093
glyph "afii10088" 1094
glyph "afii10089" 1095
glyph "afii10090" 1096
glyph "afii10091" 1097
glyph "afii10092" 1098
glyph "afii10093" 1099
glyph "afii10094" 1100
glyph "afii10095" 1101
glyph "afii10096" 1102
glyph "afii10097" 1103
glyph "afii10098" 1169
glyph "afii10099" 1106
glyph "afii10100" 1107
glyph "afii10101" 1108
glyph "afii10102" 1109
glyph "afii10103" 1110
glyph "afii10104" 1111
glyph "afii10105" 1112
glyph "afii10106" 1113
glyph "afii10107" 1114
glyph "afii10108" 1115
glyph "afii10109" 1116
glyph "afii10110" 1118
glyph "afii10145" 1039
glyph "afii10146" 1122
glyph "afii10147" 1138
glyph "afii10148" 1140
glyph "afii10192" 63174
glyph "afii10193" 1119
glyph "afii10194" 1123
glyph "afii10195" 1139
glyph "afii10196" 1141
glyph "afii10831" 63175
glyph "afii10832" 63176
glyph "afii10846" 1241
glyph "afii299" 8206
glyph "afii300" 8207
glyph "afii301" 8205
glyph "afii57381" 1642
glyph "afii57388" 1548
glyph "afii57392" 1632
glyph "afii57393" 1633
glyph "afii57394" 1634
glyph "afii57395" 1635
glyph "afii57396" 1636
glyph "afii57397" 1637
glyph "afii57398" 1638
glyph "afii57399" 1639
glyph "afii57400" 1640
glyph "afii57401" 1641
glyph "afii57403" 1563
glyph "afii57407" 1567
glyph "afii57409" 1569
glyph "afii57410" 1570
glyph "afii57411" 1571
glyph "afii57412" 1572
glyph "afii57413" 1573
glyph "afii57414" 1574
glyph "afii57415" 1575
glyph "afii57416" 1576
glyph "afii57417" 1577
glyph "afii57418" 1578
glyph "afii57419" 1579
glyph "afii57420" 1580
glyph "afii57421" 1581
glyph "afii57422" 1582
glyph "afii57423" 1583
glyph "afii57424" 1584
glyph "afii57425" 1585
glyph "afii57426" 1586
glyph "afii57427" 1587
glyph "afii57428" 1588
glyph "afii57429" 1589
glyph "afii57430" 1590
glyph "afii57431" 1591
glyph "afii57432" 1592
glyph "afii57433" 1593
glyph "afii57434" 1594
glyph "afii57440" 1600
glyph "afii57441" 1601
glyph "afii57442" 1602
glyph "afii57443" 1603
glyph "afii57444" 1604
glyph "afii57445" 1605
glyph "afii57446" 1606
glyph "afii57448" 1608
glyph "afii57449" 1609
glyph "afii57450" 1610
glyph "afii57451" 1611
glyph "afii57452" 1612
glyph "afii57453" 1613
glyph "afii57454" 1614
glyph "afii57455" 1615
glyph "afii57456" 1616
glyph "afii57457" 1617
glyph "afii57458" 1618
glyph "afii57470" 1607
glyph "afii57505" 1700
glyph "afii57506" 1662
glyph "afii57507" 1670
glyph "afii57508" 1688
glyph "afii57509" 1711
glyph "afii57511" 1657
glyph "afii57512" 1672
glyph "afii57513" 1681
glyph "afii57514" 1722
glyph "afii57519" 1746
glyph "afii57534" 1749
glyph "afii57636" 8362
glyph "afii57645" 1470
glyph "afii57658" 1475
glyph "afii57664" 1488
glyph "afii57665" 1489
glyph "afii57666" 1490
glyph "afii57667" 1491
glyph "afii57668" 1492
glyph "afii57669" 1493
glyph "afii57670" 1494
glyph "afii57671" 1495
glyph "afii57672" 1496
glyph "afii57673" 1497
glyph "afii57674" 1498
glyph "afii57675" 1499
glyph "afii57676" 1500
glyph "afii57677" 1501
glyph "afii57678" 1502
glyph "afii57679" 1503
glyph "afii57680" 1504
glyph "afii57681" 1505
glyph "afii57682" 1506
glyph "afii57683" 1507
glyph "afii57684" 1508
glyph "afii57685" 1509
glyph "afii57686" 1510
glyph "afii57687" 1511
glyph "afii57688" 1512
glyph "afii57689" 1513
glyph "afii57690" 1514
glyph "afii57694" 64298
glyph "afii57695" 64299
glyph "afii57700" 64331
glyph "afii57705" 64287
glyph "afii57716" 1520
glyph "afii57717" 1521
glyph "afii57718" 1522
glyph "afii57723" 64309
glyph "afii57793" 1460
glyph "afii57794" 1461
glyph "afii57795" 1462
glyph "afii57796" 1467
glyph "afii57797" 1464
glyph "afii57798" 1463
glyph "afii57799" 1456
glyph "afii57800" 1458
glyph "afii57801" 1457
glyph "afii57802" 1459
glyph "afii57803" 1474
glyph "afii57804" 1473
glyph "afii57806" 1465
glyph "afii57807" 1468
glyph "afii57839" 1469
glyph "afii57841" 1471
glyph "afii57842" 1472
glyph "afii57929" 700
glyph "afii61248" 8453
glyph "afii61289" 8467
glyph "afii61352" 8470
glyph "afii61573" 8236
glyph "afii61574" 8237
glyph "afii61575" 8238
glyph "afii61664" 8204
glyph "afii63167" 1645
glyph "afii64937" 701
glyph "agrave" 224
glyph "aleph" 8501
glyph "alpha" 945
glyph "alphatonos" 940
glyph "amacron" 257
glyph "ampersand" 38
glyph "ampersandsmall" 63270
glyph "angle" 8736
glyph "angleleft" 9001
glyph "angleright" 9002
glyph "anoteleia" 903
glyph "aogonek" 261
glyph "approxequal" 8776
glyph "aring" 229
glyph "aringacute" 507
glyph "arrowboth" 8596
glyph "arrowdblboth" 8660
glyph "arrowdbldown" 8659
glyph "arrowdblleft" 8656
glyph "arrowdblright" 8658
glyph "arrowdblup" 8657
glyph "arrowdown" 8595
glyph "arrowhorizex" 63719
glyph "arrowleft" 8592
glyph "arrowright" 8594
glyph "arrowup" 8593
glyph "arrowupdn" 8597
glyph "arrowupdnbse" 8616
glyph "arrowvertex" 63718
glyph "asciicircum" 94
glyph "asciitilde" 126
glyph "asterisk" 42
glyph "asteriskmath" 8727
glyph "asuperior" 63209
glyph "at" 64
glyph "atilde" 227
glyph "b" 98
glyph "backslash" 92
glyph "bar" 124
glyph "beta" 946
glyph "block" 9608
glyph "braceex" 63732
glyph "braceleft" 123
glyph "braceleftbt" 63731
glyph "braceleftmid" 63730
glyph "bracelefttp" 63729
glyph "braceright" 125
glyph "bracerightbt" 63742
glyph "bracerightmid" 63741
glyph "bracerighttp" 63740
glyph "bracketleft" 91
glyph "bracketleftbt" 63728
glyph "bracketleftex" 63727
glyph "bracketlefttp" 63726
glyph "bracketright" 93
glyph "bracketrightbt" 63739
glyph "bracketrightex" 63738
glyph "bracketrighttp" 63737
glyph "breve" 728
glyph "brokenbar" 166
glyph "bsuperior" 63210
glyph "bullet" 8226
glyph "c" 99
glyph "cacute" 263
glyph "caron" 711
glyph "carriagereturn" 8629
glyph "ccaron" 269
glyph "ccedilla" 231
glyph "ccircumflex" 265
glyph "cdotaccent" 267
glyph "cedilla" 184
glyph "cent" 162
glyph "centinferior" 63199
glyph "centoldstyle" 63394
glyph "centsuperior" 63200
glyph "chi" 967
glyph "circle" 9675
glyph "circlemultiply" 8855
glyph "circleplus" 8853
glyph "circumflex" 710
glyph "club" 9827
glyph "colon" 58
glyph "colonmonetary" 8353
glyph "comma" 44
glyph "commaaccent" 63171
glyph "commainferior" 63201
glyph "commasuperior" 63202
glyph "congruent" 8773
glyph "copyright" 169
glyph "copyrightsans" 63721
glyph "copyrightserif" 63193
glyph "currency" 164
glyph "cyrBreve" 63185
glyph "cyrFlex" 63186
glyph "cyrbreve" 63188
glyph "cyrflex" 63189
glyph "d" 100
glyph "dagger" 8224
glyph "daggerdbl" 8225
glyph "dblGrave" 63187
glyph "dblgrave" 63190
glyph "dcaron" 271
glyph "dcroat" 273
glyph "degree" 176
glyph "delta" 948
glyph "diamond" 9830
glyph "dieresis" 168
glyph "dieresisacute" 63191
glyph "dieresisgrave" 63192
glyph "dieresistonos" 901
glyph "divide" 247
glyph "dkshade" 9619
glyph "dnblock" 9604
glyph "dollar" 36
glyph "dollarinferior" 63203
glyph "dollaroldstyle" 63268
glyph "dollarsuperior" 63204
glyph "dong" 8363
glyph "dotaccent" 729
glyph "dotbelowcomb" 803
glyph "dotlessi" 305
glyph "dotlessj" 63166
glyph "dotmath" 8901
glyph "dsuperior" 63211
glyph "e" 101
glyph "eacute" 233
glyph "ebreve" 277
glyph "ecaron" 283
glyph "ecircumflex" 234
glyph "edieresis" 235
glyph "edotaccent" 279
glyph "egrave" 232
glyph "eight" 56
glyph "eightinferior" 8328
glyph "eightoldstyle" 63288
glyph "eightsuperior" 8312
glyph "element" 8712
glyph "ellipsis" 8230
glyph "emacron" 275
glyph "emdash" 8212
glyph "emptyset" 8709
glyph "endash" 8211
glyph "eng" 331
glyph "eogonek" 281
glyph "epsilon" 949
glyph "epsilontonos" 941
glyph "equal" 61
glyph "equivalence" 8801
glyph "estimated" 8494
glyph "esuperior" 63212
glyph "eta" 951
glyph "etatonos" 942
glyph "eth" 240
glyph "exclam" 33
glyph "exclamdbl" 8252
glyph "exclamdown" 161
glyph "exclamdownsmall" 63393
glyph "exclamsmall" 63265
glyph "existential" 8707
glyph "f" 102
glyph "female" 9792
glyph "ff" 64256
glyph "ffi" 64259
glyph "ffl" 64260
glyph "fi" 64257
glyph "figuredash" 8210
glyph "filledbox" 9632
glyph "filledrect" 9644
glyph "five" 53
glyph "fiveeighths" 8541
glyph "fiveinferior" 8325
glyph "fiveoldstyle" 63285
glyph "fivesuperior" 8309
glyph "fl" 64258
glyph "florin" 402
glyph "four" 52
glyph "fourinferior" 8324
glyph "fouroldstyle" 63284
glyph "foursuperior" 8308
glyph "fraction" 8260
glyph "fraction" 8725
glyph "franc" 8355
glyph "g" 103
glyph "gamma" 947
glyph "gbreve" 287
glyph "gcaron" 487
glyph "gcircumflex" 285
glyph "gcommaaccent" 291
glyph "gdotaccent" 289
glyph "germandbls" 223
glyph "gradient" 8711
glyph "grave" 96
glyph "gravecomb" 768
glyph "greater" 62
glyph "greaterequal" 8805
glyph "guillemotleft" 171
glyph "guillemotright" 187
glyph "guilsinglleft" 8249
glyph "guilsinglright" 8250
glyph "h" 104
glyph "hbar" 295
glyph "hcircumflex" 293
glyph "heart" 9829
glyph "hookabovecomb" 777
glyph "house" 8962
glyph "hungarumlaut" 733
glyph "hyphen" 45
glyph "hyphen" 173
glyph "hypheninferior" 63205
glyph "hyphensuperior" 63206
glyph "i" 105
glyph "iacute" 237
glyph "ibreve" 301
glyph "icircumflex" 238
glyph "idieresis" 239
glyph "igrave" 236
glyph "ij" 307
glyph "imacron" 299
glyph "infinity" 8734
glyph "integral" 8747
glyph "integralbt" 8993
glyph "integralex" 63733
glyph "integraltp" 8992
glyph "intersection" 8745
glyph "invbullet" 9688
glyph "invcircle" 9689
glyph "invsmileface" 9787
glyph "iogonek" 303
glyph "iota" 953
glyph "iotadieresis" 970
glyph "iotadieresistonos" 912
glyph "iotatonos" 943
glyph "isuperior" 63213
glyph "itilde" 297
glyph "j" 106
glyph "jcircumflex" 309
glyph "k" 107
glyph "kappa" 954
glyph "kcommaaccent" 311
glyph "kgreenlandic" 312
glyph "l" 108
glyph "lacute" 314
glyph "lambda" 955
glyph "lcaron" 318
glyph "lcommaaccent" 316
glyph "ldot" 320
glyph "less" 60
glyph "lessequal" 8804
glyph "lfblock" 9612
glyph "lira" 8356
glyph "ll" 63168
glyph "logicaland" 8743
glyph "logicalnot" 172
glyph "logicalor" 8744
glyph "longs" 383
glyph "lozenge" 9674
glyph "lslash" 322
glyph "lsuperior" 63214
glyph "ltshade" 9617
glyph "m" 109
glyph "macron" 175
glyph "macron" 713
glyph "male" 9794
glyph "minus" 8722
glyph "minute" 8242
glyph "msuperior" 63215
glyph "mu" 181
glyph "mu" 956
glyph "multiply" 215
glyph "musicalnote" 9834
glyph "musicalnotedbl" 9835
glyph "n" 110
glyph "nacute" 324
glyph "napostrophe" 329
glyph "ncaron" 328
glyph "ncommaaccent" 326
glyph "nine" 57
glyph "nineinferior" 8329
glyph "nineoldstyle" 63289
glyph "ninesuperior" 8313
glyph "notelement" 8713
glyph "notequal" 8800
glyph "notsubset" 8836
glyph "nsuperior" 8319
glyph "ntilde" 241
glyph "nu" 957
glyph "numbersign" 35
glyph "o" 111
glyph "oacute" 243
glyph "obreve" 335
glyph "ocircumflex" 244
glyph "odieresis" 246
glyph "oe" 339
glyph "ogonek" 731
glyph "ograve" 242
glyph "ohorn" 417
glyph "ohungarumlaut" 337
glyph "omacron" 333
glyph "omega" 969
glyph "omega1" 982
glyph "omegatonos" 974
glyph "omicron" 959
glyph "omicrontonos" 972
glyph "one" 49
glyph "onedotenleader" 8228
glyph "oneeighth" 8539
glyph "onefitted" 63196
glyph "onehalf" 189
glyph "oneinferior" 8321
glyph "oneoldstyle" 63281
glyph "onequarter" 188
glyph "onesuperior" 185
glyph "onethird" 8531
glyph "openbullet" 9702
glyph "ordfeminine" 170
glyph "ordmasculine" 186
glyph "orthogonal" 8735
glyph "oslash" 248
glyph "oslashacute" 511
glyph "osuperior" 63216
glyph "otilde" 245
glyph "p" 112
glyph "paragraph" 182
glyph "parenleft" 40
glyph "parenleftbt" 63725
glyph "parenleftex" 63724
glyph "parenleftinferior" 8333
glyph "parenleftsuperior" 8317
glyph "parenlefttp" 63723
glyph "parenright" 41
glyph "parenrightbt" 63736
glyph "parenrightex" 63735
glyph "parenrightinferior" 8334
glyph "parenrightsuperior" 8318
glyph "parenrighttp" 63734
glyph "partialdiff" 8706
glyph "percent" 37
glyph "period" 46
glyph "periodcentered" 183
glyph "periodcentered" 8729
glyph "periodinferior" 63207
glyph "periodsuperior" 63208
glyph "perpendicular" 8869
glyph "perthousand" 8240
glyph "peseta" 8359
glyph "phi" 966
glyph "phi1" 981
glyph "pi" 960
glyph "plus" 43
glyph "plusminus" 177
glyph "prescription" 8478
glyph "product" 8719
glyph "propersubset" 8834
glyph "propersuperset" 8835
glyph "proportional" 8733
glyph "psi" 968
glyph "q" 113
glyph "question" 63
glyph "questiondown" 191
glyph "questiondownsmall" 63423
glyph "questionsmall" 63295
glyph "quotedbl" 34
glyph "quotedblbase" 8222
glyph "quotedblleft" 8220
glyph "quotedblright" 8221
glyph "quoteleft" 8216
glyph "quotereversed" 8219
glyph "quoteright" 8217
glyph "quotesinglbase" 8218
glyph "quotesingle" 39
glyph "r" 114
glyph "racute" 341
glyph "radical" 8730
glyph "radicalex" 63717
glyph "rcaron" 345
glyph "rcommaaccent" 343
glyph "reflexsubset" 8838
glyph "reflexsuperset" 8839
glyph "registered" 174
glyph "registersans" 63720
glyph "registerserif" 63194
glyph "revlogicalnot" 8976
glyph "rho" 961
glyph "ring" 730
glyph "rsuperior" 63217
glyph "rtblock" 9616
glyph "rupiah" 63197
glyph "s" 115
glyph "sacute" 347
glyph "scaron" 353
glyph "scedilla" 351
glyph "scedilla" 63170
glyph "scircumflex" 349
glyph "scommaaccent" 537
glyph "second" 8243
glyph "section" 167
glyph "semicolon" 59
glyph "seven" 55
glyph "seveneighths" 8542
glyph "seveninferior" 8327
glyph "sevenoldstyle" 63287
glyph "sevensuperior" 8311
glyph "shade" 9618
glyph "sigma" 963
glyph "sigma1" 962
glyph "similar" 8764
glyph "six" 54
glyph "sixinferior" 8326
glyph "sixoldstyle" 63286
glyph "sixsuperior" 8310
glyph "slash" 47
glyph "smileface" 9786
glyph "space" 32
glyph "space" 160
glyph "spade" 9824
glyph "ssuperior" 63218
glyph "sterling" 163
glyph "suchthat" 8715
glyph "summation" 8721
glyph "sun" 9788
glyph "t" 116
glyph "tau" 964
glyph "tbar" 359
glyph "tcaron" 357
glyph "tcommaaccent" 355
glyph "tcommaaccent" 539
glyph "therefore" 8756
glyph "theta" 952
glyph "theta1" 977
glyph "thorn" 254
glyph "three" 51
glyph "threeeighths" 8540
glyph "threeinferior" 8323
glyph "threeoldstyle" 63283
glyph "threequarters" 190
glyph "threequartersemdash" 63198
glyph "threesuperior" 179
glyph "tilde" 732
glyph "tildecomb" 771
glyph "tonos" 900
glyph "trademark" 8482
glyph "trademarksans" 63722
glyph "trademarkserif" 63195
glyph "triagdn" 9660
glyph "triaglf" 9668
glyph "triagrt" 9658
glyph "triagup" 9650
glyph "tsuperior" 63219
glyph "two" 50
glyph "twodotenleader" 8229
glyph "twoinferior" 8322
glyph "twooldstyle" 63282
glyph "twosuperior" 178
glyph "twothirds" 8532
glyph "u" 117
glyph "uacute" 250
glyph "ubreve" 365
glyph "ucircumflex" 251
glyph "udieresis" 252
glyph "ugrave" 249
glyph "uhorn" 432
glyph "uhungarumlaut" 369
glyph "umacron" 363
glyph "underscore" 95
glyph "underscoredbl" 8215
glyph "union" 8746
glyph "universal" 8704
glyph "uogonek" 371
glyph "upblock" 9600
glyph "upsilon" 965
glyph "upsilondieresis" 971
glyph "upsilondieresistonos" 944
glyph "upsilontonos" 973
glyph "uring" 367
glyph "utilde" 361
glyph "v" 118
glyph "w" 119
glyph "wacute" 7811
glyph "wcircumflex" 373
glyph "wdieresis" 7813
glyph "weierstrass" 8472
glyph "wgrave" 7809
glyph "x" 120
glyph "xi" 958
glyph "y" 121
glyph "yacute" 253
glyph "ycircumflex" 375
glyph "ydieresis" 255
glyph "yen" 165
glyph "ygrave" 7923
glyph "z" 122
glyph "zacute" 378
glyph "zcaron" 382
glyph "zdotaccent" 380
glyph "zero" 48
glyph "zeroinferior" 8320
glyph "zerooldstyle" 63280
glyph "zerosuperior" 8304
glyph "zeta" 950


if false

  function unhexa s -> i
    arg Str s ; arg Int i
    i := 0
    for (var Int j) 0 s:len-1
      var Int c := s:j number
      if c>="0":0:number and c<="9":0:number
        i := i*16+(c-"0":0:number)
      eif c>="A":0:number and c<="F":0:number
        i := i*16+(c-"A":0:number+10)
      eif c>="a":0:number and c<="f":0:number
        i := i*16+(c-"a":0:number+10)
      else
        return undefined
  
  function parse_glyphs_list
    (var Stream s) open "file:/backup/doc/unicode/glyphlist.txt" in
    while not s:atend
      if (s:readline parse any:(var Str h) ";" any:(var Str glyph) ";" any)
        console "glyph " string:glyph " " unhexa:h eol

  parse_glyphs_list

if auto_accent

  type FontAccent
    field Int base accent
  
  gvar (Dictionary Int FontAccent) accents
  function fill_accents
    each g postscript_glyphs
      var Str n := postscript_glyphs key g
      if n:len>=4
        var Pointer:Int base :> postscript_glyphs first (n 0 1)
        var Pointer:Int accent :> postscript_glyphs first (n 1 n:len)
        if exists:base and exists:accent
          var FontAccent a ; a base := base ; a accent := accent
          accents insert g a
          # console n " = " base " + " accent eol
  fill_accents


public

  type FontChar
    field Str char_name
    field Array:Curve curves
    field Vector2 vector <- (vector 1 0)
    field Float bbox_x0 bbox_y0 bbox_x1 bbox_y1 <- 0

if raster_fonts

  type FontRaster
    inherit CachePrototype
    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

public

  type Font
    inherit CachePrototype
    field (Dictionary Int FontChar) chars
    field Float x0 y0 x1 y1 <- 0
    field Str file
    # Pliant way to identify
    field Str family
    field Str fullname
    field Str psname
    field Str md5
    field Array:Int encoding
    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 push f
  arg_rw FontContext fc ; arg Float f
  fc stack += f

method fc pop n
  arg_rw FontContext fc ; arg Int n
  fc:stack size -= n

method fc count -> n
  arg FontContext fc ; arg Int n
  n := fc:stack size

method fc st i -> f
  arg FontContext fc ; arg Int i ; arg_C Float f
  f :> fc:stack fc:stack:size-1-i

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

method fc lastpoint i -> p
  arg FontContext fc ; arg Int i ; arg_C CurvePoint p
  p :> fc:cc point fc:cc:size-1-i


method fc open_char_def c name
  arg_rw FontContext fc ; arg_rw FontChar c ; arg Str name
  c char_name := name
  c vector := vector 0 0
  fc ch :> c

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
  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 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
      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
        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: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 and { var Int n := cast st:1 Int ; count>=2+n }
        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 " filename " (stack size is " count ")" eol
        return
      p := r

method f load_postscript filename options -> status
  arg_rw Font f ; arg Str filename options ; 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)
    (var Stream 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
  while not s:atend
    var Str l := s readline
    if (l parse word:"/FontName" "/" any:(var Str n) word:"def")
      f psname := n
    eif (l parse word:"/FullName" "(" any:(var Str n) ")" word:"readonly" word:"def")
      f fullname := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" word:"readonly" word:"def")
      f family := n
    eif type1details and (l parse word:"/Weight" "(" any:(var Str n) ")" word:"readonly" word:"def")
      f weight := n
    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 iy0) (var Int ix1) (var Int iy1) "}" word:"def")
      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) "}" "|") or (l parse word:"dup" (var Int i) "{" any:(var Str d) "}" word:"noaccess" word:"put") or (l parse word:"dup" (var Int i) "{" any:(var Str d) "}" word:"NP")
      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) "}" "|-") or (l parse "/" any:(var Str n) "{" any:(var Str d) "}" word:"ND")
      ctx:defs insert n d
    eif (l parse word:"dup" (var Int i) "/" any:(var Str n) _ word:"put")
      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
        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) or new_ch:curves:size>0
        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
    each ch f:chars
      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
  f md5 := file_md5_hexa_signature filename
  if verbose
    console "  loaded font " f:fullname eol
  status := success

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

export postscript_glyphs '. load_postscript' 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 length x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Address kerning ; arg Float length ; arg_w Float x0 y0 x1 y1
  if text:len<>0
    var Vector2 v := f vector text:characters text:len 1 kerning
    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 Float length ; arg_w Float x0 y0 x1 y1
  if text:len<>0
    var Vector2 v := f vector text:characters text:len 4 kerning
    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

export '. length' '. bbox'


#-------------------------------------------------------------------------
# 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"


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


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)+(color map uInt8 i)*opacity)\255

  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 (f:x1-f:x0)*res Int)*raster_anti_aliasing (cast (f:y1-f:y0)*res Int)*raster_anti_aliasing color_gamut:"grey") ""
    var Link:ImageAntiAliasing final :> new ImageAntiAliasing
    final bind pixmap raster_anti_aliasing raster_anti_aliasing
    var Address linebuf := memory_allocate final:line_size null
    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
    pixmap character f char_num transform addressof:color
    var Int reserved := 2*rsize*3+uInt:size ; var Int used := 0
    buf := memory_allocate reserved null
    var Int cx := (cast -(f:x0)*res Int) ; var Int cy := (cast -(f: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
        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 += 1
        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 size
    buf := memory_resize buf used addressof:f
    
  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 (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

else

  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 (f:x1-f:x0)*res Int)*aa (cast (f:y1-f:y0)*res Int)*aa color_gamut:"grey") ""
    var Link:ImageAntiAliasing final :> new ImageAntiAliasing
    final bind pixmap aa
    var Address linebuf := memory_allocate final:line_size null
    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
    pixmap character f char_num transform addressof:color
    var Int reserved := 2*rsize*3+uInt:size ; var Int used := 0
    buf := memory_allocate reserved null
    var Int cx := (cast -(f:x0)*res Int) ; var Int cy := (cast -(f: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
        while x0<final:size_x and (linebuf map uInt8 x0)<threshold
          x0 += 1
        if x0=final:size_x
          leave segment
        var Int x1 := x0
        while x1<final:size_x and (linebuf map uInt8 x1)>=threshold
          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 += 1
        cx += dx ; cy += dy
        x0 := x1
        restart segment
    memory_free linebuf
    (buf translate Byte used) map uInt := 0 ; used += uInt size
    buf := memory_resize buf used addressof:f
    
  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

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
      spacing := 1
  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)*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
    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 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 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 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 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'


#-------------------------------------------------------------------------
# Font caching


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


public

  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"


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