Patch title: Release 93 bulk changes
Abstract:
File: /graphic/vfilter/pdf.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/count.pli"
module "/pliant/admin/file.pli"
module "/pliant/math/transform.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/matrix.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/draw/displaylist.pli"
module "/pliant/graphic/draw/transform.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/vector/freetype.pli"
module "/pliant/graphic/vector/stroke.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/color/ink.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/misc/bytes.pli"
module "/pliant/graphic/misc/float.pli"
module "/pliant/language/data/cache.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/language/data/id.pli"
module "/pliant/graphic/filter/prototype.pli"
module "/pliant/graphic/filter/jpeg.pli"
module "prototype.pli"

# gs -sDEVICE=pdfwrite -dCompressPages=false -dEncodeColorImages=false -dEncodeGrayImages=false -dEncodeMonoImages=false -sOutputFile=/tmp/test.pdf -dNOPAUSE /tmp/test.ps -c quit
# gs -sDEVICE=epswrite -sOutputFile=/tmp/test.eps -dNOPAUSE /tmp/test.ps -c quit

constant debug false
constant debug_header false
constant debug_image false
constant debug_do false
constant debug_font false
constant debug_gamut false
constant message_debug false
constant draw_image true
constant draw_fill true
constant draw_stroke true
constant draw_shading true
constant draw_text true
constant token_overflow 2^16


gvar Arrow null_arrow

method a smart_index i -> c
  arg Array a ; arg Int i ; arg_RW Arrow c
  strong_definition
  if i>=0 and i<a:size
    c :> a i
  else
    c :> null_arrow
  
alias '' '. smart_index'


#-------------------------------------------------------------------------
# PostScript charsets


gvar (Dictionary Str Array:Int) charsets

function text_to_unicode text charset -> unicode
  arg Str text ; arg Array:Int charset ; arg Str32 unicode
  unicode := text
  for (var Int i) 0 text:len-1
    var Int  c := text:i number
    if c<charset:size
      unicode i := character32 charset:c


function char_init
  (var Array:Int ascii) size := 256
  for (var Int i) 0 255
    ascii i := shunt i>=32 and i<127 i undefined
  charsets insert "WinAnsiEncoding" ascii
  charsets insert "MacRomanEncoding" ascii
char_init


function wchar win unicode
  arg Int win unicode
  # if charsets:"WinAnsiEncoding":win<>unicode
  #   console win " was " charsets:"WinAnsiEncoding":win " is " unicode eol
  charsets:"WinAnsiEncoding" win := unicode
  
wchar 128 8364
wchar 130 8218
wchar 131 402
wchar 132 8222
wchar 133 8230
wchar 134 8224
wchar 135 8225
wchar 136 710
wchar 137 8240
wchar 138 352
wchar 139 8249
wchar 140 338
wchar 142 381
wchar 145 8216
wchar 146 8217
wchar 147 8220
wchar 148 8221
wchar 149 8226
wchar 150 8211
wchar 151 8212
wchar 152 732
wchar 153 8482
wchar 154 353
wchar 155 8250
wchar 156 339
wchar 158 382
wchar 159 376
wchar 160 160
wchar 161 161
wchar 162 162
wchar 163 163
wchar 164 164
wchar 165 165
wchar 166 166
wchar 167 167
wchar 168 168
wchar 169 169
wchar 170 170
wchar 171 171
wchar 172 172
wchar 173 173
wchar 174 174
wchar 175 175
wchar 176 176
wchar 177 177
wchar 178 178
wchar 179 179
wchar 180 180
wchar 181 181
wchar 182 182
wchar 183 183
wchar 184 184
wchar 185 185
wchar 186 186
wchar 187 187
wchar 188 188
wchar 189 189
wchar 190 190
wchar 191 191
wchar 192 192
wchar 193 193
wchar 194 194
wchar 195 195
wchar 196 196
wchar 197 197
wchar 198 198
wchar 199 199
wchar 200 200
wchar 201 201
wchar 202 202
wchar 203 203
wchar 204 204
wchar 205 205
wchar 206 206
wchar 207 207
wchar 208 208
wchar 209 209
wchar 210 210
wchar 211 211
wchar 212 212
wchar 213 213
wchar 214 214
wchar 215 215
wchar 216 216
wchar 217 217
wchar 218 218
wchar 219 219
wchar 220 220
wchar 221 221
wchar 222 222
wchar 223 223
wchar 224 224
wchar 225 225
wchar 226 226
wchar 227 227
wchar 228 228
wchar 229 229
wchar 230 230
wchar 231 231
wchar 232 232
wchar 233 233
wchar 234 234
wchar 235 235
wchar 236 236
wchar 237 237
wchar 238 238
wchar 239 239
wchar 240 240
wchar 241 241
wchar 242 242
wchar 243 243
wchar 244 244
wchar 245 245
wchar 246 246
wchar 247 247
wchar 248 248
wchar 249 249
wchar 250 250
wchar 251 251
wchar 252 252
wchar 253 253
wchar 254 254
wchar 255 255

function mchar mac unicode
  arg Int mac unicode
  charsets:"MacRomanEncoding" mac := unicode
  
mchar 128 196
mchar 129 197
mchar 130 199
mchar 131 201
mchar 132 209
mchar 133 214
mchar 134 220
mchar 135 225
mchar 136 224
mchar 137 226
mchar 138 228
mchar 139 227
mchar 140 229
mchar 141 231
mchar 142 233
mchar 143 232
mchar 144 234
mchar 145 235
mchar 146 237
mchar 147 236
mchar 148 238
mchar 149 239
mchar 150 241
mchar 151 243
mchar 152 242
mchar 153 244
mchar 154 246
mchar 155 245
mchar 156 250
mchar 157 249
mchar 158 251
mchar 159 252
mchar 160 8224
mchar 161 176
mchar 162 162
mchar 163 163
mchar 164 167
mchar 165 8226
mchar 166 182
mchar 167 223
mchar 168 174
mchar 169 169
mchar 170 8482
mchar 171 180
mchar 172 168
mchar 173 8800
mchar 174 198
mchar 175 216
mchar 176 8734
mchar 177 177
mchar 178 8804
mchar 179 8805
mchar 180 165
mchar 181 181
mchar 182 8706
mchar 183 8721
mchar 184 8719
mchar 185 960
mchar 186 8747
mchar 187 170
mchar 188 186
mchar 189 937
mchar 190 230
mchar 191 248
mchar 192 191
mchar 193 161
mchar 194 172
mchar 195 8730
mchar 196 402
mchar 197 8776
mchar 198 8710
mchar 199 171
mchar 200 187
mchar 201 8230
mchar 202 160
mchar 203 192
mchar 204 195
mchar 205 213
mchar 206 338
mchar 207 339
mchar 208 8211
mchar 209 8212
mchar 210 8220
mchar 211 8221
mchar 212 8216
mchar 213 8217
mchar 214 247
mchar 215 9674
mchar 216 255
mchar 217 376
mchar 218 8260
mchar 219 8364
mchar 220 8249
mchar 221 8250
mchar 222 64257
mchar 223 64258
mchar 224 8225
mchar 225 183
mchar 226 8218
mchar 227 8222
mchar 228 8240
mchar 229 194
mchar 230 202
mchar 231 193
mchar 232 203
mchar 233 200
mchar 234 205
mchar 235 206
mchar 236 207
mchar 237 204
mchar 238 211
mchar 239 212
mchar 240 63743
mchar 241 210
mchar 242 218
mchar 243 219
mchar 244 217
mchar 245 305
mchar 246 710
mchar 247 732
mchar 248 175
mchar 249 728
mchar 250 729
mchar 251 730
mchar 252 184
mchar 253 733
mchar 254 731
mchar 255 711


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

if false

  module "/pliant/protocol/http/client.pli"
    
  function display_charset instr url
    arg Str instr url
    (var Stream s) open url in
    while not s:atend
      if (s:readline parse "0x" any:(var Str mac) "0x" any:(var Str unicode) "#" any)
        console instr " " unhexa:(replace mac "[tab]" "") " " unhexa:(replace unicode "[tab]" "") eol
  
  display_charset "mchar" "http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/ROMAN.TXT"
  display_charset "wchar" "http://www.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP1252.TXT"


#-------------------------------------------------------------------------
#   defining data type for stroring status while opening the PDF file


type PDFContext
  field Transform2 t <- constant:(transform 0 0 25.4/72 25.4/72 0 0)
  field Int clip_count <- 0
  field Float clip_x0 clip_y0 Float clip_x1 clip_y1 <- undefined
  field Link:ColorGamut fill_gamut ; field ColorBuffer fill_color ; field Int fill_mode # 0=ignore, 1=normal, 2=all
  field Link:ColorGamut stroke_gamut ; field ColorBuffer stroke_color ; field Int stroke_mode
  field Int transparency # 2 means OP is set, 1 means OPM is set
  field Link:(Array uInt8 256) gradation
  field Float line_width
  field Int line_cap <- 0
  field Int line_join <- 0
  field Float line_miter <- 10
  field CBool unsupported_fill <- false
  field CBool unsupported_stroke <- false
  field CBool unsupported_text <- false

type PDFText
  field Link:Dictionary fontdef ; field Float scale
  field Link:Font font
  field Transform2 tm tlm
  field Float charspace <- 0
  field Float wordspace <- 0
  field Float leading <- 0
  field Array:Int encoding

type PDFObject
  field Intn offset
  field Arrow content
  field Intn seek
  field Str cache_id
  field Arrow attached

type PDFReader
  field Link:Stream raw_stream stream
  field Str options
  field Link:ColorGamut gamut
  field CBool separated ; field Int page_num
  field Intn packed
  field Array stack ; field Int count <- 0
  field PDFContext context ; field List:PDFContext context_stack
  field PDFText text
  field (Dictionary Str PDFObject) objects
  field Link:Dictionary xobject_dict colorspace_dict gs_dict font_dict shading_dict
  field (Dictionary Str Str) known_colors
  field Pointer:PDFObject cobject
  field Array:Curve curves ; field Curve curve
  field Link:DrawPrototype draw
  field Str instruction
  field ExtendedStatus status <- success
  field Dictionary warnings

DrawReadFilter maybe PDFReader

type PDFReference
  field Str id


type PDFImageCache
  inherit CachePrototype
  field Link:ImagePrototype image


#-------------------------------------------------------------------------


method pdf warning msg
  arg_rw PDFReader pdf ; arg Str msg
  var Str m := msg+(shunt pdf:instruction<>"" " ('"+pdf:instruction+"' instruction)" "") 
  if (pdf:warnings first m)=null
    pdf:draw warning m
    pdf:warnings insert m true addressof:void

