Patch title: Release 85 bulk changes
Abstract:
File: /pliant/graphic/vector/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/admin/file.pli"
module "/pliant/math/transform.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/matrix.pli"
module "/pliant/graphic/vector/prototype.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/misc/bytes.pli"
module "/pliant/graphic/misc/float.pli"

constant verbose true
constant verbose2 false

# 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


#-------------------------------------------------------------------------
#   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 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 Float line_width

type PDFText
  field Link:Font font ; field Float scale
  field Transform2 t

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

type PDFReader
  field Link:Stream raw_stream stream
  field CBool separated ; field Int page_num
  field Array stack ; field Int count <- 0
  field PDFContext context ; field List:PDFContext context_stack
  field PDFText text ; field List:PDFText text_stack
  field (Dictionary Str PDFObject) objects
  field Link:Dictionary xobject_dict colorspace_dict gs_dict font_dict
  field Pointer:PDFObject cobject
  field Array:Curve curves ; field Curve curve
  field Link:DrawPrototype draw
  field Str error


type PDFReference
  field Str id


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


method pdf report err
  arg_rw PDFReader pdf ; arg Str err
  if pdf:error=""
    console err eol
    pdf error := err

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<=0
      error error_id_unexpected "no argument to pop on the PDF stack"
    a := stack count-1
    count -= 1

method pdf type index -> t
  arg_rw PDFReader pdf ; arg Int index ; arg_R Type t
  implicit pdf
    if index>=count
      error error_id_unexpected "not enough arguments on the PDF stack"
    t :> entry_type (stack count-1-index)

method pdf pick index -> a
  arg_rw PDFReader pdf ; arg Int index ; arg Address a
  implicit pdf
    if index>=count
      error error_id_unexpected "not enough arguments on the PDF stack"
    a := stack count-1-index

function a_float a -> f
  arg Address a ; arg Float f
  var Pointer:Type t :> entry_type a
  if t=Int
    f := a map Int
  eif t=Float
    f := a map Float
  else
    f := undefined

method pdf float index -> f
  arg_rw PDFReader pdf ; arg Int index ; arg Float f
  f := a_float (pdf pick index)

method pdf pop n
  arg_rw PDFReader pdf ; arg Int n
  implicit pdf
    if count<n
      error error_id_unexpected "too many arguments poped on the PDF stack"
    count -= n


method pdf display a
  arg_rw PDFReader pdf ; arg Address a
  implicit pdf
    var Pointer:Type t :> entry_type a
    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
      console " >>"
    eif t=Array
      console "[lb]"
      for (var Int i) 0 (a map Array):size-1
        console " "
        pdf display (a map Array):i
      console " [rb]"
    eif t=PDFReference
      console (cast (a map PDFReference):id Str)
    else
      console "?"

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


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


gvar (Array CBool 256) stopper
function init_stoppers
  for (var Int i) 0 255
    stopper i := false
  stopper " ":number := true
  stopper "[tab]":number := true
  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

method pdf token -> t
  arg_rw PDFReader pdf ; arg Str t
  part readline
    var Str l := pdf:stream readline
    while (l 0 1)=" " or (l 0 1)="[tab]"
      l := l 1 l:len
    if (l 0 1)="%"
      l := ""
    if l="" and not pdf:stream:atend
      restart readline
  var Int u
  if (l 0 1)="("
    u := (l search ")" l:len-1)+1
  eif (l 0 1)="[lb]" or (l 0 1)="[rb]"
    u := 1
  eif (l 0 2)="<<" or (l 0 2)=">>"
    u := 2
  eif (l 0 1)="<"
    u := (l search ">" l:len-1)+1
  else
    u := 1
    while u<l:len and not (stopper l:u:number)
      u += 1
  t := l 0 u
  if u<l:len
    pdf:stream unreadline (l u l:len)

