Patch title: Release 93 bulk changes
Abstract:
File: /graphic/filter/pcl.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# Generic PCL driver
# tested on HP Designjet large format printers

module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/math/functions.pli"
module "prototype.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/util/encoding/packbits.pli"
module "/pliant/graphic/misc/dither.pli"
module "/pliant/graphic/color/adjust.pli"
module "/pliant/graphic/misc/bytes.pli"

function generator_prototype x y head dot density f
  arg Int x y head ; arg_w Int dot density ; arg Function f
  indirect

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


method s xl_uInt8 v
  arg_rw Stream s ; arg uInt v
  var uInt8 b := 0C0h ; s raw_write addressof:b 1
  var uInt8 v8 := v ; s raw_write addressof:v8 1

method s xl_uInt16 v
  arg_rw Stream s ; arg uInt v
  var uInt8 b := 0C1h ; s raw_write addressof:b 1
  var uInt16_li v16 := v ; s raw_write addressof:v16 2

method s xl_uInt32 v
  arg_rw Stream s ; arg uInt v
  var uInt8 b := 0C2h ; s raw_write addressof:b 1
  var uInt32_li v32 := v ; s raw_write addressof:v32 4

method s xl_uInt8 v1 v2
  arg_rw Stream s ; arg uInt v1 v2
  var uInt8 b := 0D0h ; s raw_write addressof:b 1
  var uInt8 v8 := v1 ; s raw_write addressof:v8 1
  var uInt8 v8 := v2 ; s raw_write addressof:v8 1

method s xl_uInt16 v1 v2
  arg_rw Stream s ; arg uInt v1 v2
  var uInt8 b := 0D1h ; s raw_write addressof:b 1
  var uInt16_li v16 := v1 ; s raw_write addressof:v16 2
  var uInt16_li v16 := v2 ; s raw_write addressof:v16 2

method s xl_uInt32 v1 v2
  arg_rw Stream s ; arg uInt v1 v2
  var uInt8 b := 0D2h ; s raw_write addressof:b 1
  var uInt32_li v32 := v1 ; s raw_write addressof:v32 4
  var uInt32_li v32 := v2 ; s raw_write addressof:v32 4


method s xl_attr attr
  arg_rw Stream s ; arg Int attr
  var uInt8 b := 0F8h ; s raw_write addressof:b 1
  var uInt8 b := attr ; s raw_write addressof:b 1

constant xl_aUnitsPerMeasure 137

constant xl_aMeasure 134
constant xl_eInch 0

constant xl_aErrorReport 143
constant xl_eNoReporting 0
constant xl_eBackChannel 1
constant xl_eErrorPage 2
constant xl_eBackChAndErrPage 3

constant xl_aDataOrg 130
constant xl_eBinaryLowByteFirst 1

constant xl_aSourceType 136
constant xl_eDefaultSource 0

constant xl_aOrientation 40
constant xl_ePortraitOrientation 0
constant xl_eLandscapeOrientation 1

constant xl_aMediaSize 37
constant xl_eA4Paper 2
constant xl_eA3Paper 5

constant xl_aColorSpace 3
constant xl_eGrey 1
constant xl_eRGB 2

constant xl_aPaletteDepth 2
constant xl_e1Bit 0
constant xl_e4Bit 1
constant xl_e8Bit 2

constant xl_aPoint 76

constant xl_aColorMapping 100
constant xl_eDirectPixel 0
constant xl_eIndexedPixel 1

constant xl_aColorDepth 98
constant xl_aSourceWidth 108
constant xl_aSourceHeight 107
constant xl_aDestinationSize 103
constant xl_aStartLine 109
constant xl_aBlocHeight 99

constant xl_aCompressMode 101
constant xl_eNoCompression 0
constant xl_eDeltaRowCompression 3

constant xl_aPadBytesMultiple 110

method s xl_op op
  arg_rw Stream s ; arg Int op
  var uInt8 b := op ; s raw_write addressof:b 1

constant xl_oBeginSession 41h
constant xl_oOpenDataSource 48h
constant xl_oBeginPage 43h
constant xl_oSetColorSpace 6Ah
constant xl_oSetCursor 6Bh
constant xl_oBeginImage B0h
constant xl_oReadImage B1h