method pdf severe msg
  arg_rw PDFReader pdf ; arg Str msg
  if pdf:status=success
    pdf status := failure msg+(shunt pdf:instruction<>"" " while processing '"+pdf:instruction+"'" "")


method pdf push a
  arg_rw PDFReader pdf ; arg Address a
  implicit pdf
    if count=stack:size
      pdf:stack size += 1
    stack count := a
    count += 1

method pdf pop -> a
  arg_rw PDFReader pdf ; arg Address a
  implicit pdf
    if count>=1
      a := stack count-1
      count -= 1
    else
      severe "stack underflow (pop)"
      a := null

method pdf pop n
  arg_rw PDFReader pdf ; arg Int n
  implicit pdf
    if count>=n
      count -= n
    else
      severe "stack underflow (pop n)"

method pdf pick index -> a
  arg_rw PDFReader pdf ; arg Int index ; arg Address a
  implicit pdf
    if count>index
      a := stack count-1-index
    else
      severe "stack underflow (pick)"
      a := null

method p is t -> c
  arg Address p ; arg Type t ; arg CBool c
  c := p<>null and (entry_type:p=t or t=Float and entry_type:p=Int)

function no_null p t a -> r
  arg Address p ; arg Type t ; arg_rw Arrow a ; arg Address r
  if p<>null and entry_type:p=t
    r := p
  eif t=Int
    r := addressof (cast undefined Int)
  eif t=Float
    if p<>null and entry_type:p=Int
      a := addressof (new Float (p map Int))
      r := a
    else
      r := addressof (cast undefined Float)
  eif t=Str
    r := addressof ""
  eif t=Ident
    r := addressof constant:(cast "" Ident)
  eif t=Dictionary
    r := addressof (gvar Dictionary empty_dictionary)
  eif t=Array
    r := addressof (gvar Array empty_array)
  else
    error error_id_unexpected "'as' is not implemented for data type '"+t:name+"'"

meta '. as' e
  if e:size=2 and (e:0 cast Address) and { var Link:Type t :> (e:1 constant Type) map Type ; exists t }
    var Link:Argument p :> argument local Address
    var Link:Argument v :> argument indirect t p 0
    if t=Ident
      v :> argument indirect Str p 0
    e suckup e:0
    e add (instruction (the_function no_null Address Type Arrow -> Address) e:0:result (argument mapped_constant Type t) (argument local Arrow) p)
    e set_result v access_read


#-------------------------------------------------------------------------
#   parsing


gvar (Array CBool 256) separator
function init_separators
  for (var Int i) 0 255
    separator i := false
  separator " ":number := true
  separator "[tab]":number := true
  separator "[cr]":number := true
  separator "[lf]":number := true
init_separators

gvar (Array CBool 256) stopper
function init_stoppers
  for (var Int i) 0 255
    stopper i := separator i
  stopper "[lb]":number := true
  stopper "[rb]":number := true
  stopper "<":number := true
  stopper ">":number := true
  stopper "(":number := true
  stopper ")":number := true
  stopper "/":number := true
init_stoppers

function unhexa c -> i
  arg Char c ; arg Int i
  var Int l := c number
  if l>="0":number and l<="9":number
    i := l-"0":number
  eif l>="A":number and l<="F":number
    i := l-"A":number+10
  eif l>="a":number and l<="f":number
    i := l-"a":number+10
  else
    i := undefined
  

method pdf pick_byte -> b
  arg_rw PDFReader pdf ; arg Int b
  var Pointer:Stream s :> pdf stream
  if not s:atend
    b := s:stream_read_cur map uInt8
  else
    b := "[lf]" number

method pdf read_byte -> b
  arg_rw PDFReader pdf ; arg Int b
  var Pointer:Stream s :> pdf stream
  if not s:atend
    b := s:stream_read_cur map uInt8
    s stream_read_cur := s:stream_read_cur translate uInt8 1
  else
    b := "[lf]" number

method pdf token -> t
  arg_rw PDFReader pdf ; arg Str t
  part scan
    var Int u := pdf read_byte
    if pdf:stream:atend
      return ""
    eif separator:u
      restart scan
    eif u="%":number
      while { u := pdf read_byte ; u<>"[cr]":number and u<>"[lf]":number }
        void
      restart scan
    eif u="(":number
      t := "(" ; var Int count := 1
      while count>0 and not pdf:stream:atend
        var Int u := pdf read_byte ; t += character u
        if u="(":number
          count += 1
        eif u=")":number
          count -= 1
        eif u="\":number
          u := pdf read_byte
          if u>="0":number and u<="7":number
            t := (t 0 t:len-1)+(character (u-"0":number)*64+(pdf:read_byte-"0":number)*8+pdf:read_byte-"0":number)
          else
            t := (t 0 t:len-1)+character:u
        if t:len>=token_overflow
          pdf severe "token overflow"
          return ""
    eif (u="<":number or u=">":number) and pdf:pick_byte=u
      t := character:u+(character pdf:read_byte)
    eif u="<":number
      t := "<"
      while { u := pdf read_byte ; u<>">":number and not pdf:stream:atend }
        t += character u
      t += ">"
    eif stopper:u and u<>"/":number
      t := character u
    else
      if true
        var Pointer:Stream s :> pdf stream
        var Address a := s stream_read_cur
        while a<>s:stream_read_stop and not stopper:(a map uInt8)
          a := a translate uInt8 1
        var Int len := (cast a Int) .-. (cast s:stream_read_cur Int) .+. 1
        var Address buf := memory_allocate len addressof:t
        buf map uInt8 := u
        memory_copy s:stream_read_cur (buf translate uInt8 1) len-1
        t set buf len true
        s stream_read_cur := a
        if a=s:stream_read_stop
          while not (stopper pdf:pick_byte)
            t += character pdf:read_byte
            if t:len>=token_overflow
              pdf severe "token overflow"
              return ""
      else
        t := character u
        while not (stopper pdf:pick_byte)
          t += character pdf:read_byte
    var Int u := pdf pick_byte
    if u="[cr]":number or u="[lf]":number
      if pdf:pick_byte="[cr]":number
        pdf read_byte
      if pdf:pick_byte="[lf]":number
        pdf read_byte
    eif separator:u
      pdf read_byte

type PDFMark
  field Str id

function pdf_mark id -> m
  arg Str id ; arg PDFMark m
  m id := id

method pdf parse -> t
  arg_rw PDFReader pdf ; arg Str t
  implicit pdf
    while true
      t := pdf token
      # console t eol
      if t=""
        return t
      eif t="<<" or t="[lb]"
        push addressof:(new PDFMark pdf_mark:t)
      eif t=">>"
        var Int n := 0
        while n<count and not (pick:n is PDFMark)
          n += 1
        if n%2<>0
          severe "wrong number of arguments in dictionary"
        for (var Int i) 0 n-1 step 2
          if not ((pick n-1-i) is Ident)
            severe "wrong key type in dictionary"
        var Link:Dictionary dict :> new Dictionary
        for (var Int i) 0 n-2 step 2 # VERIFY
          dict insert ((pick n-1-i) as Ident) true (pick n-2-i) 
        pop n+1
        push addressof:dict
      eif t="[rb]"
        var Int n := 0
        while n<count and (entry_type pick:n)<>PDFMark
          n += 1
        var Link:Array array :> new Array
        array size := n
        for (var Int i) 0 n-1
          array i := pick n-1-i
        pop n+1
        push addressof:array
      eif t="R"
        if not (pick:1 is Int) or not (pick:0 is Int)
          severe "wrong arguments for 'R' instruction" ; return
        var Link:PDFReference ref :> new PDFReference
        ref id := string:(pick:1 as Int)+" "+string:(pick:0 as Int)
        pop 2
        push addressof:ref
      eif (t 0 1)="/"
        var Str ident := t 1 t:len
        var Int i := 0
        while i+2<ident:len
          if ident:i="#" and unhexa:(ident i+1)<>undefined and unhexa:(ident i+2)<>undefined
            ident := (ident 0 i)+(character unhexa:(ident i+1)*16+unhexa:(ident i+2))+(ident i+3 ident:len)
          i += 1
        push addressof:(new Ident (cast ident Ident))
      eif (t 0 1)="(" and t:len>=2 and (t t:len-1)=")"
        push addressof:(new Str (t 1 t:len-2))
      eif (t 0 1)="<" and t:len>=2 and (t t:len-1)=">"
        var Str s := "" ; var Int j := undefined
        for (var Int i) 1 t:len-2
          var Int k := unhexa t:i
          if k<>undefined
            if j=undefined
              j := k
            else
              s += character 16*j+k ; j := undefined
        if j<>undefined
          s += character 16*j
        push addressof:(new Str s)
      eif (t parse (var Int i))
        push addressof:(new Int i)
      eif (t parse (var Float f))
        push addressof:(new Float f)
      eif t="true"
        push addressof:(new Bool true)
      eif t="false"
        push addressof:(new Bool false)
      else
        return t

method pdf solve a -> b
  arg_rw PDFReader pdf ; arg Address a b
  implicit pdf
    b := a
    if (a is PDFReference)
      var Str id := (a as PDFReference) id
      var Pointer:PDFObject object :> pdf:objects first id
      if not exists:object
        severe "no '"+id+"' object" ; return
      if object:content=null
        object content := addressof void
        var Link:Stream current_stream :> stream
        stream :> raw_stream
        (raw_stream query "seek") parse (var Intn current_seek)
        stream configure "seek "+(string object:offset)
        part read
          var Str head := pdf:token+" "+pdf:token+" "+pdf:token
          if head<>id+" obj"
            status := failure "unsupported object header '"+head+"'"
            leave read
          var Int base := count
          var Str t := pdf parse
          if t="stream"
            (stream query "seek") parse object:seek
          eif t="endobj"
            void
          else
            status := failure "unsupported token '"+t+"'"
            leave read
          if count<>base+1
            status := failure "wrong number of arguments on the stack after reading object '"+id+"'"
            leave read
          object content := pop
        raw_stream configure "seek "+string:current_seek
        stream :> current_stream
      if (entry_type object:content)<>Void
        b := object content
        cobject :> object
      

