Patch title: Release 94 bulk changes
File: /pliant/graphic/vfilter/postscript.pli
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/admin/file.pli"
module "/pliant/admin/execute.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/vfilter/prototype.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/curve/mode.pli"
module "/pliant/math/transform.pli"
module "/pliant/math/matrix.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/graphic/misc/bytes.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/language/stream/pipe.pli"

function ps_string f -> s
  arg Float f ; arg Str s
  if abs:f<1e-9
    s := "0"
    s := string f

type DrawWriteFilterPsPending
  field Array:Curve curves
  field Int mode
  field Transform2 t
  field Int counter
  field ColorBuffer pending

type DrawWriteFilterPs
  field Pointer:Stream stream
  field ImagePrototype proto
  field Float ox oy
  field Link:ColorGamut gamut
  field Int dim transp
  field Array:Str temps
  field (Array Pointer:Stream) streams
  field Array:Stream real_streams
  field Int counter <- 0
  field ExtendedStatus status
  field Array:Curve clip_curves
  field Int clip_mode
  field Transform2 clip_t
  field ColorBuffer clip_pending
  field CBool optimize
  field List:DrawWriteFilterPsPending pending_stack

DrawWriteFilter maybe DrawWriteFilterPs

method f open stream options proto -> status
  arg_rw DrawWriteFilterPs f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype proto ; arg ExtendedStatus status
  f stream :> stream
  f ox := proto x0
  f oy := proto y1
  f proto := proto
  f gamut :> proto gamut
  f dim := f:gamut dimension
  f transp := f:gamut transparency
  var Pointer:Stream s :> stream
  s writeline "%!PS"
  s writeline "%%Creator: Pliant "+string:pliant_release_number
  s writeline "%%HiResBoundingBox: 0 0 "+(ps_string (proto:x1-proto:x0)/25.4*72)+" "+(ps_string (proto:y1-proto:x0)/25.4*72)
  s writeline "%%PliantOrigin: "+(ps_string -(proto:x0)/25.4*72)+" "+(ps_string proto:y1/25.4*72)
  s writeline "%%PliantDrawModel: vector"
  s writeline "%%PliantColorModel: separated"
  s writeline "%%PliantColorGamut: "+proto:gamut:name
  s writeline "%%Pages: "+(string f:dim)
  s writeline "%%DocumentData: Binary"
  s writeline "%%BeginSetup"
  s writeline (ps_string (proto:x1-proto:x0)/25.4*72)+" "+(ps_string (proto:y1-proto:y0)/25.4*72)+" 0 1 statusdict begin setpageparams end"
  s writeline "%%EndSetup"
  f:temps size := f dim
  f:real_streams size := f dim
  f:streams size := f dim
  for (var Int i) 0 f:dim-1
    if i=0
      f:streams i :> stream
      f:temps i := file_temporary
      f:real_streams:i open f:temps:i out+safe
      f:streams i :> f:real_streams:i
    var Pointer:Stream s :> f:streams i
    s writeline "%%Page: "+(string i+1)+" "+(string i+1)
    s writeline "%%PlateColor: "+(proto:gamut query "component_name "+string:i)
    s writeline "%%BeginDocument: "+(proto:gamut query "component_name "+string:i)
  f optimize := not (options option "no_optimize")
  f status := success
  memory_clear (addressof f:clip_pending) f:dim
  status := success

method f close -> status
  arg_rw DrawWriteFilterPs f ; arg ExtendedStatus status
  var Pointer:Stream s :> f stream
  for (var Int i) 0 f:dim-1
    var Pointer:Stream s :> f:streams i
    s writeline "%%EndDocument"
    s writeline "showpage"
    if i>0
      s open f:temps:i in+safe+bigcache
      while not s:atend and f:stream=success
        raw_copy s f:stream 1 4*2^20
      s close
      file_delete f:temps:i
  f:stream writeline "%%EOF"
  status := f status