type PDFMark
  field Str id

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

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 parse -> t
  arg_rw PDFReader pdf ; arg Str t
  implicit pdf
    while true
      t := pdf token
      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 (entry_type pick:n)<>PDFMark
          n += 1
        if n%2<>0
          report "wrong number of arguments in dictionary"
          return ""
        for (var Int i) 0 n-1 step 2
          if (type n-1-i)<>Ident
            report "wrong argument type in dictionary "+(type n-1-i):name
            return ""
        var Link:Dictionary dict :> new Dictionary
        for (var Int i) 0 n-1 step 2
          dict insert (cast ((pick n-1-i) map Ident) Str) 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 count<2 or type:1<>Int or type:0<>Int
          report "wrong arguments for 'R' instruction"
          return ""
        var Link:PDFReference ref :> new PDFReference
        ref id := string:(pick:1 map Int)+" "+string:(pick:0 map 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<>null and entry_type:a=PDFReference
      var Str id := (a map PDFReference) id
      var Pointer:PDFObject object :> pdf:objects first id
      if not exists:object
        report "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"
            report "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
            report "unsupported token '"+t+"'"
            leave read
          if count<>base+1
            report "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
      

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


method pdf new_curve
  arg_rw PDFReader pdf
  implicit pdf
    if curve:size>0
      curve compute outline+bezier
      curves += curve
    curve reset

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

function '-' p1 p2 -> v
  arg Point2 p1 p2 ; arg Vector2 v
  v x := p1:x-p2:x
  v y := p1:y-p2:y

function '+' p1 v -> p2
  arg Point2 p1 ; arg Vector2 v ; arg Point2 p2
  p2 x := p1:x+v:x
  p2 y := p1:y+v:y

function '*' c v -> w
  arg Float c ; arg Vector2 v w
  w x := c*v:x
  w y := c*v:y

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

function orthogonal v -> w
  arg Vector2 v w
  w x := -(v y)
  w y := v x

function resize v d -> w
  arg Vector2 v ; arg Float d ; arg Vector2 w
  w := (d/norme:v)*v

function intersection a b c d -> i
  arg Point2 a b c d i
  var Float m := a:y-b:y      # we have to solve (m n) * (X) = (x)
  var Float n := b:x-a:x      #                  (o p)   (Y)   (y)
  var Float o := c:y-d:y
  var Float p := d:x-c:x
  var Float det := m*p-o*n
  var Float x := a:x*m+a:y*n
  var Float y := c:x*o+c:y*p
  i x := (p*x-n*y)/det
  i y := (m*y-o*x)/det 

function '+=' c p
  arg_rw Curve c ; arg Point2 p
  c angle p:x p:y

function corner p0 p1 p2 width line
  arg Point2 p0 p1 p2 ; arg Float width ; arg_rw Curve line
  var Vector2 o01 := resize (orthogonal p1-p0) width/2
  var Vector2 o12 := resize (orthogonal p2-p1) width/2
  var Point2 q0 := p0+o01
  var Point2 q1 := p1+o01
  var Point2 q2 := p1+o12
  var Point2 q3 := p2+o12
  var Point2 inter := intersection q0 q1 q2 q3
  if inter:x=undefined or inter:y=undefined
    line += q1
    line += q2
  eif (norme inter-q1)>width or (norme inter-q2)>width
    line += q1+(resize inter-q1 width)
    line += q2+(resize inter-q2 width)
  else
    line += inter

function line curve width -> line
  arg Curve curve ; arg Float width ; arg Curve line
  var Float epsilon := 1e-3
  var Array:Point2 points := curve polyline transform epsilon
  var Int j := 1
  while j<points:size
    if (norme (points j)-(points j-1))<epsilon/10
      for (var Int k) j points:size-2
        points k := points k+1
      points size -= 1
    else
      j += 1
  line reset
  line += points:0+(resize (orthogonal points:1-points:0) width/2)
  for (var Int j) 0 points:size-3
    corner (points j) (points j+1) (points j+2) width line
  line += (points points:size-1)+(resize (orthogonal (points points:size-1)-(points points:size-2)) width/2)
  line += (points points:size-1)+(resize (orthogonal (points points:size-2)-(points points:size-1)) width/2)
  for (var Int j) points:size-1 2 step -1
    corner (points j) (points j-1) (points j-2) width line
  line += points:0+(resize (orthogonal points:0-points:1) width/2)
  line compute outline


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


function real_color_name name -> real
  arg Str name real
  real := lower name
  if (real parse word:"pantone" any:(var Str remain) word:"cvc")
    real := remain
  eif (real parse word:"pantone" any:(var Str remain) word:"cv")
    real := remain
  eif (real parse word:"pantone" any:(var Str remain) word:"c")
    real := remain
  if real="cyan" or real="magenta" or real="yellow" or real="black"
    real := "process_"+real
  real := replace real " " "_"

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 draw: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 :=  draw:gamut speedup gamut ""
      draw:gamut convert gamut addressof:c addressof:real 1 speedup
      if context:transparency<2
        bytes_fill (addressof:real translate Byte draw:gamut:dimension) 1 draw:gamut:transparency
        

method pdf process_instructions -> status
  arg_rw PDFReader pdf ; arg ExtendedStatus status
  implicit pdf
    var Dictionary unknown
    while { var Str t := parse ; t<>"" and t<>"endstream" }

      if t="m" and count>=2
        new_curve
        curve += curve_point (context:t (point float:1 float:0))
        pop 2
      eif t="l" and count>=2
        curve += curve_point (context:t (point float:1 float:0))
        pop 2
      eif t="c" and count>=6 and curve:size>0
        var Point2 p2 := context:t (point float:5 float:4)
        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 float:1 float:0))
        var Point2 p2 := context:t (point float:3 float:2)
        p in p2:x-p:x p2:y-p:y
        curve += p
        pop 6
      eif t="y" and count>=4 and curve:size>0
        var Point2 p2 := context:t (point float:3 float:2)
        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 float:1 float:0))
        pop 4
      eif t="v" and count>=4
        var CurvePoint p := curve_point (context:t (point float:1 float:0))
        var Point2 p2 := context:t (point float:3 float:2)
        p in p2:x-p:x p2:y-p:y
        curve += p
        pop 4
      eif t="re" and count>=4
        new_curve
        curve += curve_point (context:t (point float:3 float:2))
        curve += curve_point (context:t (point float:3+float:1 float:2))
        curve += curve_point (context:t (point float:3+float:1 float:2+float:0))
        curve += curve_point (context:t (point float:3 float:2+float:0))
        new_curve
        pop 4
      eif t="n" # new path
        new_curve
        curves size := 0
      eif t="h" # closepath
        new_curve
      eif t="f" or t="f*" or t="F"
        new_curve
        if context:fill_mode<>0
          draw fill curves (shunt t="f" or t="F" fill_nonzero fill_evenodd) transform addressof:(real_color context:fill_gamut context:fill_color)
        curves size := 0
      eif t="s" or t="S"
        if t="s"
          new_curve
        eif curve:size>0
          curve compute bezier
          curves += curve
          curve reset
        if context:stroke_mode<>0
          for (var Int i) 0 curves:size-1
            if curves:i=success
              (var Array:Curve stroke) size := 1
              stroke 0 := line curves:i context:line_width
              draw fill stroke fill_nonzero transform addressof:(real_color context:stroke_gamut context:stroke_color)
        curves size := 0
      eif t="B" or t="B*"
        new_curve
        if context:fill_mode<>0
          draw fill curves (shunt t="B" fill_nonzero fill_evenodd) transform addressof:(real_color context:fill_gamut context:fill_color)
        if context:stroke_mode<>0
          for (var Int i) 0 curves:size-1
            if curves:i=success
              (var Array:Curve stroke) size := 1
              stroke 0 := line curves:i context:line_width
              draw fill stroke fill_nonzero transform addressof:(real_color context:stroke_gamut context:stroke_color)
        curves size := 0
      eif t="W" or t="W*"
        new_curve
        draw clip_open undefined undefined undefined undefined
        draw clip_draw_open
        var uInt8 ft := 255
        draw fill curves (shunt t="W" fill_nonzero fill_evenodd) transform addressof:ft
        draw clip_draw_close
        context clip_count += 1

      eif t="Do" and count>=1 and type:0=Ident
        var Pointer:Dictionary d :> solve:(xobject_dict first (cast (pick:0 map Ident) Str)) map Dictionary
        if exists:d and (entry_type addressof:d)=Dictionary
          var Pointer:PDFObject img_object :> cobject
          if img_object:attached=null
            console "Do " ; display addressof:d ; console eol
            var Link:Int size_x :> solve:(d first "Width") map Int
            var Link:Int size_y :> solve:(d first "Height") map Int
            var Link:Ident colorspace :> solve:(d first "ColorSpace") map Ident
            var Link:ColorGamut gamut
            if separated
              gamut :> color_gamut "pantone:"+(draw:gamut query "component_name "+string:page_num)
            eif exists:colorspace and (cast colorspace Str)="DeviceCMYK"
              gamut :> color_gamut "pantone:process_cyan+process_magenta+process_yellow+process_black"
            else
              gamut :> color_gamut ""
            var Link:Int predictor :> null map Int
            var Int pred_step := undefined
            var Int pred_left := undefined
            var Link:Dictionary parameters :> solve:(d first "DecodeParms") map Dictionary
            if exists:parameters and (entry_type addressof:parameters)=Dictionary
              predictor :> solve:(parameters first "Predictor") map Int
              var Link:Int pred_columns :> solve:(parameters first "Columns") map Int
              var Link:Int pred_bits :> solve:(parameters first "BitsPerComponent") map Int
              var Link:Int pred_colors :> solve:(parameters first "Colors") map Int
              if exists:pred_columns and (entry_type addressof:pred_columns)=Int
                if exists:pred_bits and (entry_type addressof:pred_bits)=Int
                  if exists:pred_colors and (entry_type addressof:pred_colors)=Int
                    pred_step := max (pred_columns*pred_bits*pred_colors+7)\8 1
                    pred_left := max (pred_bits*pred_colors+7)\8 1
            if not exists:predictor
              predictor :> new Int 1
            if exists:size_x and (entry_type addressof:size_x)=Int and exists:size_y and (entry_type addressof:size_y)=Int and gamut=success and gamut:pixel_size<>0
              var Link:ImagePacked packed :> new ImagePacked
              packed 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 :> raw_stream
              var Link:Ident filter_ident :> solve:(d first "Filter") map Ident
              if exists:filter_ident and (entry_type addressof:filter_ident)=Ident
                var Str filter := cast filter_ident Str
                if filter<>"FlateDecode"
                  return (failure "Unsupported '"+filter+"' encoding")
                pixels :> new Stream
                pixels open "zlib:" "" in+safe pliant_default_file_system raw_stream
              var Address buffer := (memory_zallocate packed:line_size+packed:pixel_size null) translate Byte gamut:pixel_size
              var Address previous := (memory_zallocate packed:line_size+packed:pixel_size null) translate Byte gamut:pixel_size
              var Address final := memory_zallocate packed:line_size null
              for (var Int y) 0 size_y-1
                var Int offset := 0
                while offset<packed:line_size
                  var Int algo := 0 ; var Int step := packed: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
                  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<packed:pixel_size -pred_left -(packed 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
                    return (failure "Unsupported image predictor "+string:algo)
                  memory_copy buffer (final translate Byte offset) step
                  memory_copy buffer previous step
                  offset += step
                if separated
                  bytes_copy_255minus final 1 final 1 packed:line_size
                packed write 0 size_y-1-y size_x final
              memory_free (buffer translate Byte -(packed:pixel_size))
              memory_free (previous translate Byte -(packed:pixel_size))
              memory_free final
              raw_stream configure "seek "+string:current_seek
              img_object attached := addressof packed
            else
              return failure:"Broken image"
          if cobject:attached<>null and (entry_type cobject:attached)=ImagePacked
            draw image (cobject:attached omap ImagePrototype) context:t
        else
          return failure:"Unexpected 'Do' instruction usage"
        pop 1

      eif t="cs" and count>=1 and type:0=Ident
        var Arrow a := solve (colorspace_dict first (cast (pick:0 map Ident) Str))
        if a<>null and entry_type:a=Dictionary
          console "cs " ; display a ; console eol
        eif a<>null and entry_type:a=Array and (a map Array):size>=2 and (entry_type (a map Array):0)=Ident and ((a map Array):0 map Ident)=(cast "Separation" Ident) and (entry_type (a map Array):1)=Ident
          context fill_gamut :> color_gamut "pantone:"+real_color_name:(cast ((a map Array):1 map Ident) Str)+"+transparencies"
          if context:fill_gamut=success
            bytes_fill (addressof context:fill_color) 1 context:fill_gamut:pixel_size
            context fill_mode := 1
          eif (cast ((a map Array):1 map Ident) Str)="All"
            context fill_gamut :> draw gamut
            bytes_fill (addressof context:fill_color) 1 context:fill_gamut:pixel_size
            context fill_mode := 2
          else
            return (failure "Unknown color gamut '"+(cast ((a map Array):1 map Ident) Str)+"'")
        eif (pick:0 map Ident)=(cast "Pattern" Ident)
          context fill_mode := 0
          if verbose
            console "paint pattern" eol
        else
          if a<>null
            console "colorspace " ; display a ; console eol
          return failure:"Unexpected 'cs' instruction usage"
        pop
      eif t="CS" and count>=1 and type:0=Ident
        var Arrow a := solve (colorspace_dict first (cast (pick:0 map Ident) Str))
        if a<>null and entry_type:a=Dictionary
          console "cs " ; display a ; console eol
        eif a<>null and entry_type:a=Array and (a map Array):size>=2 and (entry_type (a map Array):0)=Ident and ((a map Array):0 map Ident)=(cast "Separation" Ident) and (entry_type (a map Array):1)=Ident
          context stroke_gamut :> color_gamut "pantone:"+real_color_name:(cast ((a map Array):1 map Ident) Str)+"+transparencies"
          if context:stroke_gamut=success
            bytes_fill (addressof context:stroke_color) 1 context:stroke_gamut:pixel_size
            context stroke_mode := 1
          eif (cast ((a map Array):1 map Ident) Str)="All"
            context stroke_gamut :> draw gamut
            bytes_fill (addressof context:stroke_color) 1 context:stroke_gamut:pixel_size
            context stroke_mode := 2
          else
            return (failure "Unknown color gamut '"+(cast ((a map Array):1 map Ident) Str)+"'")
        eif (pick:0 map Ident)=(cast "Pattern" Ident)
          context stroke_mode := 0
          if verbose
            console "paint pattern" eol
        else
          if a<>null
            console "colorspace " ; display a ; console eol
          return failure:"Unexpected 'cs' instruction usage"
        pop
      eif t="sc" or t="scn"
        var Int base := 0
        if t="scn" and count>=1 and type:0=Ident
          base := 1
        if context:fill_mode=0
          pop count
        eif context:fill_mode=1 and count>=base+context:fill_gamut:dimension
          for (var Int i) 0 context:fill_gamut:dimension-1
            context:fill_color:bytes i := cast 255*(bound (float base+context:fill_gamut:dimension-1-i) 0 1) Int
          pop base+context:fill_gamut:dimension
        eif context:fill_mode=2 and count>=base+1
          for (var Int i) 0 context:fill_gamut:dimension-1
            context:fill_color:bytes i := cast 255*(bound float:base 0 1) Int
          pop base+1
        else
          return (failure "Unexpected '"+t+"' instruction usage")
      eif t="SC" or t="SCN"
        var Int base := 0
        if t="SCN" and count>=1 and type:0=Ident
          base := 1
        if context:stroke_mode=0
          pop count
        eif context:stroke_mode=1 and count>=base+context:stroke_gamut:dimension
          for (var Int i) 0 context:stroke_gamut:dimension-1
            context:stroke_color:bytes i := cast 255*(bound (float base+context:stroke_gamut:dimension-1-i) 0 1) Int
          pop base+context:stroke_gamut:dimension
        eif context:stroke_mode=2 and count>=base+1
          for (var Int i) 0 context:stroke_gamut:dimension-1
            context:stroke_color:bytes i := cast 255*(bound float:base 0 1) Int
          pop base+1
        else
          return (failure "Unexpected '"+t+"' instruction usage")
      eif t="k" and count>=4
        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
          if (float 3-i)=undefined
            return failure:"Unexpected 'k' instruction usage"
          context:fill_color:bytes i := cast 255*(bound (float 3-i) 0 1) Int
          context:fill_color:bytes 4+i := shunt (float 3-i)<>0 255 0
        pop 4
      eif t="K" and count>=4
        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
          if (float 3-i)=undefined
            return failure:"Unexpected 'k' instruction usage"
          context:stroke_color:bytes i := cast 255*(bound (float 3-i) 0 1) Int
          context:stroke_color:bytes 4+i := shunt (float 3-i)<>0 255 0
        pop 4
      eif t="g" and count>=1
        if separated
          memory_clear (addressof context:fill_color) draw:gamut:pixel_size
          if page_num<draw:gamut:dimension
            context:fill_color:bytes page_num := cast 255*(bound 1-float:0 0 1) Int
            context:fill_color:bytes draw:gamut:dimension+page_num := 255
        else
          context fill_mode := 1
          context fill_gamut :> color_gamut "pantone:process_black+transparencies"
          context:fill_color:bytes 0 := cast 255*(bound 1-float:0 0 1) Int
          context:fill_color:bytes 1 := 255
        pop
      eif t="G" and count>=1
        if separated
          memory_clear (addressof context:stroke_color) draw:gamut:pixel_size
          if page_num<draw:gamut:dimension
            context:stroke_color:bytes page_num := cast 255*(bound 1-float:0 0 1) Int
            context:stroke_color:bytes draw:gamut:dimension+page_num := 255
        else
          context stroke_mode := 1
          context stroke_gamut :> color_gamut "pantone:process_black+transparencies"
          context:stroke_color:bytes 0 := cast 255*(bound 1-float:0 0 1) Int
          context:stroke_color:bytes 1 := 255
        pop

      eif t="BT"
        text_stack += text
      eif t="ET" and (exists text_stack:first)
        text := text_stack last
        text_stack remove text_stack:last
      eif t="Tf" and count>=2 and type:1=Ident and float:0<>undefined
        var Link:Dictionary fdict :> solve:(font_dict first (cast (pick:1 map Ident) Str)) map Dictionary
        var Link:Ident fname :> solve:(fdict first "BaseFont") map Ident
        if not exists:fname or (entry_type addressof:fname)<>Ident
          fname :> new Ident (cast "" Ident)
        # console "font " (cast (pick:1 map Ident) Str) " "
        # display addressof:fdict
        # console eol
        text font :> font (cast fname Str)
        if not (exists text:font)
          console "No '"+(cast fname Str)+"' font" eol
        pop 2
      eif t="Tm" and count>=6
        (var Matrix m) resize 3 3
        m 0 0 := float 5
        m 0 1 := float 3
        m 0 2 := float 1
        m 1 0 := float 4
        m 1 1 := float 2
        m 1 2 := float 0
        m 2 0 := 0
        m 2 1 := 0
        m 2 2 := 0
        text t := transform m
        pop 6
      eif t="Tj" and count>=1 and type:0=Str
        if (exists text:font)
          draw text (cast (pick:0 map Str) Str32) text:font null undefined (compose (transform 0 0 text:scale text:scale 0 0) text:t context:t) addressof:(real_color context:fill_gamut context:fill_color)
        pop

      eif t="q"
        context_stack += context
        context clip_count := 0
      eif t="Q" and (exists context_stack:first)
        for (var Int i) 1 context:clip_count
          draw clip_close
        context := context_stack last
        context_stack remove context_stack:last
      eif t="gs"
        var Pointer:Dictionary d :> solve:(gs_dict first (cast (pick:0 map Ident) Str)) map Dictionary
        if exists:d and (entry_type addressof:d)=Dictionary
          # console "gs " ; display addressof:d ; console eol
          var Link:Bool op :> (d first "OP") map Bool
          if not exists:op
            op :> new Bool (shunt (context:transparency .and. 2)<>0 true false)
          var Link:Int opm :> (d first "OPM") map Int
          if not exists:opm
            opm :> new Int (context:transparency .and. 1)
          context transparency := (shunt op 2 0)+opm
        pop
      eif t="cm" and count>=6
        (var Matrix m) resize 3 3
        m 0 0 := float 5
        m 0 1 := float 3
        m 0 2 := float 1
        m 1 0 := float 4
        m 1 1 := float 2
        m 1 2 := float 0
        m 2 0 := 0
        m 2 1 := 0
        m 2 2 := 0
        context t := compose transform:m context:t
        pop 6

      eif t="MP" and count>=1
        pop
      eif t="DP" and count>=2
        pop 2
      eif t="BMC" and count>=1
        pop
      eif t="BDC" and count>=2
        pop 2
      eif t="EMC"
        void

      eif t="i" and count>=1
        # flatness
        pop
      eif t="w" and count>=1
        if float:0=0
          console "line width set to zero !" eol
        context line_width := norme (context:t (vector float:0 0)) # FIXME
        pop 
      eif t="M" and count>=1
        # set miter limit
        pop
      eif t="j" and count>=1
        # set line join
        pop
      eif t="J" and count>=1
        # set line cap
        pop
      eif t="ri" and count>=1
        # set rendering intents
        pop
      eif t="d" and count>=2
        # dash line pattern
        pop 2

      else
        if (unknown first t)=null
          if verbose
            console "unkown instruction " t eol
            display
          unknown insert t true addressof:void
        pop count

    if t="" and addressof:stream<>addressof:raw_stream
      stream :> raw_stream
      t := token
    if t="endstream"
      t := token
    if t<>"endobj" 
      return (failure "Missing page end ("+t+")")
    status := success


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


function pdf_rip file draw options -> status
  arg Str file ; arg_rw DrawPrototype draw ; arg Str options ; arg ExtendedStatus status
  var PDFReader pdf
  implicit pdf
    separated := options option "separated"
    raw_stream :> new Stream
    stream :> raw_stream
    stream open file in+safe+anyeol
    if pdf:stream=failure
      return failure:"Failed to open file"
    var Intn fsize := (file_query file standard) size
    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"
    stream configure "seek "+string:offset
    if stream:readline<>"xref"
      return failure:"Corrupted reference table (1)"
    part scan_reference
      while true
        var Str l := stream readline
        if (l parse (var Int first) (var Int nb))
          if count<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) offset := offset
              objects insert (string first+i)+" "+string:version obj
            eif (l parse (var Intn offset) (var Int version) word:"n")
              (var PDFObject obj) offset := offset
              objects insert (string first+i)+" "+string:version obj
            else
              return (failure "Unsupporred reference: "+l)
        eif l="trailer"
          leave scan_reference   
        eif (l 0 1)="%"
          void
        else
          return (failure "Unsupported reference instruction: "+l)
    part scan_tailer
      var Str t := parse
      if t<>"startxref"
        return (failure "Unsupported trailer end: "+t)
    if count<1 or type:0<>Dictionary
      return failure:"Unsupported trailer content"
    var Link:Dictionary trailer :> pop map Dictionary
    var Link:Dictionary root :> solve:(trailer first "Root") map Dictionary
    if not exists:root or (entry_type addressof:root)<>Dictionary
      return failure:"Unsupported root content"
    var Link:Dictionary pages :> solve:(root first "Pages") map Dictionary
    if not exists:pages or (entry_type addressof:pages)<>Dictionary
      return failure:"Not a pages object"
    var Link:Array kids :> solve:(pages first "Kids") map Array
    if not exists:kids or (entry_type addressof:kids)<>Array
      return failure:"Not a kids object"
    pdf draw :> draw
    for (var Int page_num) 0 kids: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 t := transform 0 0 1 1 0 0
      if separated
        memory_clear (addressof context:fill_color) draw:gamut:pixel_size
        if page_num<draw:gamut:dimension
          context fill_mode := 1
          context:fill_color:bytes page_num := 255
          context:fill_color:bytes draw:gamut:dimension+page_num := 255
          context stroke_mode := 1
          context:stroke_color:bytes page_num := 255
          context:stroke_color:bytes draw:gamut:dimension+page_num := 255
      var Link:Dictionary page :> (solve kids:page_num) map Dictionary
      if not exists:page or (entry_type addressof:page)<>Dictionary
        return failure:"No page"
      if verbose2
        console "page " page_num ":" eol
        display addressof:page
        console eol
      context t := transform 0 0 25.4/72 25.4/72 0 0
      var Link:Array mb :> solve:(page first "MediaBox") map Array
      if exists:mb and (entry_type addressof:mb)=Array and mb:size=4
        var Float mx0 := a_float mb:0
        var Float my0 := a_float mb:1
        var Float mx1 := a_float mb:2
        var Float my1 := a_float mb:3
        if mx0=defined and my0=defined and mx1=defined and my1=defined
          context t := compose (transform -mx0 -my1 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 font_dict :> new Dictionary
      var Link:Dictionary res :> solve:(page first "Resources") map Dictionary
      if exists:res and (entry_type addressof:res)=Dictionary
        var Link:Dictionary dict :> solve:(res first "XObject") map Dictionary
        if exists:dict and (entry_type addressof:dict)=Dictionary
          if verbose2
            console "xobject dictionary " page_num ":" eol
            display addressof:dict
            console eol
          pdf xobject_dict :> dict
        var Link:Dictionary dict :> solve:(res first "ColorSpace") map Dictionary
        if exists:dict and (entry_type addressof:dict)=Dictionary
          if verbose2
            console "colorspace dictionary " page_num ":" eol
            display addressof:dict
            console eol
          pdf colorspace_dict :> dict
        var Link:Dictionary dict :> solve:(res first "ExtGState") map Dictionary
        if exists:dict and (entry_type addressof:dict)=Dictionary
          pdf gs_dict :> dict
        var Link:Dictionary dict :> solve:(res first "Font") map Dictionary
        if exists:dict and (entry_type addressof:dict)=Dictionary
          pdf font_dict :> dict
      eif verbose
        console "no resources dictionary" eol
      var Link:Array contents :> solve:(page first "Contents") map Array
      if exists:contents and (entry_type addressof:contents)=Dictionary
        var Link:Dictionary content :> addressof:contents map Dictionary
        contents :> new Array
        contents size := 1
        contents 0 := addressof content
      for (var Int i) 0 contents:size-1
        var Link:Dictionary content :> (solve contents:i) map Dictionary
        if not (exists content) or (entry_type addressof:content)<>Dictionary
          if exists:content
            return (failure "No page content ("+(entry_type addressof:content):name+")")
          return failure:"No page content"
        if verbose2
          console "content " page_num ":" eol
          display addressof:content
          console eol
        stream configure "seek "+(string cobject:seek)
        var Link:Ident filter_ident :> solve:(content first "Filter") map Ident
        if exists:filter_ident and (entry_type addressof:filter_ident)=Ident
          var Str filter := cast filter_ident Str
          if filter<>"FlateDecode"
            return (failure "Unsupported '"+filter+"' encoding")
          stream :> new Stream
          stream open "zlib:" "" in+safe pliant_default_file_system raw_stream
        status := process_instructions
        stream :> raw_stream
        if status=failure
          if verbose
            console "PDF error: " status:message eol
            display
          return
      if count>0
        console count " dust objects on the stack at end of page " page_num ":" eol
        display
        pop count
    status := success


if false # build display list

  module "pml.pli"
  
  function test gamut_name
    arg Str gamut_name
    console "running" eol
    var Link:Stream stream :> new Stream
    stream open "file:/tmp/test.pml" out+safe
    var Link:DrawPml pml :> new DrawPml
    pml bind stream color_gamut:gamut_name ""
    var ExtendedStatus s := pdf_rip "file:/tmp/test.pdf" pml "separated"
    if s=failure
      console "failed: " s:message eol
    pml unbind
    console "done" eol

eif true # RIP

  module "image.pli"
  module "/pliant/graphic/image/prototype.pli"
  module "/pliant/graphic/image/packed.pli"
  module "/pliant/graphic/color/gamut.pli"
  module "/pliant/graphic/filter/io.pli"
  module "/pliant/graphic/image/convert.pli"
  module "/pliant/graphic/image/antialiasing.pli"
  module "/pliant/graphic/image/transparency.pli"
  
  constant mm_x 270
  constant mm_y 270
  constant res 75

  function test gamut_name options
    arg Str gamut_name ; arg Str options
    console "ripping" eol
    var Link:ImagePrototype img :> new ImagePacked
    img setup (image_prototype 0 0 mm_x mm_y res*4 res*4 4 4 image_adjust_extend color_gamut:gamut_name) ""
    var Link:ImageTransparency transp :> new ImageTransparency
    if (transp bind img "")=failure
      console "oops: failed to bind transparency"
    var Link:DrawImage draw :> new DrawImage
    draw bind transp ""
    var ExtendedStatus s := pdf_rip "file:/tmp/test.pdf" draw options
    if s=failure
      console "failed: " s:message eol
    else
      console "storing" eol
      var Link:ImageConvert conv :> new ImageConvert
      conv bind img color_gamut:"rgb" "fast"
      var Link:ImageAntiAliasing aa :> new ImageAntiAliasing
      aa bind conv 4 4
      aa save "file:/tmp/test.png" ""
      console "done" eol

# hc631
test "pantone:662+186+221+199+1635+process_cyan+process_yellow+white+forme+transparencies" "separated"
# jambon10.pdf
# test "pantone:process_cyan+process_magenta+process_yellow+process_black+485+blanc+transparencies" ""
# stick.pdf
# test "pantone:process_cyan+process_magenta+process_yellow+process_black+transparencies" ""
# ec2513 lustucru
# test "pantone:485+reflex_blue+process_cyan+process_magenta+process_yellow+white+transparencies" ""
# ec2210
# test "pantone:process_cyan+process_magenta+process_yellow+process_black+485+blanc+transparencies" ""