method pdf display a complete
  arg_rw PDFReader pdf ; arg Address a ; arg CBool complete
  implicit pdf
    var Pointer:Type t :> entry_type a
    if t=PDFReference and complete
      var Arrow b := pdf solve a
      if b<>null and b<>a
        pdf display b complete
        return
    console t:name "="
    if t=Int
      console (a map Int)
    eif t=Float
      console (a map Float)
    eif t=Str
      console string:(a map Str)
    eif t=Bool
      console string:(a map Bool)
    eif t=Ident
      console string:(cast (a map Ident) Str)
    eif t=Dictionary
      console "<<"
      each c (a map Dictionary) getkey k
        console " " k ":"
        pdf display c complete
      console " >>"
    eif t=Array
      console "[lb]"
      for (var Int i) 0 (a map Array):size-1
        console " "
        pdf display (a map Array):i complete
      console " [rb]"
    eif t=PDFReference
      console (cast (a map PDFReference):id Str)
    else
      console "?"

method pdf display a
  arg_rw PDFReader pdf ; arg Address a
  pdf display a false

method pdf display 
  arg_rw PDFReader pdf
  implicit pdf
    for (var Int i) 0 count-1
      var Arrow a := pick i
      console "  " i ": "
      pdf display a false
      console eol


#-------------------------------------------------------------------------
#   handling graphical instructions


method pdf new_curve close
  arg_rw PDFReader pdf ; arg CBool close
  implicit pdf
    if curve:size>=2
      curve compute (shunt close outline+bezier bezier)
      curves += curve
    curve reset

function curve_point p2 -> p
  arg Point2 p2 ; arg CurvePoint p
  p := curve_point p2:x p2:y true

gvar uInt8 byte255 := 255

method pdf real_color_name name -> real
  arg PDFReader pdf ; arg Str name real
  arg_rw PDFReader pdf ; arg Str name real
  real := lower name
  if (real eparse "pantone " any:(var Str pantone) " c" any)
    real := pantone
  if (real parse "pantone_" any:(var Str pantone) "_c" any)
    real := pantone
  if real="cyan" or real="magenta" or real="yellow" or real="black"
    real := "process_"+real
  real := replace real " " "_"
  var Int i := 0
  while { var Int p := pdf:options option_position "alias" i undefined ; p<>undefined }
    if ((pdf:options p pdf:options:len) parse word:"alias" (var Str name1) (var Str name2) any)
      if real=name1
        real := name2
    i += 1
  var Pointer:Str final :> pdf:known_colors first real
  if exists:final
    real := final
  else
    if (color_ink (shunt (real search ":" -1)=(-1) "pantone:" "")+(real 0 (real search "#" real:len)))=success
      pdf:known_colors insert real real
    else
      var Str drop := "drop#"+(string 2^30+pdf:known_colors:size)
      pdf:known_colors insert real drop
      real := drop


method pdf colorspace cs extra -> gamut
  arg_rw PDFReader pdf ; arg Address cs ; arg Str extra ; arg Link:ColorGamut gamut
  gamut :> null map ColorGamut
  if (cs is Ident)
    var Str id := cs as Ident
    if pdf:separated and (id="G" or id="DeviceGray")
      gamut :> color_gamut "pantone:"+(pdf:gamut query "component_name "+(string pdf:page_num))+extra
    eif id="G" or id="DeviceGray"
      gamut :> color_gamut "pantone:process_black"+extra
    eif id="RGB" or id="DeviceRGB"
      gamut :> color_gamut "rgb"
    eif id="DeviceCMYK"
      gamut :> color_gamut "pantone:process_cyan+process_magenta+process_yellow+process_black"+extra
    eif (lower:id parse word:"pantone" any:(var Str pantone) _ "c" any)
      gamut :> color_gamut "pantone:"+(pdf real_color_name id)+extra
  eif (cs is Array)
    var Pointer:Array a :> cs as Array
    if a:size>=2 and (a:0 as Ident)="DeviceN" and (a:1 is Array)
      var Pointer:Array inks :> a:1 as Array
      var Str name := ""
      for (var Int i) 0 inks:size-1
        if (entry_type inks:i)=Ident
          var Str ink := cast (inks:i map Ident) Str
          name += "+"+(pdf real_color_name ink)
      gamut :> color_gamut "pantone:"+(name 1 name:len)+extra
    eif a:size>=2 and (a:0 as Ident)="Separation"
      gamut :> color_gamut "pantone:"+(pdf real_color_name (a:1 as Ident))+extra
    eif a:size>0 and (a:0 as Ident)="CalRGB"
      gamut :> color_gamut "rgb"
  if exists:gamut and gamut=failure
    gamut :> null map ColorGamut


method pdf real_color gamut color -> real
  arg_rw PDFReader pdf ; oarg ColorGamut gamut ; arg ColorBuffer color ; arg ColorBuffer real
  implicit pdf
    if separated
      memory_copy addressof:color addressof:real pdf:gamut:pixel_size
    else
      memory_copy addressof:color addressof:(var ColorBuffer c) gamut:pixel_size
      if context:transparency<>3
        bytes_fill (addressof:c translate Byte gamut:dimension) 1 gamut:transparency
      var Arrow speedup :=  pdf:gamut speedup gamut ""
      pdf:gamut convert gamut addressof:c addressof:real 1 speedup
      if context:transparency<2
        bytes_fill (addressof:real translate Byte pdf:gamut:dimension) 1 pdf:gamut:transparency
       

method curves bbox x0 y0 x1 y1
  arg Array:Curve curves ; arg_w Float x0 y0 x1 y1
  x0 := undefined ; y0 := undefined ; x1 := undefined ; y1 := undefined
  for (var Int i) 0 curves:size-1
    curves:i bbox (var Float ix0) (var Float iy0) (var Float ix1) (var Float iy1)
    x0 := shunt x0=undefined or (ix0<>undefined and ix0<x0) ix0 x0
    y0 := shunt y0=undefined or (iy0<>undefined and iy0<y0) iy0 y0
    x1 := shunt x1=undefined or (ix1<>undefined and ix1>x1) ix1 x1
    y1 := shunt y1=undefined or (iy1<>undefined and iy1>y1) iy1 y1


gvar Dictionary pdf_instructions

named_expression pdf_instruction_prototype
  function instruction pdf
    arg_rw PDFReader pdf
    implicit pdf
      body
  record_pdf_instruction (the_function instruction PDFReader) name

function record_pdf_instruction fun name
  arg Function fun ; arg Str name
  pdf_instructions insert (shunt name="quote" "'" name) true addressof:fun

meta pdf_instruction e
  if e:size=2 and e:0:ident<>""
    var Link:Expression ee :> expression duplicate pdf_instruction_prototype substitute instruction (expression constant (cast ". pdf_instruction_"+e:0:ident Ident) near e:0) substitute body e:1 substitute name (expression constant e:0:ident near e:0)
    e compile_as ee


module "ascii85.pli"

method pdf filter base a decoder -> s
  arg_rw PDFReader pdf ; arg_rw Link:Stream base ; arg Address a ; arg_rw Link:ImageReadFilter decoder ; arg Link:Stream s
  implicit pdf
    if (a is Array)
      s :> base
      var Link:Array array :> a as Array
      for (var Int i) 0 array:size-1
        s :> pdf filter s array:i decoder
    eif (a as Ident)="FlateDecode"
      s :> new Stream
      s open "zlib:" "" in+safe pliant_default_file_system base
    eif (a as Ident)="ASCII85Decode"
      s :> new Stream
      s open "ascii85:" "" in+safe pliant_default_file_system base
    eif (a as Ident)="DCTDecode"
      s :> base
      decoder :> image_read_filter ".jpeg"
    eif (a is Ident)
      s :> null map Stream
      console "unsupported '"+(a as Ident)+"' encoding used" eol
      warning "unsupported '"+(a as Ident)+"' encoding used"
    else
      s :> base

method pdf filter d decoder -> s
  arg_rw PDFReader pdf ; arg Dictionary d ; arg_rw Link:ImageReadFilter decoder ; arg Link:Stream s
  decoder :> null map ImageReadFilter
  s :> pdf filter pdf:raw_stream (d first "Filter") decoder
  if addressof:s=(addressof pdf:raw_stream)
    var Int length := (d first "Length") as Int
    if length=defined
      s :> new Stream
      s open "count:" "size "+string:length in+safe pliant_default_file_system pdf:raw_stream

    
method pdf process_instructions
  arg_rw PDFReader pdf
  later


#-------------------------------------------------------------------------
#   PDF instructions set


# context

pdf_instruction q
  context_stack += context
  context clip_count := 0

pdf_instruction Q
  if not (exists context_stack:first)
    severe "context stack underflow" ; return
  for (var Int i) 1 context:clip_count
    draw clip_close
  context := context_stack last
  context_stack remove context_stack:last

pdf_instruction gs
  var Arrow a := solve:(gs_dict first (pick:0 as Ident))
  if debug
    display a true ; console eol
  if (a is Dictionary)
    var Link:Dictionary d :> a as Dictionary
    var Bool op
    if ((d first "OP") is Bool)
      op := (d first "OP") as Bool
    else
      op := (context:transparency .and. 2)<>0
    var Int opm
    if ((d first "OPM") is Int)
      opm := (d first "OPM") as Int
    else
      opm := context:transparency .and. 1
    context transparency := (shunt op 2 0)+opm
    if (solve:(d first "TR") is Dictionary)
      var Link:Dictionary tr :> solve:(d first "TR") as Dictionary
      if ((tr first "FunctionType") is Int) and ((tr first "FunctionType") as Int)=0
        (raw_stream query "seek") parse (var Intn current_seek)
        raw_stream configure "seek "+(string cobject:seek)
        var Link:Stream s :> filter tr (var Link:ImageReadFilter decoder)
        if exists:s
          context gradation :> new (Array uInt8 256)
          s raw_read (addressof context:gradation) 256
        raw_stream configure "seek "+string:current_seek
  else
    severe "expected a Dictionary argument"
  pop

pdf_instruction cm
  (var Matrix m) resize 3 3
  m 0 0 := pick:5 as Float
  m 0 1 := pick:3 as Float
  m 0 2 := pick:1 as Float
  m 1 0 := pick:4 as Float
  m 1 1 := pick:2 as Float
  m 1 2 := pick:0 as Float
  m 2 0 := 0
  m 2 1 := 0
  m 2 2 := 0
  context t := compose transform:m context:t
  pop 6


pdf_instruction i
  # warning "using set flatness tolerence to "+string:(pick:0 as Float)+" is not recommended"
  pop


pdf_instruction w
  function norme v -> d
    arg Vector2 v ; arg Float d
    d := ( v:x*v:x + v:y*v:y )^0.5
    if d=undefined
      d := 0
  var Float lwx := norme (context:t (vector (pick:0 as Float) 0))
  var Float lwy := norme (context:t (vector 0 (pick:0 as Float)))
  context line_width := (lwx+lwy)/2
  if (pick:0 as Float)=0
    warning "line width set to zero"
    context unsupported_stroke := true
  if (abs lwx-lwy)>1e-6
    warning "line width is not the same on both axes"
    context unsupported_stroke := true
  pop 