constant xl_oEndImage B2h
constant xl_oEndPage 44h
constant xl_oCloseDataSource 49h
constant xl_oEndSession 42h


method s xl_length length
  arg_rw Stream s ; arg Int length
  var uInt8 b := 0FAh ; s raw_write addressof:b 1
  var uInt32_li l32 := length ; s raw_write addressof:l32 4


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


type ImageWriteFilterPcl
  field Pointer:Stream stream
  field Int line_size
  field Address buffer
  field Address previous_line
  field Int size_x line_size
  field Link:ColorGamut gamut
  field Int current_y
  field CBool hpgl
  field CBool seedrow <- false
  field CBool pclxl
  field Address negative <- null
  field Address plan <- null
  field Address bits <- null
  field Array:DitherMatrix dither
  field CBool packbits <- false
  field CBool seedrow <- false
  field CBool always_compress <- false
  field Address previous_line <- null
  field Address compressed <- null

ImageWriteFilter maybe ImageWriteFilterPcl


function memory_search_difference adr1 adr2 size -> offset
  arg Address adr1 adr2 ; arg Int size ; arg Int offset
  var Address a1 := adr1 ; var Address a2 := adr2
  var Int remain := size
  while remain>=Int:size and (a1 map Int)=(a2 map Int)
    a1 := a1 translate Int 1 ; a2 := a2 translate Int 1 ; remain -= Int size
  while remain>0 and (a1 map Int8)=(a2 map Int8)
    a1 := a1 translate Int8 1 ; a2 := a2 translate Int8 1 ; remain -= 1
  offset := size-remain

function seedrow_encode src dest count previous -> csize
  arg Address src dest ; arg Int count ; arg Address previous ; arg Int csize
  var Address s := src ; var Address stop := src translate Byte count
  var Address d := dest
  var Int delta := (cast previous Int).-.(cast src Int)
  while { var Int offset := memory_search_difference s (s translate Byte delta) (cast stop Int).-.(cast s Int) ; offset<>(cast stop Int).-.(cast s Int) }
    var Address s := s translate Byte offset
    var Address s2 := s translate Byte 1
    while s2<>stop and (s2 map uInt8 delta)<>(s2 map uInt8)
      s2 := s2 translate Byte 1
    var Int replace := (cast s2 Int).-.(cast s Int)
    while replace>0
      var Int r := min replace 8 ; replace -= r
      var Int o := min offset 31 ; offset -= o
      d map uInt8 := (r-1)*2^5 + o ; d := d translate uInt8 1
      if o=31
        o := 255
        while o=255
          o := min offset 255 ; offset -= o
          d map uInt8 := o ; d := d translate uInt8 1
      memory_copy s d r ; s := s translate Byte r ; d := d translate Byte r
  csize := (cast d Int).-.(cast dest Int)

  
constant escape character:27