if false
  method f image_prototype options -> proto
    oarg DrawWriteFilterPs f ; arg Str options ; arg ImagePrototype proto
    proto := f proto

method f writeline l color
  arg DrawWriteFilterPs f ; arg Str l ; arg Address color
  for (var Int i) 0 f:dim-1
    if color=null or i>=f:transp or (color map uInt8 f:dim+i)<>0
      var Pointer:Stream s :> f:streams i
      s writeline l

method f point p -> s
  arg DrawWriteFilterPs f ; arg Point2 p ; arg Str s
  s := (ps_string (p:x-f:ox)/25.4*72)+" "+(ps_string (f:oy-p:y)/25.4*72)

method f point x y t -> s
  arg DrawWriteFilterPs f ; arg Float x y ; arg Transform2 t ; arg Str s
  s := f point t:(point x y)

method f ps_curves curves t color
  arg_rw DrawWriteFilterPs f ; arg Array:Curve curves ; arg Transform2 t ; arg Address color
  for (var Int j) 0 curves:size-1
    var Pointer:Curve c :> curves j
    if c=failure
      f status := failure "some curve is broken"
    eif (c:mode .and. bezier)<>0
      var CurvePoint p := c point 0
      f writeline (f point p:x p:y t)+" moveto" color
      for (var Int k) 1 c:size
        var CurvePoint p := c point k-1
        var CurvePoint q := c point (shunt k=c:size 0 k)
        if p:out_x=0 and p:out_y=0 and q:in_x=0 and q:in_y=0
          f writeline (f point q:x q:y t)+" lineto" color
          f writeline (f point p:x+p:out_x p:y+p:out_y t)+" "+(f point q:x+q:in_x q:y+q:in_y t)+" "+(f point q:x q:y t)+" curveto" color
      var Array:Point2 pts := c polyline t 1e-3
      f writeline (f point pts:0)+" moveto" color
      for (var Int k) 1 pts:size-1
        f writeline (f point pts:k)+" lineto" color

method f do_clip i
  arg_rw DrawWriteFilterPs f ; arg Int i
  if f:clip_pending:bytes:i<>0
    memory_clear addressof:(var ColorBuffer color) f:dim+f:transp
    color:bytes f:dim+i := 255
    f ps_curves f:clip_curves f:clip_t addressof:color
    f writeline (shunt f:clip_mode=fill_evenodd "eoclip" "clip") addressof:color
    f writeline "newpath" addressof:color
    f:clip_pending:bytes i := 0
  if f:optimize
    each p f:pending_stack
      if p:pending:bytes:i=1
        memory_clear addressof:(var ColorBuffer color) f:dim+f:transp
        color:bytes f:dim+i := 255
        f writeline "gsave" addressof:color
        f writeline "%id "+(string p:counter)+" clip" addressof:color
        f ps_curves p:curves p:t addressof:color
        f writeline (shunt p:mode=fill_evenodd "eoclip" "clip") addressof:color
        f writeline "newpath" addressof:color
        p:pending:bytes i := 2