pdf_instruction M
  warning "set miter limit is not supported"
  context unsupported_stroke := true
pdf_instruction J
  context line_cap := pick:0 as Int
  if context:line_cap<>0
    warning "set line cap to "+(string context:line_cap)+" is not supported"
    context unsupported_stroke := true
  pop

pdf_instruction j
  warning "set line join is not supported"
  context unsupported_stroke := true
  context line_join := pick:0 as Int
  if context:line_join<>0
    warning "set line join to "+(string context:line_join)+" is not supported"
    context unsupported_stroke := true
  pop

pdf_instruction J
  warning "set line cap is not supported"
  context unsupported_stroke := true
pdf_instruction M
  context line_miter := pick:0 as Float
  # warning "set miter limit to "+(string context:line_miter)+" is not supported"
  # context unsupported_stroke := true
  pop

pdf_instruction ri
  warning "using set rendering intents is not recommended"
  pop

pdf_instruction d # dash line pattern
  warning "set dash line pattern is not supported"
  context unsupported_stroke := true
  pop 2


# color 

pdf_instruction cs
  var Arrow a := solve (colorspace_dict first (pick:0 as Ident))
  if (pick:0 as Ident)="Pattern"
    warning "pattern painting"
    context fill_mode := 0
    context unsupported_fill := true
  eif ((a as Array):0 as Ident)="Separation" and ((a as Array):1 as Ident)="All"
    context fill_gamut :> pdf gamut
    if pdf:gamut:model=color_gamut_additive
      context fill_gamut :> color_gamut "pantone:process_black"
    bytes_fill (addressof context:fill_color) 1 context:fill_gamut:pixel_size
    context fill_mode := 2
  eif { var Link:ColorGamut gamut :> colorspace a "+transparencies" ; exists gamut }
    context fill_gamut :> gamut
    bytes_fill (addressof context:fill_color) 1 context:fill_gamut:pixel_size
    context fill_mode := 1
  else
    warning "unexpected colorspace"
    context fill_mode := 0
    context unsupported_fill := true
    if debug
      console "cs trouble" eol
      display a true ; console eol
  pop

pdf_instruction CS
  var Arrow a := solve (colorspace_dict first (pick:0 as Ident))
  if (pick:0 as Ident)="Pattern"
    warning "pattern painting"
    context stroke_mode := 0
    context unsupported_stroke := true
  eif ((a as Array):0 as Ident)="Separation" and ((a as Array):1 as Ident)="All"
    context stroke_gamut :> pdf gamut
    if pdf:gamut:model=color_gamut_additive
      context stroke_gamut :> color_gamut "pantone:process_black"
    bytes_fill (addressof context:stroke_color) 1 context:stroke_gamut:pixel_size
    context stroke_mode := 2
  eif { var Link:ColorGamut gamut :> colorspace a "+transparencies" ; exists gamut }
    context stroke_gamut :> gamut
    bytes_fill (addressof context:stroke_color) 1 context:stroke_gamut:pixel_size
    context stroke_mode := 1
  else
    warning "unexpected colorspace"
    context stroke_mode := 0
    context unsupported_stroke := true
  pop

pdf_instruction sc
  if context:fill_mode=0
    pop count
  eif context:fill_mode=1
    for (var Int i) 0 context:fill_gamut:dimension-1
      context:fill_color:bytes i := cast 255*(bound ((pick context:fill_gamut:dimension-1-i) as Float) 0 1) Int
    pop context:fill_gamut:dimension
  eif context:fill_mode=2
    for (var Int i) 0 context:fill_gamut:dimension-1
      context:fill_color:bytes i := cast 255*(bound (pick:0 as Float) 0 1) Int
    pop 1

pdf_instruction scn
  var Int base := shunt (pick:0 is Ident) 1 0
  if context:fill_mode=0
    pop count
  eif context:fill_mode=1
    for (var Int i) 0 context:fill_gamut:dimension-1
      context:fill_color:bytes i := cast 255*(bound ((pick base+context:fill_gamut:dimension-1-i) as Float) 0 1) Int
    pop base+context:fill_gamut:dimension
  eif context:fill_mode=2
    for (var Int i) 0 context:fill_gamut:dimension-1
      context:fill_color:bytes i := cast 255*(bound (pick:base as Float) 0 1) Int
    pop base+1

pdf_instruction SC
  if context:stroke_mode=0
    pop count
  eif context:stroke_mode=1
    for (var Int i) 0 context:stroke_gamut:dimension-1
      context:stroke_color:bytes i := cast 255*(bound ((pick context:stroke_gamut:dimension-1-i) as Float) 0 1) Int
    pop context:stroke_gamut:dimension
  eif context:stroke_mode=2
    for (var Int i) 0 context:stroke_gamut:dimension-1
      context:stroke_color:bytes i := cast 255*(bound (pick:0 as Float) 0 1) Int
    pop 1

pdf_instruction SCN
  var Int base := shunt (pick:0 is Ident) 1 0
  if context:stroke_mode=0
    pop count
  eif context:stroke_mode=1
    for (var Int i) 0 context:stroke_gamut:dimension-1
      context:stroke_color:bytes i := cast 255*(bound ((pick base+context:stroke_gamut:dimension-1-i) as Float) 0 1) Int
    pop base+context:stroke_gamut:dimension
  eif context:stroke_mode=2
    for (var Int i) 0 context:stroke_gamut:dimension-1
      context:stroke_color:bytes i := cast 255*(bound (pick:base as Float) 0 1) Int
    pop base+1

pdf_instruction k
  context fill_mode := 1
  context fill_gamut :> color_gamut "pantone:process_cyan+process_magenta+process_yellow+process_black+transparencies"
  for (var Int i) 0 3
    context:fill_color:bytes i := cast 255*(bound ((pick 3-i) as Float) 0 1) Int
    context:fill_color:bytes 4+i := shunt ((pick 3-i) as Float)<>0 255 0
  pop 4

pdf_instruction K
  context stroke_mode := 1
  context stroke_gamut :> color_gamut "pantone:process_cyan+process_magenta+process_yellow+process_black+transparencies"
  for (var Int i) 0 3
    context:stroke_color:bytes i := cast 255*(bound ((pick 3-i) as Float) 0 1) Int
    context:stroke_color:bytes 4+i := shunt ((pick 3-i) as Float)<>0 255 0
  pop 4

pdf_instruction rg
  context fill_mode := 1
  context fill_gamut :> color_gamut "rgb"
  for (var Int i) 0 2
    context:fill_color:bytes i := cast 255*(bound ((pick 2-i) as Float) 0 1) Int
  pop 3

pdf_instruction RG
  context stroke_mode := 1
  context stroke_gamut :> color_gamut "rgb"
  for (var Int i) 0 2
    context:stroke_color:bytes i := cast 255*(bound ((pick 2-i) as Float) 0 1) Int
  pop 3

pdf_instruction g
  if separated
    memory_clear (addressof context:fill_color) pdf:gamut:pixel_size
    if page_num<pdf:gamut:dimension
      context fill_mode := 1
      context:fill_color:bytes page_num := cast 255*(bound 1-(pick:0 as Float) 0 1) Int
      context:fill_color:bytes pdf:gamut:dimension+page_num := 255
    else
      context fill_mode := 0
  else
    context fill_mode := 1
    context fill_gamut :> color_gamut "pantone:process_black+transparencies"
    context:fill_color:bytes 0 := cast 255*(bound 1-(pick:0 as Float) 0 1) Int
    context:fill_color:bytes 1 := 255
  pop

pdf_instruction G
  if separated
    memory_clear (addressof context:stroke_color) pdf:gamut:pixel_size
    if page_num<pdf:gamut:dimension
      context stroke_mode := 1
      context:stroke_color:bytes page_num := cast 255*(bound 1-(pick:0 as Float) 0 1) Int
      context:stroke_color:bytes pdf:gamut:dimension+page_num := 255
    else
      context stroke_mode := 0
  else
    context stroke_mode := 1
    context stroke_gamut :> color_gamut "pantone:process_black+transparencies"
    context:stroke_color:bytes 0 := cast 255*(bound 1-(pick:0 as Float) 0 1) Int
    context:stroke_color:bytes 1 := 255
  pop


# drawing

pdf_instruction m
  new_curve false
  curve += curve_point (context:t (point (pick:1 as Float) (pick:0 as Float)))
  pop 2

pdf_instruction l
  curve += curve_point (context:t (point (pick:1 as Float) (pick:0 as Float)))
  pop 2

pdf_instruction c
  if curve:size=0
    severe "no current point" ; return
  var Point2 p2 := context:t (point (pick:5 as Float) (pick:4 as Float))
  var Pointer:CurvePoint l :> curve point curve:size-1
  l out p2:x-l:x p2:y-l:y
  var CurvePoint p := curve_point (context:t (point (pick:1 as Float) (pick:0 as Float)))
  var Point2 p2 := context:t (point (pick:3 as Float) (pick:2 as Float))
  p in p2:x-p:x p2:y-p:y
  curve += p
  pop 6

pdf_instruction y
  if curve:size=0
    severe "no current point" ; return
  var Point2 p2 := context:t (point (pick:3 as Float) (pick:2 as Float))
  var Pointer:CurvePoint l :> curve point curve:size-1
  l out p2:x-l:x p2:y-l:y
  curve += curve_point (context:t (point (pick:1 as Float) (pick:0 as Float)))
  pop 4

pdf_instruction v
  if curve:size=0
    severe "no current point" ; return
  var CurvePoint p := curve_point (context:t (point (pick:1 as Float) (pick:0 as Float)))
  var Point2 p2 := context:t (point (pick:3 as Float) (pick:2 as Float))
  p in p2:x-p:x p2:y-p:y
  curve += p
  pop 4

pdf_instruction re
  new_curve false
  curve += curve_point (context:t (point (pick:3 as Float) (pick:2 as Float)))
  curve += curve_point (context:t (point (pick:3 as Float)+(pick:1 as Float) (pick:2 as Float)))
  curve += curve_point (context:t (point (pick:3 as Float)+(pick:1 as Float) (pick:2 as Float)+(pick:0 as Float)))
  curve += curve_point (context:t (point (pick:3 as Float) (pick:2 as Float)+(pick:0 as Float)))
  new_curve true
  pop 4

pdf_instruction n
  curve reset
  curves size := 0