method f open s options h -> status
  arg_rw ImageWriteFilterPcl f ; arg_rw Stream s ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status
  if h:gamut:pixel_size<>1 and h:gamut:pixel_size<>3
    return failure:"Only 1 or 3 components images can be saved as .pcl"
  f stream :> s
  f size_x := h size_x
  f line_size := h line_size
  f buffer := memory_allocate 2*f:line_size+4 addressof:f
  f gamut :> h gamut
  f hpgl := options option "hpgl"
  f pclxl := options option "pclxl"
  if not (options option "pcl_no_compression")
    if (options option "pcl_seedrow_compression")
      f seedrow := true
    eif (options option "pcl_packbits_compression")
      f packbits := true
    else
      f seedrow := true
  var Float dpi := h:size_x/(abs h:x1-h:x0)*25.4
  s writechars escape+"E" # reset
  if f:hpgl
    s writechars escape+"%-12345X@PJL RESET[cr][lf]@PJL SET RESOLUTION = "+string:dpi+"[cr][lf]@PJL ENTER LANGUAGE = HPGL2[cr][lf]"
    s writechars escape+"%1B" # enter HP GL/2 mode
    s writechars "BP3,1,5,1;" # do not store file on the device disk and do not rotate automatically
    if (options option "hpgl_page")
      var Int nx := cast 1016.0*h:size_x/dpi+0.5 Int
      var Int ny := cast 1016.0*h:size_y/dpi+0.5 Int
      s writechars "PS"+string:ny+","+string:nx+";" # set page size
    else
      s writechars "PS;" # no page clip
    s writechars escape+"%0A" # enter HP RTL mode
  if not (options option "pcl_no_paper_size")
    # A4 = 26 , A3 = 27 , A3+ = 16, custom = 101
    s writechars escape+"&l"+(options option "pcl_paper_size" Str "101")+"A" # paper size
  if (options option "pcl_no_perforation_skip")
    s writechars escape+"&l0L" # Turn off perforation skip
  s writechars escape+"&a1N" # No negative motion - allow plotting while receiving
  if h:gamut:dimension=3
    var Int color_model := shunt h:gamut:model<>color_gamut_additive 1 (options option "sRGB") 2 0 # 0 = device RGB, 1 = device CMY, 2 = sRGB
    s writechars escape+"*v6W"+character:color_model+character:3+character:0+character:8+character:8+character:8 # select 3 bytes per pixel trivial encoding
  s writechars escape+"*t"+string:(cast dpi Int)+"R" # set resolution
  s writechars escape+"*r"+(string h:size_x)+"S" # number of pixels per line
  s writechars escape+"*r"+(string h:size_y)+"T" # number of rows
  s writechars escape+"*r1A" # start raster graphics at current position, no scaling requested
  s writechars escape+"*b"+(shunt f:seedrow "3" f:packbits "2" "0")+"M" # select compression
  f always_compress := options option "pcl_always_compress"
  if f:packbits or f:seedrow
    f compressed := memory_allocate 2*f:line_size+4 addressof:f
  if f:seedrow
    f previous_line := memory_zallocate f:line_size addressof:f
  if f:pclxl
    check h:gamut:pixel_size=1 or h:gamut:pixel_size=3
    s writechars ") HP-PCL XL;1;1;Pliant "+string:pliant_release_number+"[cr][lf]"
    s xl_uInt16 (cast h:size_x/(abs h:x1-h:x0)*25.4 uInt) (cast h:size_y/(abs h:y1-h:y0)*25.4 uInt) ; s xl_attr xl_aUnitsPerMeasure
    s xl_uInt8 xl_eInch ; s xl_attr xl_aMeasure
    s xl_uInt8 xl_eBackChAndErrPage ; s xl_attr xl_aErrorReport
    s xl_op xl_oBeginSession
    s xl_uInt8 xl_eBinaryLowByteFirst ; s xl_attr xl_aDataOrg
    s xl_uInt8 xl_eDefaultSource ; s xl_attr xl_aSourceType
    s xl_op xl_oOpenDataSource
    s xl_uInt8 xl_ePortraitOrientation ; s xl_attr xl_aOrientation
    s xl_uInt8 (cast (options option "pcl_media_size" Int (shunt h:x1-h:x0>210.001 or h:y1-h:y0>297.001 xl_eA3Paper xl_eA4Paper)) uInt) ; s xl_attr xl_aMediaSize
    s xl_op xl_oBeginPage
    s xl_uInt8 (shunt h:gamut:dimension=1 xl_eGrey xl_eRGB) ; s xl_attr xl_aColorSpace
    s xl_uInt8 xl_e8Bit ; s xl_attr xl_aPaletteDepth
    s xl_op xl_oSetColorSpace
    s xl_uInt16 0 0 ; s xl_attr xl_aPoint
    s xl_op xl_oSetCursor
    s xl_uInt8 xl_eDirectPixel ; s xl_attr xl_aColorMapping
    s xl_uInt8 xl_e8Bit ; s xl_attr xl_aColorDepth
    s xl_uInt16 (cast h:size_x uInt) ; s xl_attr xl_aSourceWidth
    s xl_uInt16 (cast h:size_y uInt) ; s xl_attr xl_aSourceHeight
    s xl_uInt16 (cast h:size_x uInt) (cast h:size_y uInt) ; s xl_attr xl_aDestinationSize
    s xl_op xl_oBeginImage
  else # pcl5
    var Float dpi := h:size_x/(abs h:x1-h:x0)*25.4
    s writechars escape+"E" # reset
    if f:hpgl
      s writechars escape+"%-12345X@PJL RESET[cr][lf]@PJL SET RESOLUTION = "+string:dpi+"[cr][lf]@PJL ENTER LANGUAGE = HPGL2[cr][lf]"
      s writechars escape+"%1B" # enter HP GL/2 mode
      s writechars "BP3,1,5,1;" # do not store file on the device disk and do not rotate automatically
      if (options option "hpgl_page")
        var Int nx := cast 1016.0*h:size_x/dpi+0.5 Int
        var Int ny := cast 1016.0*h:size_y/dpi+0.5 Int
        s writechars "PS"+string:ny+","+string:nx+";" # set page size
      else
        s writechars "PS;" # no page clip
      s writechars escape+"%0A" # enter HP RTL mode
    if not (options option "pcl_no_paper_size")
      # A4 = 26 , A3 = 27 , A3+ = 16, custom = 101
      s writechars escape+"&l"+(options option "pcl_paper_size" Str (shunt h:x1-h:x0>(options option "pcl_a4_size_x" Float 210.001) or h:y1-h:y0>(options option "pcl_a4_size_y" Float 297.001) "27" "26"))+"A" # paper size
    if (options option "pcl_no_perforation_skip")
      s writechars escape+"&l0L" # Turn off perforation skip
    s writechars escape+"&a1N" # No negative motion - allow plotting while receiving
    if (options option "pcl_dither")
      if h:gamut:dimension=1
        s writechars escape+"*r1U"
        if h:gamut:model=color_gamut_additive
          f negative := memory_allocate f:line_size addressof:f
      eif h:gamut:model=color_gamut_additive
        check h:gamut:pixel_size=3
        s writechars escape+"*r"+(string h:gamut:dimension)+"U"
      else
        check h:gamut:pixel_size=3 or h:gamut:pixel_size=4
        s writechars escape+"*r"+(string -(h:gamut:dimension))+"U"
      f plan := memory_allocate f:size_x addressof:f
      f bits := memory_allocate (f:size_x+7)\8 addressof:f
      f:dither size := h:gamut dimension
      for (var Int i) 0  h:gamut:dimension-1
        var Pointer:DitherMatrix dither :> f:dither i
        dither := dither_matrix i ""
        for (var Int y) 0 dither:size_y-1
          for (var Int x) 0 dither:size_x-1
            var Float d := (dither x y)/(dither:size_x*dither:size_y)
            d := dot_unadjust d "header [dq]pcl_"+(h:gamut query "component_name "+string:i)+"[dq] header2 [dq]pcl_[dq] "+options
            dither x y := max (cast d*255 Int) 1
      if f:gamut:dimension>1 and f:seedrow
        f packbits := true
        f seedrow := false
    else
      if h:gamut:dimension=1
        s writechars escape+"*v6W"+character:0+character:1+character:8+character:0+character:0+character:0
        for (var Int i) 0 255
          for (var Int c) 0 2 
            s writechars escape+"*v"+string:(shunt h:gamut:model=color_gamut_additive i 255-i)+(character "A":number+c)
          s writechars escape+"*v"+string:i+"I"
        s writechars escape+"&b1M"
      else # RGB
        check h:gamut:model=color_gamut_additive and h:gamut:dimension=3
        var Int color_model := shunt (options option "sRGB") 2 0 # 0 = device RGB, 1 = device CMY, 2 = sRGB
        s writechars escape+"*v6W"+character:color_model+character:3+character:0+character:8+character:8+character:8 # select 3 bytes per pixel trivial encoding
    s writechars escape+"*t"+string:(cast dpi Int)+"R" # set resolution
    s writechars escape+"*r"+(string h:size_x)+"S" # number of pixels per line
    s writechars escape+"*r"+(string h:size_y)+"T" # number of rows
    s writechars escape+"*r1A" # start raster graphics at current position, no scaling requested
    if f:always_compress
      s writechars escape+"*b"+(shunt f:seedrow "3" f:packbits "2" "0")+"M" # select compression
  f current_y := 0
  status := success