method f image img t
  oarg_rw DrawWriteFilterPs f ; oarg_rw ImagePrototype img ; arg Transform2 t
  if img:gamut:transparency>0
    f status := failure "images with transparency channels are not supported"
  f counter += 1
  for (var Int i) 0 f:gamut:dimension-1
    for (var Int j) 0 img:gamut:dimension-1
      if (img:gamut query "component_name "+string:j)=(f:gamut query "component_name "+string:i)
        f do_clip i
        var Pointer:Stream s :> f:streams i
        s writeline "%id "+(string f:counter)+" image"
        s writeline "/scanline "+(string img:size_x)+" string def"
        var Transform2 tt
        tt := compose t (transform -(f:ox) -(f:oy) 1 1 0 0) (transform 0 0 72/25.4 -72/25.4 0 0)
        tt := compose (compose (transform img:x0 img:y0 img:x1-img:x0 img:y1-img:y0 0 0) t) (compose (transform -(f:ox) -(f:oy) 1 1 0 0) (transform 0 0 72/25.4 -72/25.4 0 0))
        tt := compose reverse:tt (transform 0 0 img:size_x img:size_y 0 0)
        var Matrix m := tt matrix
        # s writeline "%origin "+(string f:ox)+" "+(string f:oy)
        # s writeline "%image "+(string img:x0)+" "+(string img:y0)+" "+(string img:x1)+" "+(string img:y1)+" "+(string img:size_x)+" "+(string img:size_y)
        # s writeline "%matrix "+(string t:xx)+" "+(string t:xy)+" "+(string t:xt)+" "+(string t:yx)+" "+(string t:yy)+" "+(string t:yt)
        s writeline (string img:size_x)+" "+(string img:size_y)+" 8 [lb]"+ps_string:(m 0 0)+" "+ps_string:(m 1 0)+" "+ps_string:(m 0 1)+" "+ps_string:(m 1 1)+" "+ps_string:(m 0 2)+" "+ps_string:(m 1 2)+"[rb] { currentfile scanline readstring pop }"
        s writeline "%%BeginBinary: "+(string img:size_x*img:size_y+"colorimage[lf]":len)
        s writeline "image"
        var Address src := memory_allocate img:line_size null
        var Address dest := memory_allocate img:size_x null
        for (var Int y) 0 img:size_y-1
          img read 0 y img:size_x src
          bytes_copy_255minus (src translate Byte j) img:pixel_size dest 1 img:size_x
          s raw_write dest img:size_x
        memory_free src
        memory_free dest
        s writeline "%%EndBinary"

method f fill curves mode t color
  oarg_rw DrawWriteFilterPs f ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  f counter += 1
  for (var Int i) 0 f:dim-1
    if i>=f:transp or (color map uInt8 f:dim+i)<>0
      f do_clip i
      var Pointer:Stream s :> f:streams i
      s writeline "%id "+(string f:counter)+" fill"
      s writeline (string 1-(color map uInt8 i)/255)+" setgray"
  f ps_curves curves t color
  f writeline (shunt mode=fill_evenodd "eofill" "fill") color

type DrawClipFilterPs
  field Pointer:DrawWriteFilterPs f
  field CBool done <- false

DrawPrototype maybe DrawClipFilterPs

method clip image img t
  oarg_rw DrawClipFilterPs clip ; oarg_rw ImagePrototype img ; arg Transform2 t
  clip:f status := failure "image clipping is not supported"

method clip fill curves mode t color
  oarg_rw DrawClipFilterPs clip ; arg Array:Curve curves ; arg Int mode ; arg Transform2 t ; arg Address color
  var Pointer:DrawWriteFilterPs f :> clip f
  if (color map uInt8)<>255
    f status := failure "halftone clipping is not supported"
  if clip:done
    f status := failure "multi instructions clipping is not supported"
  for (var Int i) 0 f:dim-1
    if f:clip_pending:bytes:i<>0
      # console "double clipping " i eol
      f do_clip i
  if f:dim>f:transp
  f counter += 1
  if f:optimize
    var Pointer:DrawWriteFilterPsPending p :> f:pending_stack last
    p curves := curves
    p mode := mode
    p t := t
    p counter := f counter
    for (var Int i) 0 f:dim-1
      p:pending:bytes i := 1
    f writeline "%id "+(string f:counter)+" clip" null
    f ps_curves curves t null
    f writeline (shunt mode=fill_evenodd "eoclip" "clip") null
    f writeline "newpath" null
    f clip_curves := curves
    f clip_mode := mode
    f clip_t := t
    for (var Int i) 0 f:dim-1
      f:clip_pending:bytes i := 1
  clip done := true