pdf_instruction h
  new_curve true


pdf_instruction f
  new_curve false
  if draw_fill and context:fill_mode<>0
    draw fill curves fill_nonzero transform addressof:(real_color context:fill_gamut context:fill_color)
  curves size := 0

pdf_instruction F
  pdf_instruction_f

pdf_instruction 'f*'
  new_curve false
  if draw_fill and context:fill_mode<>0
    draw fill curves fill_evenodd transform addressof:(real_color context:fill_gamut context:fill_color)
  curves size := 0

pdf_instruction S
  new_curve false
  if draw_stroke and context:stroke_mode<>0
    draw stroke curves context:line_width "" transform addressof:(real_color context:stroke_gamut context:stroke_color)
    draw stroke curves context:line_width "cap "+(string context:line_cap)+" join "+(string context:line_join)+" miter "+(string context:line_miter) transform addressof:(real_color context:stroke_gamut context:stroke_color)
  curves size := 0

pdf_instruction s
  pdf_instruction_h
  pdf_instruction_S 

pdf_instruction B
  new_curve false
  if draw_fill and context:fill_mode<>0
    draw fill curves fill_nonzero transform addressof:(real_color context:fill_gamut context:fill_color)
  if draw_stroke and context:stroke_mode<>0
    draw stroke curves context:line_width "" transform addressof:(real_color context:stroke_gamut context:stroke_color)
    draw stroke curves context:line_width "cap "+(string context:line_cap)+" join "+(string context:line_join)+" miter "+(string context:line_miter) transform addressof:(real_color context:stroke_gamut context:stroke_color)
  curves size := 0

pdf_instruction 'B*'
  new_curve false
  if draw_fill and context:fill_mode<>0
    draw fill curves fill_evenodd transform addressof:(real_color context:fill_gamut context:fill_color)
  if draw_stroke and context:stroke_mode<>0
    draw stroke curves context:line_width "" transform addressof:(real_color context:stroke_gamut context:stroke_color)
    draw stroke curves context:line_width "cap "+(string context:line_cap)+" join "+(string context:line_join)+" miter "+(string context:line_miter) transform addressof:(real_color context:stroke_gamut context:stroke_color)
  curves size := 0

pdf_instruction b
  pdf_instruction_h
  pdf_instruction_B

pdf_instruction 'b*'
  pdf_instruction_h
  'pdf_instruction_B*'

pdf_instruction W
  new_curve false
  curves bbox context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1
  var Link:DrawPrototype clip :> draw clip_open context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1
  clip fill curves fill_nonzero transform addressof:byte255
  context clip_count += 1

pdf_instruction 'W*'
  new_curve false
  curves bbox context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1
  var Link:DrawPrototype clip :> draw clip_open context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1
  clip fill curves fill_evenodd transform addressof:byte255
  context clip_count += 1

module "/pliant/graphic/vector/shading.pli"
pdf_instruction sh
  var Link:Dictionary d :> solve:(shading_dict first (pick:0 as Ident)) as Dictionary
  var Int st := (d first "ShadingType") as Int
  if context:clip_x0=defined and (st=2 or st=3)
    warning (shunt st=2 "axial" "radial")+" shading"
    var Link:ColorGamut gamut :> colorspace solve:(d first "ColorSpace") "+transparencies"
    if exists:gamut
      var Link:Array a :> (d first "Coords") as Array
      if st=2
        var Point2 p0 := context:t (point (a:0 as Float) (a:1 as Float))
        var Point2 p1 := context:t (point (a:2 as Float) (a:3 as Float))
      eif st=3
        var Point2 p0 := context:t (point (a:0 as Float) (a:1 as Float))
        var Float r0 := norme (context:t (vector (a:2 as Float) 0))
        var Point2 p1 := context:t (point (a:3 as Float) (a:4 as Float))
        var Float r1 := norme (context:t (vector (a:5 as Float) 0))
        if (norme p1-p0)>1e-9
          warning "radial shading with different centers"
      var Link:Dictionary f :> solve:(d first "Function") as Dictionary
      var ColorBuffer c0
      for (var Int i) 0 gamut:dimension-1
        c0:bytes i := cast 255*(((f first "C0") as Array):i as Float) Int
      bytes_fill (addressof:c0 translate Byte gamut:dimension) 1 gamut:transparency
      var ColorBuffer c1
      for (var Int i) 0 gamut:dimension-1
        c1:bytes i := cast 255*(((f first "C1") as Array):i as Float) Int
      bytes_fill (addressof:c1 translate Byte gamut:dimension) 1 gamut:transparency
      var Link:ImagePacked p :> new ImagePacked
      p setup (image_prototype context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1 300 300 1 1 image_adjust_extend gamut) ""
      if st=2
        p axial_shading p0 c0 p1 c1 gamut
      eif st=3
        p radial_shading p0 r0 c0 p1 r1 c1 gamut
      if draw_shading
        draw image p transform
    else
      warning "unsupported shading colorspace"
      var Link:DrawPrototype dt :> draw trouble_open
      dt rectangle context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1 addressof:byte255
      draw trouble_close
  else
    warning "unsupported shading "+string:((d first "ShadingType") as Int)
    var Link:DrawPrototype dt :> draw trouble_open
    dt rectangle context:clip_x0 context:clip_y0 context:clip_x1 context:clip_y1 addressof:byte255
    draw trouble_close
  pop

 
# image