method f writeline adr -> status
  arg_rw ImageWriteFilterPcl f ; arg Address adr ; arg Status status
  var Pointer:Stream s :> f stream
  if f:seedrow
    var Int csize := seedrow_encode adr f:buffer f:line_size f:previous_line
    s writechars escape+"*b3m"+string:csize+"W"
    s raw_write f:buffer csize
    memory_copy adr f:previous_line f:line_size
  eif f:packbits
    var Int csize := packbits_encode adr f:buffer f:line_size
    s writechars escape+"*b2m"+string:csize+"W"
    s raw_write f:buffer csize
  else
    s writechars escape+"*b0m"+(string f:line_size)+"W"
    s raw_write adr f:line_size
  var Address line := adr ; var Int size := f line_size
  if f:negative<>null
    bytes_copy_255minus line 1 f:negative 1 f:line_size
    line := f negative
  for (var Int i) 0 (shunt f:plan<>null f:gamut:dimension-1 0)
    var Address memo_line := line ; var Int memo_size := size
    if f:plan<>null
      bytes_copy (line translate Byte (i+(shunt f:gamut:dimension=4 3 0))%4) f:gamut:pixel_size f:plan 1 f:size_x
      line := f plan ; size := f size_x
    if f:bits<>null
      memory_clear f:bits (size+7)\8
      var Address src := line
      var Address stop := line translate uInt8 size
      var Address dest := f bits ; var Int shift := 7
      var Address dither := addressof (f:dither:i 0 f:current_y%f:dither:i:size_y) ; var Int dx := 0 ; var Int dm := f:dither:i:size_x
      while src<>stop
        if (src map uInt8)>=(dither map Int dx)
          dest map uInt8 += 2^shift
        src := src translate uInt8
        dx += 1
        if dx=dm
          dx := 0
        if shift>0
          shift -= 1
        else
          dest := dest translate uInt8 1 ; shift := 7
      line := f bits ; size := (size+7)\8
    var Int cmode := 0
    if f:seedrow
      var Int csize := seedrow_encode line f:compressed size f:previous_line
      memory_copy line f:previous_line size
      if csize<size or f:always_compress
        line := f compressed ; size := csize
        cmode := 3
    eif f:packbits
      var Int csize := packbits_encode line f:compressed size
      if csize<size or f:always_compress
        line := f compressed ; size := csize
        cmode := 2
    if f:pclxl
      s xl_uInt16 (cast f:current_y uInt) ; s xl_attr xl_aStartLine
      s xl_uInt16 1 ; s xl_attr xl_aBlocHeight
      s xl_uInt8 (shunt cmode=3 xl_eDeltaRowCompression xl_eNoCompression) ; s xl_attr xl_aCompressMode
      s xl_uInt8 1 ; s xl_attr xl_aPadBytesMultiple
      s xl_op xl_oReadImage
      s xl_length size
      s raw_write line size
    else
      s writechars escape+"*b"+string:cmode+"m"+string:size+"W"
      s raw_write line size
    line := memo_line ; size := memo_size
  f current_y += 1
  status := success


method f close -> status
  arg_rw ImageWriteFilterPcl f ; arg ExtendedStatus status
  if f:seedrow
    memory_free f:previous_line
  memory_free f:buffer
  memory_free f:negative
  memory_free f:plan
  memory_free f:bits
  memory_free f:compressed
  memory_free f:previous_line
  var Pointer:Stream s :> f stream
  s writechars escape+"*rC" # end raster graphics
  if f:hpgl
    s writechars escape+"%1B" # back to HP GL/2
    s writechars "PG;" # end of job: eject page or advance roll
  s writechars escape+"E" # reset
  if f:pclxl
    s xl_op xl_oEndImage
    s xl_op xl_oEndPage
    s xl_op xl_oCloseDataSource
    s xl_op xl_oEndSession
  else # pcl5
    s writechars escape+"*rC" # end raster graphics
    if f:hpgl
      s writechars escape+"%1B" # back to HP GL/2
      s writechars "PG;" # end of job: eject page or advance roll
    s writechars escape+"E" # reset
  status := success


image_record_filters ".pcl" Void false ImageWriteFilterPcl false