method f clip_open x0 y0 x1 y1 -> dc
  oarg_rw DrawWriteFilterPs f ; arg Float x0 y0 x1 y1 ; arg Link:DrawPrototype dc
  f writeline "gsave" null
  if f:optimize
    var DrawWriteFilterPsPending p
    memory_clear (addressof p:pending) f:dim
    f pending_stack += p
    f writeline "gsave" null
  var Link:DrawClipFilterPs clip :> new DrawClipFilterPs
  clip f :> f
  dc :> clip

method f clip_close
  oarg_rw DrawWriteFilterPs f
  for (var Int i) 0 f:dim-1
    if f:clip_pending:bytes:i=0
      f:streams:i writeline "grestore"
      f:clip_pending:bytes i := 0
  if f:optimize
    var Pointer:DrawWriteFilterPsPending p :> f:pending_stack last
    for (var Int i) 0 f:dim-1
      if p:pending:bytes:i=2
        f:streams:i writeline "grestore"
    f:pending_stack remove p
    f writeline "grestore" null

method f image_prototype options -> proto
  oarg DrawWriteFilterPs f ; arg Str options ; arg ImagePrototype proto
  proto := f proto


type DrawReadFilterPs

DrawReadFilter maybe DrawReadFilterPs

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 f load stream options draw -> status
  oarg_rw DrawReadFilterPs f ; arg_rw Stream stream ; arg Str options ; oarg_rw DrawPrototype draw ; arg ExtendedStatus status
  var Str pdf_temp := file_temporary
  stream_pipe (var Str gs_in_pipe) (var Str gs_out_pipe)
  stream_pipe (var Str gmt_in_pipe) (var Str gmt_out_pipe)
  var Sem gs_sem
  gs_sem request
    part convert "convert PostScript to PDF"
      execute "gs -q -sDEVICE=pdfwrite -dCompressPages=false -dEncodeColorImages=false -dEncodeGrayImages=false -dEncodeMonoImages=false -dSubsetFonts=false -sOutputFile="+file_os_name:pdf_temp+" -dNOPAUSE -dSAFER - -c quit" input gs_in_pipe
    share:gs_sem release
  var Str gamutname
  var Sem gmt_sem
  gmt_sem request
    part discover "discover PostScript gamut"
      share gamutname := "pantone:"
      share gamutname := (options option "color_device" Str "pantone")+":"
      var CBool newpage := false
      (var Stream ps) open gmt_in_pipe in+safe+anyeol
      while not ps:atend
        var Str l := ps readline ; ps recover
        if (l 0 1)="%"
          if (l parse "%%" "BeginBinary" ":" (var Int count))
            while count>0 and not ps:atend
              ps read_available (var Address adr) (var Int size) count
              count -= size
          eif (l parse "%%" "Page" ":" any)
            newpage := true
          eif (l parse "%%" "PlateColor" ":" any:(var Str colorname)) and newpage
            gamutname += (shunt (gamutname gamutname:len-1)<>":" "+" "")+real_color_name:colorname
            newpage := false
      if gamutname<>"pantone:"
      if gamutname<>(options option "color_device" Str "pantone")+":"
        gamutname += "+transparencies"
        gamutname := ""
    share:gmt_sem release
  (var Stream gs_out) open gs_out_pipe out+safe
  (var Stream gmt_out) open gmt_out_pipe out+safe
  while not stream:atend and gs_out=success and gmt_out=success
    stream read_available (var Address adr) (var Int size)
    gs_out raw_write adr size
    gmt_out raw_write adr size
  gs_out close ; gmt_out close
  gs_sem request ; gs_sem release
  gmt_sem request ; gmt_sem release
  var Link:Stream pdf_stream :> new Stream
  pdf_stream open pdf_temp in+safe
  var Link:DrawReadFilter pdf_filter :> draw_read_filter ".pdf"
  status := pdf_filter load pdf_stream options+" share_fonts_with_same_name"+(shunt gamutname<>"" " separated gamut "+string:gamutname " gamut [dq]rgb[dq]") draw
  pdf_stream close
  file_delete pdf_temp

draw_record_filters ".ps" DrawReadFilterPs false DrawWriteFilterPs false