pdf_instruction Do
  function predictor a b c -> r
    arg Int a b c r
    var Int p := a+b-c
    var Int pa := abs p-a
    var Int pb := abs p-b
    var Int pc := abs p-c
    r := shunt pa<=pb and pa<=pc a pb<=pc b c
  var Str id := pick:0 as Ident
  var Arrow a := solve (xobject_dict first (pop as Ident))
  if (a is Dictionary) and { var Link:Dictionary d :> a as Dictionary ; (d first "Width")<>null }
  var Link:Dictionary d :> a as Dictionary
  var Str subtype := (d first "Subtype") as Ident
  if subtype="Image"
    var Pointer:PDFObject img_object :> cobject
    if (cache_open "/pliant/pdf/image/"+img_object:cache_id PDFImageCache (var Link:CachePrototype ca))
      var CBool ok := false
      part load "loading image"
        var Int size_x := solve:(d first "Width") as Int
        var Int size_y := solve:(d first "Height") as Int
        var Int bpc := solve:(d first "BitsPerComponent") as Int
        var Link:ColorGamut gamut :> colorspace solve:(d first "ColorSpace") ""
        var CBool mask := false
        if not exists:gamut and ((d first "ImageMask") is Bool)
          mask := (d first "ImageMask") as Bool
          if mask
            gamut :> pdf gamut
            var ColorBuffer c0 ; memory_clear addressof:c0 gamut:pixel_size
            var ColorBuffer c1 := real_color context:fill_gamut context:fill_color
        eif bpc=1
          mask := true
          var ColorBuffer c0 ; memory_clear addressof:c0 gamut:pixel_size
          var ColorBuffer c1 ; bytes_fill addressof:c1 1 gamut:pixel_size
        if debug or debug_image
          console "Do " size_x " x " size_y " " 
          if exists:gamut
            console gamut:name " "
          console (shunt mask "MASK" "") eol
          display a true ; console eol
        if not exists:gamut
          # console "unsupported colorspace " ; display a true ; console eol
          var Str name := (solve (solve:(d first "ColorSpace") as Array):0) as Ident
          if name=""
            name := solve:(d first "ColorSpace") as Ident
          warning "unsupported image colorspace "+name ; leave load
        var CBool reverse := (solve:(d first "ColorSpace") as Ident)="DeviceGray"
        if mask
          reverse := ((solve:(d first "Decode") as Array):0 as Float)<>1
        var Link:Dictionary parameters :> solve:(d first "DecodeParms") as Dictionary
        var Int predictor := solve:(parameters first "Predictor") as Int
        if predictor=undefined
          predictor := 1
        var Int pred_columns := solve:(parameters first "Columns") as Int
        var Int pred_bits := solve:(parameters first "BitsPerComponent") as Int
        var Int pred_colors := solve:(parameters first "Colors") as Int
        var Int pred_step := undefined
        var Int pred_left := undefined
        if pred_columns<>undefined and pred_bits<>undefined and pred_colors<>undefined
          pred_step := max (pred_columns*pred_bits*pred_colors+7)\8 1
          pred_left := max (pred_bits*pred_colors+7)\8 1
        if size_x<=0 or size_y<=0
          severe "incorrect image size" ; leave load
        var Link:ImagePrototype img
        if 1n*size_x*size_y*gamut:pixel_size>=packed or mask
          if debug_do
            console "*"
          img :> new ImagePacked
        else
          if debug_do
            console "+"
          img :> new ImagePixmap
        img setup (image_prototype 0 0 1 1 size_x size_y gamut) ""
        (raw_stream query "seek") parse (var Intn current_seek)
        raw_stream configure "seek "+(string img_object:seek)
        var Link:Stream pixels :> filter d (var Link:ImageReadFilter decoder)
        if not exists:pixels
          warning "unsupported image encoding" ; leave load
        if exists:decoder
          if (decoder open pixels "" (var ImagePrototype h))=failure
            warning "failed to setup image decoder" ; leave load
        var Int line_size := shunt mask (img:size_x+7)\8 img:line_size
        var Address buffer := (memory_zallocate line_size+img:pixel_size null) translate Byte gamut:pixel_size
        var Address previous := (memory_zallocate line_size+img:pixel_size null) translate Byte gamut:pixel_size
        var Address final := memory_zallocate line_size null
        var Address final2 := memory_zallocate img:line_size null
        var CBool passed := false
        part read_lines
          for (var Int y) 0 size_y-1
            var Int offset := 0
            while offset<line_size
              var Int algo := 0 ; var Int step := line_size-offset
              if predictor=1
                void
              eif predictor=15
                pixels raw_read addressof:(var uInt8 algo8) 1 ; algo := algo8
                if pred_step=defined
                  step := min step pred_step
              else
                algo := predictor-10
              if exists:decoder
                if (decoder readline buffer)=failure
                  warning "failed to read image line "+(string y+1)+"/"+string:size_y ; leave read_lines
              else
                pixels raw_read buffer step
              var Address cur := buffer
              var Address stop := buffer translate Byte step
              var Int left := shunt pred_left<>undefined and pred_left<img:pixel_size -pred_left -(img pixel_size)
              var Int top := (cast previous Int).-.(cast buffer Int)
              var Int topleft := left+top
              if algo=0
                void
              eif algo=1
                cur := cur translate Byte -left
                while cur<>stop
                  cur map uInt8 := (cur map uInt8)+(cur map uInt8 left) .and. 255
                  cur := cur translate uInt8 1
              eif algo=2
                while cur<>stop
                  cur map uInt8 := (cur map uInt8)+(cur map uInt8 top) .and. 255
                  cur := cur translate uInt8 1
              eif algo=3
                while cur<>stop
                  cur map uInt8 := (cur map uInt8)+((cur map uInt8 left)+(cur map uInt8 top))\2 .and. 255
                  cur := cur translate uInt8 1
              eif algo=4
                while cur<>stop
                  cur map uInt8 := (cur map uInt8)+(predictor (cur map uInt8 left) (cur map uInt8 top) (cur map uInt8 topleft)) .and. 255
                  cur := cur translate uInt8 1
              else
                # warning "Unsupported image predictor "+string:predictor+" algorithm "+string:algo+" at line "+string:y+"/"+string:size_y+" ("+string:size_x+" "+string:size_y+" "+string:line_size+" , "+string:pred_columns+" "+string:pred_bits+" "+string:pred_colors+" "+string:pred_step+" "+string:pred_left+")" ; leave read_lines
                warning "Unsupported image predictor "+string:predictor+" algorithm "+string:algo ; leave read_lines
              memory_copy buffer (final translate Byte offset) step
              memory_copy buffer previous step
              offset += step
            if (exists context:gradation)
              var Pointer:(Array uInt8 256) gradation :> context gradation
              var Address cur := final ; var Address stop := final translate Byte line_size
              while cur<>stop
                cur map uInt8 := gradation (cur map uInt8)
                cur := cur translate uInt8 1
            if reverse
              bytes_copy_255minus final 1 final 1 line_size
            if mask
              var Address cur := final2
              for (var Int i) 0 size_x-1
                memory_copy (shunt ((final map uInt8 i\8) .and. 2^(7-i%8))<>0 addressof:c1 addressof:c0) cur img:pixel_size
                cur := cur translate Byte img:pixel_size                  
              img write 0 size_y-1-y size_x final2
            else
              img write 0 size_y-1-y size_x final
          passed := true
        if exists:decoder
          if decoder:close=failure
            warning "failed to read image" ; leave load
        memory_free (buffer translate Byte -(img:pixel_size))
        memory_free (previous translate Byte -(img:pixel_size))
        memory_free final
        memory_free final2
        img configure "shrink"
        raw_stream configure "seek "+string:current_seek
        if pixels=failure
          warning "failed to read image" ; leave load
        (addressof:ca omap PDFImageCache) image :> img
        ok := passed
      if ok
        cache_ready ca
      else
        cache_cancel ca
        warning "failed to load image"
        return
    else
      if debug_do
        console "-"
    if draw_image
      draw image (addressof:ca omap PDFImageCache):image context:t
  eif (a is Dictionary) and cobject:attached<>null
  eif subtype="Form" and cobject:attached<>null
    check (entry_type cobject:attached)=DrawDisplayList
    var Transform2 ct := context t
    (addressof:draw omap DrawDisplayList) include (cobject:attached map DrawDisplayList) DrawTransform "xx "+(string ct:xx)+" xy "+(string ct:xy)+" xt "+(string ct:xt)+" yx "+(string ct:yx)+" yy "+(string ct:yy)+" yt "+(string ct:yt)
    if debug_do
      console "Do again" eol
  eif (a is Dictionary)
  eif subtype="Form"
    if (entry_type addressof:draw)=DrawDisplayList
      var Pointer:PDFObject do_object :> cobject
      var Link:DrawDisplayList memo_draw :> addressof:draw map DrawDisplayList
      var Link:DrawDisplayList sub :> new DrawDisplayList
      sub setup (draw image_prototype "") (draw image_prototype ""):options
      draw :> sub
      var Transform2 memo_t := context t
      context t := transform
    var Link:Stream current_stream :> stream
    (raw_stream query "seek") parse (var Intn current_seek)
    raw_stream configure "seek "+(string cobject:seek)
    stream :> filter (a map Dictionary) (var Link:ImageReadFilter decoder)
    var Link:Dictionary colorspace_memo :> colorspace_dict
    var Link:Dictionary xobject_memo :> xobject_dict
    var Link:Dictionary gs_memo :> gs_dict
    var Link:Dictionary font_memo :> font_dict
    var Link:Dictionary shading_memo :> shading_dict
    var Link:Dictionary res :> solve:((a as Dictionary) first "Resources") map Dictionary
    if exists:res and exists:(res first "XObject")
      xobject_dict :> solve:(res first "XObject") as Dictionary
    if exists:res and exists:(res first "ColorSpace")
      colorspace_dict :> solve:(res first "ColorSpace") as Dictionary
    if exists:res and exists:(res first "ExtGState")
      gs_dict :> solve:(res first "ExtGState") as Dictionary
    if exists:res and exists:(res first "Font")
      font_dict :> solve:(res first "Font") as Dictionary
    if exists:res and exists:(res first "Shading")
      shading_dict :> solve:(res first "Shading") as Dictionary
    process_instructions
    colorspace_dict :> colorspace_memo
    xobject_dict :> xobject_memo
    gs_dict :> gs_memo
    font_dict :> gs_memo
    shading_dict :> gs_memo
    raw_stream configure "seek "+string:current_seek
    stream :> current_stream
    if (entry_type addressof:draw)=DrawDisplayList
      context t := memo_t
      draw :> memo_draw
      var Transform2 ct := context t
      memo_draw include sub DrawTransform "xx "+(string ct:xx)+" xy "+(string ct:xy)+" xt "+(string ct:xt)+" yx "+(string ct:yx)+" yy "+(string ct:yy)+" yt "+(string ct:yt)
      do_object attached := addressof sub
    if debug_do
      console "Do first" eol
  else
    warning "unexpected Do usage"
    warning "unexpected Do usage (Subtype = "+subtype+")"

pdf_instruction BI
  void

pdf_instruction EI
  void

pdf_instruction ID
  var Int isize_x := undefined ; var Int isize_y := undefined ; var Int bpc := undefined
  var Link:ColorGamut gamut :> null map ColorGamut ; var CBool reverse := false
  for (var Int i) 0 count-2 step 2
    var Str id := (pick i+1) as Ident
    if id="W"
      isize_x := pick:i as Int
    eif id="H"
      isize_y := pick:i as Int
    eif id="BPC"
      bpc := pick:i as Int
      if bpc<>8
        warning "Unsupported "+string:bpc+" bits per component inline image" ; return
    eif id="CS"
      var Str cs := pick:i as Ident
      if separated and (cs="DeviceGray" or cs="G")
        gamut :> color_gamut "pantone:"+(pdf:gamut query "component_name "+string:page_num) ; reverse := true
      eif cs="DeviceGray" or cs="G"
        gamut :> color_gamut "pantone:process_black" ; reverse := true
      else
        warning "unsupported inline image colorspace '"+cs+"'" ; return
    else
      warning "unsupported inline image attribute '"+id+"'" ; return
  if not exists:gamut
    warning "unsupported inline image gamut" ; return
  if isize_x<=0 or isize_y<=0 or isize_x>2^14 or isize_y>2^14 or isize_x*isize_y>2^24
    warning "inline image overflow" ; return
  var Link:ImagePacked packed :> new ImagePacked
  packed setup (image_prototype 0 0 1 1 isize_x isize_y gamut) ""
  var Address buffer := memory_allocate packed:line_size null
  for (var Int iy) 0 isize_y-1
    pdf:stream raw_read buffer packed:line_size
    if reverse
      bytes_copy_255minus buffer 1 buffer 1 packed:line_size
    packed write 0 isize_y-1-iy isize_x buffer
  memory_free buffer
  draw image packed context:t
  pop count
  if token<>"EI"
    warning "unexpected end of inline image"


# text

pdf_instruction BT
  text tlm := transform 0 0 1 1 0 0
  text tm := text tlm

pdf_instruction ET
  void

pdf_instruction Tf
  text fontdef :> solve:(font_dict first (pick:1 as Ident)) as Dictionary
  var Pointer:PDFObject img_object :> cobject
  if (cache_open "/pliant/graphic/pdf/font/"+img_object:cache_id Font ((addressof Link:Font text:font) map Link:CachePrototype))
    var Str name := solve:(text:fontdef first "BaseFont") as Ident
    if debug
      console "font name '" name "' " (shunt (exists text:font) "yes" "no") eol
  var Str name := solve:(text:fontdef first "BaseFont") as Ident
  var Str id := shunt (options option "share_fonts_with_same_name") and name<>"" name img_object:cache_id 
  if (cache_open "/pliant/graphic/pdf/font/"+id Font ((addressof Link:Font text:font) map Link:CachePrototype))
    if debug_font
      console "font name '" name "' " (shunt (exists text:font) "yes" "no") " " img_object:cache_id eol
      console "font def " ; display (addressof text:fontdef) true ; console eol
    part compute_the_encoding
      text:encoding size := 256
      for (var Int i) 0 255
        text:encoding i := i
      var Str charset := (text:fontdef first "Encoding") as Ident
      if exists:(charsets first charset)
        text encoding := charsets first charset
      var Link:Dictionary enc :> solve:(text:fontdef first "Encoding") as Dictionary
      var Str charset := (enc first "BaseEncoding") as Ident
      if exists:(charsets first charset)
        text encoding := charsets first charset
      var Link:Array diff :> solve:(enc first "Differences") as Array
      var Int num := undefined
      for (var Int i) 0 diff:size-1
        if (diff:i is Int)
          num := diff:i as Int
        if (diff:i as Ident)<>"" and num>=0 and num<256
          var Pointer:Int unicode :> postscript_glyphs first (diff:i as Ident)
          if exists:unicode
            text:encoding num := unicode
          num += 1
      if solve:(text:fontdef first "ToUnicode")<>null
        var Link:Dictionary mapping :> solve:(text:fontdef first "ToUnicode") as Dictionary
        (raw_stream query "seek") parse (var Intn current_seek)
        raw_stream configure "seek "+(string cobject:seek)
        var Link:Stream s :> filter mapping (var Link:ImageReadFilter decoder)
        while not s:atend
          var Str l := s readline
          if (l parse (var Int drop) word:"beginbfchar")
            while (s:readline parse "<" any:(var Str code8) ">" "<" any:(var Str code16) ">")
              var Int char := unhexa code8
              if char>=0 and char<256
                text:encoding char := unhexa code16
        raw_stream configure "seek "+string:current_seek
    text:font encoding := text encoding
    part load_the_font
      var CBool loaded := false
      var Arrow def := addressof text:fontdef
      if (text:fontdef first "DescendantFonts")<>null
        def := solve (text:fontdef first "DescendantFonts")
        if (def is Array)
          def := solve (def as Array):0
      if ((def as Dictionary) first "FontDescriptor")<>null
        def := solve ((def as Dictionary) first "FontDescriptor")
      for (var Int i) 0 3
        if ((def as Dictionary) first "FontFile"+(shunt i>0 string:i ""))<>null
          var Link:Dictionary ff :> solve:((def as Dictionary) first "FontFile"+(shunt i>0 string:i "")) as Dictionary
          if cobject:seek<>0
            (raw_stream query "seek") parse (var Intn current_seek)
            raw_stream configure "seek "+(string cobject:seek)
            var Str temp := file_temporary
            var Link:Stream src :> filter ff (var Link:ImageReadFilter decoder)
            var Int length
            if addressof:src=(addressof pdf:raw_stream)
              length := (ff first "Length") as Int
            else
              length := 2^30
            (var Stream dest) open temp out+safe
            raw_copy src dest length length
            dest close
            # file_copy temp "file:/tmp/font.bin" standard
            raw_stream configure "seek "+(string current_seek)
            part load "loading freetype font"
            part load "loading font"
              if not (options option "nopliantfont") and (text:font load_postscript temp "")=success
                loaded := true
                if debug
                  console "loaded Type1 font at " cobject:seek eol
              eif not (options option "nofreetypefont") and (text:font load_freetype temp "")=success
                loaded := true
                if debug
                  console "loaded FreeType font at " cobject:seek eol
              else
                if debug
                  console "failed to load FreeType font at " cobject:seek eol
                warning "Failed to load embedded font at "+(string cobject:seek)
            file_delete temp
      if false # not loaded and ((def as Dictionary) first "CharProcs")<>null
        var Link:Dictionary procs :> solve:((def as Dictionary) first "CharProcs") as Dictionary
        var Int num := undefined
        for (var Int i) 0 diff:size-1
          if (diff:i is Int)
            num := diff:i as Int
          if (diff:i as Ident)<>""
            var Link:Dictionary proc :>solve:(procs first (diff:i as Ident)) as Dictionary
            if cobject:seek<>0
              (raw_stream query "seek") parse (var Intn current_seek)
              raw_stream configure "seek "+(string cobject:seek)
              var Link:Stream src :> filter proc (var Link:ImageReadFilter decoder)
              console "glyph " (diff:i as Ident) eol
              while not src:atend
                console "  " src:readline eol
              raw_stream configure "seek "+string:current_seek
      if loaded
        cache_ready ((addressof Link:Font text:font) map Link:CachePrototype)
      else
        if debug
          console "Font '"+name+"' is missing" eol
        cache_cancel ((addressof Link:Font text:font) map Link:CachePrototype)
        text font :> null map Font
  if (exists text:font)
    text encoding := text:font encoding
  text scale := pick:0 as Float
  pop 2

pdf_instruction Tm
  (var Matrix m) resize 3 3
  m 0 0 := pick:5 as Float
  m 0 1 := pick:3 as Float
  m 0 2 := pick:1 as Float
  m 1 0 := pick:4 as Float
  m 1 1 := pick:2 as Float
  m 1 2 := pick:0 as Float
  m 2 0 := 0
  m 2 1 := 0
  m 2 2 := 0
  text tlm := transform m
  text tm := text tlm
  pop 6

pdf_instruction Td
  text tlm := compose (transform (pick:1 as Float) (pick:0 as Float) 1 1 0 0) text:tlm 
  text tm := text tlm
  pop 2

pdf_instruction Tc
  text charspace := pick:0 as Float
  pop

pdf_instruction Tw
  text wordspace := pick:0 as Float
  pop

pdf_instruction TL
  text leading := pick:0 as Float
  pop

pdf_instruction TD
  text leading := pick:0 as Float
  text tlm := compose (transform (pick:1 as Float) (pick:0 as Float) 1 1 0 0) text:tlm 
  text tm := text tlm
  pop 2

pdf_instruction 'T*'
  text tlm := compose (transform 0 -(text:leading) 1 1 0 0) text:tlm
  text tm := text tlm

method pdf draw_text txt offsets
  arg_rw PDFReader pdf ; arg Str txt ; arg_rw Array:Float offsets
  implicit pdf
    if debug
      console "text is "
      for (var Int i) 0 txt:len-1
        console (shunt txt:i:number>=32 and txt:i:number<128 txt:i "?")
      console " ("
      for (var Int i) 0 txt:len-1
        console " " txt:i:number
      console ")" eol
    var Transform2 t := compose (transform 0 0 text:scale -(text:scale) 0 0) text:tm context:t
    var Float length := 0
    var ColorBuffer color := real_color context:fill_gamut context:fill_color
    var Int firstchar := (text:fontdef first "FirstChar") as Int
    if firstchar<0
      firstchar := 0
    var Str32 unicode := text_to_unicode txt text:encoding
    if debug
      console "unicode is"
      for (var Int i) 0 unicode:len-1
        console " " unicode:i:number
      console eol
    var Link:Font font :> text font
    if not exists:font
      font :> font (solve:(text:fontdef first "BaseFont") as Ident)
    if not exists:font
      warning "Font '"+(solve:(text:fontdef first "BaseFont") as Ident)+"' is missing"
      if debug
        console "missing font " ; display (addressof text:fontdef) true ; console eol
        warning "Using missing font"
        console "text is "
        for (var Int i) 0 txt:len-1
          console (shunt txt:i:number>=32 and txt:i:number<128 txt:i "?")
        console " ("
        for (var Int i) 0 txt:len-1
          console " " txt:i:number
        console ")" eol
        console "unicode text is "
        for (var Int i) 0 unicode:len-1
          console character:(shunt unicode:i:number>=32 and unicode:i:number<256 unicode:i:number "?":number)
        console " ("
        for (var Int i) 0 unicode:len-1
          console " " unicode:i:number
        console ")" eol
      font :> font "Helvetica"
    for (var Int i) 0 txt:len-1
      var Int c := txt:i number
      var Int width := (((text:fontdef first "Widths") as Array) (max c-firstchar 0)) as Int
      if width=undefined
        width := cast (font length (unicode i 1) null)*1000 Int
      offsets i := (width-offsets:i)/1000+(shunt c=32 text:wordspace text:charspace)/text:scale
      length += offsets i
    if debug
      console "length is"
      for (var Int i) 0 unicode:len-1
        console " " offsets:i
      console " -> " length eol
    if true
      var Address kerning := memory_allocate txt:len*Float:size null
      for (var Int i) 0 txt:len-1
        var Float length := font length (unicode i 1) null
        if length=0
          length := offsets i
        kerning map Float i := offsets:i/length
      if draw_text
        draw text unicode font kerning undefined t addressof:color
      memory_free kerning
    else
      for (var Int i) 0 txt:len-1
        if draw_text
          draw text (unicode i 1) font null undefined t addressof:color
        t := compose (transform offsets:i 0 1 1 0 0) t
    text tm := compose (transform length 0 1 1 0 0) text:tm

pdf_instruction Tj
  var Str txt := pick:0 as Str
  (var Array:Float offsets) size := txt len
  for (var Int i) 0 offsets:size-1
    offsets i := 0
  draw_text txt offsets
  pop

pdf_instruction TJ
  var Link:Array a :> pick:0 as Array
  var Str txt := "" ; var Array:Float offsets
  for (var Int i) 0 a:size-1 step 2
    txt += a:i as Str
    while offsets:size<txt:len-1
      offsets += 0
    if i+1<a:size
      offsets += a:(i+1) as Float
    else
      offsets += 0
  draw_text txt offsets
  pop

pdf_instruction Tr
  if (pick:0 as Int)<>0
    warning "text rendering mode "+string:(pick:0 as Int)+" is not supported"
  pop

pdf_instruction Tz
  if (pick:0 as Float)<>100
    warning "text horizontal scaling "+string:(pick:0 as Float)+"% is not supported"
  pop

pdf_instruction Ts
  if (pick:0 as Float)<>0
    warning "text rise "+string:(pick:0 as Float)+" is not supported"
  pop

pdf_instruction quote
  text tlm := compose (transform 0 -(text:leading) 1 1 0 0) text:tlm
  text tm := text tlm
  var Str txt := pick:0 as Str
  (var Array:Float offsets) size := txt len
  for (var Int i) 0 offsets:size-1
    offsets i := 0
  draw_text txt offsets
  pop


# tagging

pdf_instruction MP
  if message_debug
    console "MP " ; display pick:0 ; console eol
  pop

pdf_instruction DP
  if message_debug
    console "DP " ; display pick:1 ; console " " ; display pick:0 ; console eol
  pop 2

pdf_instruction BMC
  if message_debug
    console "BMC " ; display pick:0 ; console eol
  pop

pdf_instruction BDC
  if message_debug
    console "BDC " ; display pick:1 ; console " " ; display pick:0 ; console eol
  pop 2

pdf_instruction EMC
  if message_debug
    console "EMC" eol
  void


#-------------------------------------------------------------------------
#   main function


function pdf_instruction_prototype pdf f
  arg_rw PDFReader pdf ; arg Function f
  indirect

method pdf process_instructions
  arg_rw PDFReader pdf
  implicit pdf
    while { var Str t := parse ; t<>"" and t<>"endstream" }
      if debug
        console t
        for (var Int i) (min count-1 7) 0 step -1
          console " " ; display pick:i
        console eol
      var Pointer:Arrow p :> pdf_instructions first t
      if p<>null
        instruction := t
        pdf_instruction_prototype pdf (p map Function)
        instruction := ""
        if status=failure
          return
      else
        if debug
          console "TROUBLE" eol
        warning "unsupported instruction '"+t+"'"
        pop count
    if t="" and addressof:stream<>addressof:raw_stream
      stream :> raw_stream
      t := token
    if t="endstream"
      t := token
    if t<>"endobj" 
      warning "missing page end '"+t+"'"


method pdf scan_pages_list a pages_array
  arg_rw PDFReader pdf ; arg Address a ; arg_rw Array pages_array
  var Link:Array kids :> ((a as Dictionary) first "Kids") as Array
  for (var Int i) 0 kids:size-1
    var Address b := pdf solve kids:i
    if (((b as Dictionary) first "Type") as Ident)="Page"
      pages_array size += 1
      pages_array pages_array:size-1 := kids i
    if (((b as Dictionary) first "Type") as Ident)="Pages"
      pdf scan_pages_list b pages_array


method pdf load base_stream options draw -> status
  oarg_rw PDFReader pdf ; arg_rw Stream base_stream ; arg Str options ; arg_rw DrawPrototype draw ; arg ExtendedStatus status
  implicit pdf
    separated := options option "separated"
    packed := options option "packed" Intn 16*2^20
    stream :> base_stream
    raw_stream :> base_stream
    pdf options := options
    var Intn fsize := (file_query stream:name standard) size
    if fsize<64
      return failure:"File is too short"
    stream safe_configure "seek "+(string fsize-64)
    stream readline
    var Str l := stream readline
    while not stream :atend and { var Str next := stream  readline ; next<>"%%EOF" }
      l := next
    if not (l parse (var Intn offset))
      return failure:"Failed to find reference table"
    var Link:Dictionary root :> null map Dictionary
    part scan_reference
      stream configure "seek "+string:offset
      if pdf:token<>"xref"
        return failure:"Corrupted reference table (1)"
      while { var Str l := stream readline ; l<>"trailer" }
        if (l parse (var Int first) (var Int nb))
          if count<0 or nb>65536
          if nb<0 or nb>65536
            return failure:"Incorrect object number in reference"
          for (var Int i) 0 nb-1
            var Str l := stream readline
            if (l parse (var Intn offset) (var Int version) word:"f")
              var PDFObject obj
              obj offset := offset
              obj cache_id := generate_id
              objects insert (string first+i)+" "+string:version obj
            eif (l parse (var Intn offset) (var Int version) word:"n")
              var PDFObject obj
              obj offset := offset
              obj cache_id := generate_id
              objects insert (string first+i)+" "+string:version obj
            else
              return (failure "Unsupported reference: "+l)
        eif (l 0 1)="%"
          void
        else
          return (failure "Unsupported reference instruction: "+l)
      var Str t := parse
      if t<>"startxref"
        return (failure "Unsupported trailer end: "+t)
      if not (pick:0 is Dictionary)
        return failure:"unsupported trailer content"
      var Link:Dictionary trailer :> pop as Dictionary
      if not exists:root
        root :> solve:(trailer first "Root") map Dictionary
      var Int prev := (trailer first "Prev") as Int
      if prev<>undefined
        offset := prev
        restart scan_reference
    if not (addressof:root is Dictionary)
      return failure:"failed to find root content"
    if debug or debug_header
      console "root " ; display addressof:root ; console eol
    var Link:Dictionary pages :> solve:(root first "Pages") as Dictionary
    if debug or debug_header
      console "pages " ; display addressof:pages ; console eol
    pdf scan_pages_list addressof:pages (var Array pages_array)
    pdf draw :> draw
    var CBool first_page := true
    if separated
      var Str gamutname := options option "gamut" Str
      pdf gamut :> color_gamut gamutname
      if pdf:gamut=failure
        return (failure "Incorrect gamut '"+gamutname+"' ("+pdf:gamut:message+")")
    for (var Int page_num) (shunt separated 0 (options option "page" Int 1)-1) (shunt separated pdf:gamut:dimension-1 (options option "page" Int pages_array:size)-1)
      pdf page_num := page_num
      context fill_mode := 0
      context stroke_mode := 0
      context transparency := 0
      context line_width := 0
      text font :> null map Font
      text fontdef :> new Dictionary
      text scale := 1
      text tlm := transform 0 0 1 1 0 0
      text tm := text tlm
      if separated
        memory_clear (addressof context:fill_color) pdf:gamut:pixel_size
        memory_clear (addressof context:stroke_color) pdf:gamut:pixel_size
        if page_num<pdf:gamut:dimension
          context fill_mode := 1
          context:fill_color:bytes page_num := 255
          context:fill_color:bytes pdf:gamut:dimension+page_num := 255
          context stroke_mode := 1
          context:stroke_color:bytes page_num := 255
          context:stroke_color:bytes pdf:gamut:dimension+page_num := 255
      else
        context fill_gamut :> color_gamut "pantone:process_black+transparencies"
        context:fill_color:bytes 0 := 255
        context:fill_color:bytes 1 := 255
      if page_num<0 or page_num>=pages_array:size
        return (failure "no page "+(string page_num+1))
      var Link:Dictionary page :> (pdf solve pages_array:page_num) as Dictionary
      if debug or debug_header
        console "page " ; display addressof:page ; console eol
      context t := transform 0 0 25.4/72 25.4/72 0 0
      var Link:Array box :> solve:(page first "CropBox") as Array
      if box:size<4
        box :> solve:(page first "MediaBox") as Array
      var Float bx0 := box:0 as Float
      var Float by0 := box:1 as Float
      var Float bx1 := box:2 as Float
      var Float by1 := box:3 as Float
      if bx0=undefined or by0=undefined or bx1=undefined or by1=undefined
        bx0 := 0 ; by0 := 0 ; bx1 := 210*72/25.4 ; by1 := 297*72/25.4
      if bx1<=bx0 or by1<=by0
        return (failure "Incorrect page format "+(string (bx1-bx0)/72*25.4)+" x "+(string (by1-by0)/72*25.4))
      context t := compose (transform -bx0 -by1 1 1 0 0) (transform 0 0 25.4/72 -25.4/72 0 0)
      pdf xobject_dict :> new Dictionary
      pdf colorspace_dict :> new Dictionary
      pdf gs_dict :> new Dictionary
      pdf shading_dict :> new Dictionary
      var Link:Dictionary res :> solve:(page first "Resources") map Dictionary
      if not exists:res
        res :>  solve:(pages first "Resources") as Dictionary
      # console "ressources " ; display addressof:res ; console eol
      pdf xobject_dict :> solve:(res first "XObject") as Dictionary
      pdf colorspace_dict :> solve:(res first "ColorSpace") as Dictionary
      # console "colorspaces are " ; display addressof:colorspace_dict true ; console eol
      if first_page
        var Str gamutname := options option "gamut" Str
        if gamutname=""
          var Int maxi := 4
          each colorspace colorspace_dict
            var Link:Array a :> solve:colorspace as Array
            # console "  " ; display addressof:a ; console eol
            if a:size>=2 and (a:0 as Ident)="DeviceN"
              maxi := max maxi (a:1 as Array):size
          var Str gamutname := "+" ; var CBool some := false
          for (var Int count) maxi 1 step -1
          var (Dictionary Str Str) already := var (Dictionary Str Str) no_inks
          part gamut_lap
            var (Dictionary Str Str) possible := var (Dictionary Str Str) no_inks
            var (Dictionary Str Str) rejected := var (Dictionary Str Str) no_inks
            each colorspace colorspace_dict
              (var Array:Str inks) size := 0
              var Link:Array a :> solve:colorspace as Array
              if a:size>=2 and (a:0 as Ident)="Separation" and count=1
                var Str ink := real_color_name (a:1 as Ident)
                if (gamutname search "+"+ink+"+" -1)=(-1) and ink<>"all"
                  gamutname += ink+"+" ; some := true
              eif a:size>=2 and (a:0 as Ident)="DeviceN" and (a:1 as Array):size=count
                var Link:Array inks :> a:1 as Array
                for (var Int i) 0 inks:size-1
                  var Str ink := real_color_name (inks:i as Ident)
                  if (gamutname search "+"+ink+"+" -1)=(-1)
                    gamutname += ink+"+" ; some := true
              eif (solve:colorspace as Ident)="DeviceCMYK" and count=4
              if a:size>=2 and (a:0 as Ident)="Separation"
                inks += real_color_name (a:1 as Ident)
              eif a:size>=2 and (a:0 as Ident)="DeviceN"
                var Link:Array devn :> a:1 as Array
                for (var Int i) 0 devn:size-1
                  inks += real_color_name (devn:i as Ident)
              eif (solve:colorspace as Ident)="DeviceCMYK"
                for (var Int i) 0 3
                  var Str ink := "process_"+(shunt i=0 "cyan" i=1 "magenta" i=2 "yellow" "black")
                  if (gamutname search "+"+ink+"+" -1)=(-1)
                    gamutname += ink+"+" ; some := true
          if some
            gamutname := "pantone:"+(gamutname 1 gamutname:len)+"transparencies"
                  inks += "process_"+(shunt i=0 "cyan" i=1 "magenta" i=2 "yellow" "black")
              var Int i := 0
              while i<inks:size and exists:(already first inks:i)
                i += 1
              if i<inks:size and not exists:(possible first inks:i)
                possible insert inks:i inks:i
              for (var Int j) i+1 inks:size-1
                if not exists:(rejected first inks:j)
                  rejected insert inks:j inks:j
            var Str selected := ""
            each k possible
              if not exists:(rejected first k)
                if selected=""
                  selected := k
                else
                  if debug_gamut
                    each colorspace colorspace_dict
                      console "colorspace " ; display colorspace true ; console eol
                  return (failure "Ambigious inks order between '"+selected+"' and '"+k+"'")
            if selected<>""
              gamutname += selected+"+"
              already insert selected selected
              restart gamut_lap
          if gamutname<>""
            gamutname := "pantone:"+gamutname+"transparencies"
          else
            gamutname := "rgb"
        if debug_gamut
          console "PDF gamut is " gamutname eol
        pdf gamut :> color_gamut gamutname
        if pdf:gamut=failure
          return (failure "Incorrect gamut '"+gamutname+"' ("+pdf:gamut:message+")")
        draw setup (image_prototype 0 0 (bx1-bx0)/72*25.4 (by1-by0)/72*25.4 undefined undefined pdf:gamut) options+(shunt separated "" " page_count "+(string pages_array:size))
        if (options option "header")
          return success
        first_page := false
      pdf gs_dict :> solve:(res first "ExtGState") as Dictionary
      pdf font_dict :> solve:(res first "Font") as Dictionary
      pdf shading_dict :> solve:(res first "Shading") as Dictionary
      var Link:Array contents
      var Address c := solve:(page first "Contents")
      if (c is Array)
        contents :> c as Array
      eif (c is Dictionary)
        contents :> new Array
        contents size := 1
        contents 0 := c
      else
        return failure:"no page content"
      for (var Int i) 0 contents:size-1
        var Link:Dictionary content :> (solve contents:i) map Dictionary
        if not (addressof:content is Dictionary)
          return failure:"no page content"
        stream configure "seek "+(string cobject:seek)
        stream :> filter content (var Link:ImageReadFilter decoder)
        process_instructions
        stream :> raw_stream
        if pdf:status=failure
          return pdf:status
      if pdf:count>0
        warning (string pdf:count)+" dust objects on the stack"
        pop count
    status := success

draw_record_filters ".pdf" PDFReader true Void false